1/* Convert language-specific tree expression to rtl instructions, 2 for GNU CHILL compiler. 3 Copyright (C) 1992, 93, 1994, 1998, 1999 Free Software Foundation, Inc. 4 5This file is part of GNU CC. 6 7GNU CC is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU CC is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU CC; see the file COPYING. If not, write to 19the Free Software Foundation, 59 Temple Place - Suite 330, 20Boston, MA 02111-1307, USA. */ 21 22 23#include "config.h" 24#include "system.h" 25#include "rtl.h" 26#include "tree.h" 27#include "flags.h" 28#include "expr.h" 29#include "ch-tree.h" 30#include "assert.h" 31#include "lex.h" 32#include "convert.h" 33#include "toplev.h" 34 35extern char **boolean_code_name; 36extern int flag_old_strings; 37extern tree long_unsigned_type_node; 38extern int ignore_case; 39extern int special_UC; 40 41/* definitions for duration built-ins */ 42#define MILLISECS_MULTIPLIER 1 43#define SECS_MULTIPLIER MILLISECS_MULTIPLIER * 1000 44#define MINUTES_MULTIPLIER SECS_MULTIPLIER * 60 45#define HOURS_MULTIPLIER MINUTES_MULTIPLIER * 60 46#define DAYS_MULTIPLIER HOURS_MULTIPLIER * 24 47 48/* the maximum value for each of the calls */ 49#define MILLISECS_MAX 0xffffffff 50#define SECS_MAX 4294967 51#define MINUTES_MAX 71582 52#define HOURS_MAX 1193 53#define DAYS_MAX 49 54 55/* forward declaration */ 56rtx chill_expand_expr PROTO((tree, rtx, enum machine_mode, 57 enum expand_modifier)); 58 59/* variable to hold the type the DESCR built-in returns */ 60static tree descr_type = NULL_TREE; 61 62 63/* called from ch-lex.l */ 64void 65init_chill_expand () 66{ 67 lang_expand_expr = chill_expand_expr; 68} 69 70/* Take the address of something that needs to be passed by reference. */ 71tree 72force_addr_of (value) 73 tree value; 74{ 75 /* FIXME. Move to memory, if needed. */ 76 if (TREE_CODE (value) == INDIRECT_REF) 77 return convert_to_pointer (ptr_type_node, TREE_OPERAND (value, 0)); 78 mark_addressable (value); 79 return build1 (ADDR_EXPR, ptr_type_node, value); 80} 81 82/* Check that EXP has a known type. */ 83 84tree 85check_have_mode (exp, context) 86 tree exp; 87 char *context; 88{ 89 if (TREE_CODE (exp) != ERROR_MARK && TREE_TYPE (exp) == NULL_TREE) 90 { 91 if (TREE_CODE (exp) == CONSTRUCTOR) 92 error ("tuple without specified mode not allowed in %s", context); 93 else if (TREE_CODE (exp) == COND_EXPR || TREE_CODE (exp) == CASE_EXPR) 94 error ("conditional expression not allowed in %s", context); 95 else 96 error ("internal error: unknown expression mode in %s", context); 97 98 return error_mark_node; 99 } 100 return exp; 101} 102 103/* Check that EXP is discrete. Handle conversion if flag_old_strings. */ 104 105tree 106check_case_selector (exp) 107 tree exp; 108{ 109 if (exp != NULL_TREE && TREE_TYPE (exp) != NULL_TREE) 110 exp = convert_to_discrete (exp); 111 if (exp) 112 return exp; 113 error ("CASE selector is not a discrete expression"); 114 return error_mark_node; 115} 116 117tree 118check_case_selector_list (list) 119 tree list; 120{ 121 tree selector, exp, return_list = NULL_TREE; 122 123 for (selector = list; selector != NULL_TREE; selector = TREE_CHAIN (selector)) 124 { 125 exp = check_case_selector (TREE_VALUE (selector)); 126 if (exp == error_mark_node) 127 { 128 return_list = error_mark_node; 129 break; 130 } 131 return_list = tree_cons (TREE_PURPOSE (selector), exp, return_list); 132 } 133 134 return nreverse(return_list); 135} 136 137tree 138chill_expand_case_expr (expr) 139 tree expr; 140{ 141 tree selector_list = TREE_OPERAND (expr, 0), selector; 142 tree alternatives = TREE_OPERAND (expr, 1); 143 tree type = TREE_TYPE (expr); 144 int else_seen = 0; 145 tree result; 146 147 if (TREE_CODE (selector_list) != TREE_LIST 148 || TREE_CODE (alternatives) != TREE_LIST) 149 abort(); 150 if (TREE_CHAIN (selector_list) != NULL_TREE) 151 abort (); 152 153 /* make a temp for the case result */ 154 result = decl_temp1 (get_unique_identifier ("CASE_EXPR"), 155 type, 0, NULL_TREE, 0, 0); 156 157 selector = check_case_selector (TREE_VALUE (selector_list)); 158 159 expand_start_case (1, selector, TREE_TYPE (selector), "CASE expression"); 160 161 alternatives = nreverse (alternatives); 162 for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives)) 163 { 164 tree labels = TREE_PURPOSE (alternatives), t; 165 166 if (labels == NULL_TREE) 167 { 168 chill_handle_case_default (); 169 else_seen++; 170 } 171 else 172 { 173 tree label; 174 if (labels != NULL_TREE) 175 { 176 for (label = TREE_VALUE (labels); 177 label != NULL_TREE; label = TREE_CHAIN (label)) 178 chill_handle_case_label (TREE_VALUE (label), selector); 179 labels = TREE_CHAIN (labels); 180 if (labels != NULL_TREE) 181 error ("The number of CASE selectors does not match the number " 182 "of CASE label lists"); 183 184 } 185 } 186 187 t = build (MODIFY_EXPR, type, result, 188 convert (type, TREE_VALUE (alternatives))); 189 TREE_SIDE_EFFECTS (t) = 1; 190 expand_expr_stmt (t); 191 expand_exit_something (); 192 } 193 194 if (!else_seen) 195 { 196 chill_handle_case_default (); 197 expand_exit_something (); 198#if 0 199 expand_raise (); 200#endif 201 202 check_missing_cases (TREE_TYPE (selector)); 203 } 204 205 expand_end_case (selector); 206 return result; 207} 208 209/* Hook used by expand_expr to expand CHILL-specific tree codes. */ 210 211rtx 212chill_expand_expr (exp, target, tmode, modifier) 213 tree exp; 214 rtx target; 215 enum machine_mode tmode; 216 enum expand_modifier modifier; 217{ 218 tree type = TREE_TYPE (exp); 219 register enum machine_mode mode = TYPE_MODE (type); 220 register enum tree_code code = TREE_CODE (exp); 221 rtx original_target = target; 222 rtx op0, op1; 223 int ignore = target == const0_rtx; 224 char *lib_func; /* name of library routine */ 225 226 if (ignore) 227 target = 0, original_target = 0; 228 229 /* No sense saving up arithmetic to be done 230 if it's all in the wrong mode to form part of an address. 231 And force_operand won't know whether to sign-extend or zero-extend. */ 232 233 if (mode != Pmode && modifier == EXPAND_SUM) 234 modifier = EXPAND_NORMAL; 235 236 switch (code) 237 { 238 case STRING_EQ_EXPR: 239 case STRING_LT_EXPR: 240 { 241 rtx func = gen_rtx (SYMBOL_REF, Pmode, 242 code == STRING_EQ_EXPR ? "__eqstring" 243 : "__ltstring"); 244 tree exp0 = TREE_OPERAND (exp, 0); 245 tree exp1 = TREE_OPERAND (exp, 1); 246 tree size0, size1; 247 rtx op0, op1, siz0, siz1; 248 if (chill_varying_type_p (TREE_TYPE (exp0))) 249 { 250 exp0 = save_if_needed (exp0); 251 size0 = convert (integer_type_node, 252 build_component_ref (exp0, var_length_id)); 253 exp0 = build_component_ref (exp0, var_data_id); 254 } 255 else 256 size0 = size_in_bytes (TREE_TYPE (exp0)); 257 if (chill_varying_type_p (TREE_TYPE (exp1))) 258 { 259 exp1 = save_if_needed (exp1); 260 size1 = convert (integer_type_node, 261 build_component_ref (exp1, var_length_id)); 262 exp1 = build_component_ref (exp1, var_data_id); 263 } 264 else 265 size1 = size_in_bytes (TREE_TYPE (exp1)); 266 267 op0 = expand_expr (force_addr_of (exp0), 268 NULL_RTX, MEM, EXPAND_CONST_ADDRESS); 269 op1 = expand_expr (force_addr_of (exp1), 270 NULL_RTX, MEM, EXPAND_CONST_ADDRESS); 271 siz0 = expand_expr (size0, NULL_RTX, VOIDmode, 0); 272 siz1 = expand_expr (size1, NULL_RTX, VOIDmode, 0); 273 return emit_library_call_value (func, target, 274 0, QImode, 4, 275 op0, GET_MODE (op0), 276 siz0, TYPE_MODE (sizetype), 277 op1, GET_MODE (op1), 278 siz1, TYPE_MODE (sizetype)); 279 } 280 281 case CASE_EXPR: 282 return expand_expr (chill_expand_case_expr (exp), 283 NULL_RTX, VOIDmode, 0); 284 break; 285 286 case SLICE_EXPR: 287 { 288 tree func_call; 289 tree array = TREE_OPERAND (exp, 0); 290 tree min_value = TREE_OPERAND (exp, 1); 291 tree length = TREE_OPERAND (exp, 2); 292 tree new_type = TREE_TYPE (exp); 293 tree temp = decl_temp1 (get_unique_identifier ("BITSTRING"), 294 new_type, 0, NULL_TREE, 0, 0); 295 if (! CH_REFERABLE (array) && TYPE_MODE (TREE_TYPE (array)) != BLKmode) 296 array = decl_temp1 (get_unique_identifier ("BSTRINGVAL"), 297 TREE_TYPE (array), 0, array, 0, 0); 298 func_call = build_chill_function_call ( 299 lookup_name (get_identifier ("__psslice")), 300 tree_cons (NULL_TREE, 301 build_chill_addr_expr (temp, (char *)0), 302 tree_cons (NULL_TREE, length, 303 tree_cons (NULL_TREE, 304 force_addr_of (array), 305 tree_cons (NULL_TREE, powersetlen (array), 306 tree_cons (NULL_TREE, convert (integer_type_node, min_value), 307 tree_cons (NULL_TREE, length, NULL_TREE))))))); 308 expand_expr (func_call, const0_rtx, VOIDmode, 0); 309 emit_queue (); 310 return expand_expr (temp, ignore ? const0_rtx : target, 311 VOIDmode, 0); 312 } 313 314 /* void __concatstring (char *out, char *left, unsigned left_len, 315 char *right, unsigned right_len) */ 316 case CONCAT_EXPR: 317 { 318 tree exp0 = TREE_OPERAND (exp, 0); 319 tree exp1 = TREE_OPERAND (exp, 1); 320 rtx size0 = NULL_RTX, size1 = NULL_RTX; 321 rtx targetx; 322 323 if (TREE_CODE (exp1) == UNDEFINED_EXPR) 324 { 325 if (TYPE_MODE (TREE_TYPE (exp0)) == BLKmode 326 && TYPE_MODE (TREE_TYPE (exp)) == BLKmode) 327 { 328 rtx temp = expand_expr (exp0, target, tmode, modifier); 329 if (temp == target || target == NULL_RTX) 330 return temp; 331 emit_block_move (target, temp, expr_size (exp0), 332 TYPE_ALIGN (TREE_TYPE(exp0)) / BITS_PER_UNIT); 333 return target; 334 } 335 else 336 { 337 exp0 = force_addr_of (exp0); 338 exp0 = convert (build_pointer_type (TREE_TYPE (exp)), exp0); 339 exp0 = build1 (INDIRECT_REF, TREE_TYPE (exp), exp0); 340 return expand_expr (exp0, 341 NULL_RTX, Pmode, EXPAND_CONST_ADDRESS); 342 } 343 } 344 345 if (TREE_CODE (type) == ARRAY_TYPE) 346 { 347 /* No need to handle scalars or varying strings here, since that 348 was done in convert or build_concat_expr. */ 349 size0 = expand_expr (size_in_bytes (TREE_TYPE (exp0)), 350 NULL_RTX, Pmode, EXPAND_CONST_ADDRESS); 351 352 size1 = expand_expr (size_in_bytes (TREE_TYPE (exp1)), 353 NULL_RTX, Pmode, EXPAND_CONST_ADDRESS); 354 355 /* build a temp for the result, target is its address */ 356 if (target == NULL_RTX) 357 { 358 tree type0 = TREE_TYPE (exp0); 359 tree type1 = TREE_TYPE (exp1); 360 int len0 = int_size_in_bytes (type0); 361 int len1 = int_size_in_bytes (type1); 362 363 if (len0 < 0 && TYPE_ARRAY_MAX_SIZE (type0) 364 && TREE_CODE (TYPE_ARRAY_MAX_SIZE (type0)) == INTEGER_CST) 365 len0 = TREE_INT_CST_LOW (TYPE_ARRAY_MAX_SIZE (type0)); 366 367 if (len1 < 0 && TYPE_ARRAY_MAX_SIZE (type1) 368 && TREE_CODE (TYPE_ARRAY_MAX_SIZE (type1)) == INTEGER_CST) 369 len1 = TREE_INT_CST_LOW (TYPE_ARRAY_MAX_SIZE (type1)); 370 371 if (len0 < 0 || len1 < 0) 372 fatal ("internal error - don't know how much space is needed for concatenation"); 373 target = assign_stack_temp (mode, len0 + len1, 0); 374 preserve_temp_slots (target); 375 } 376 } 377 else if (TREE_CODE (type) == SET_TYPE) 378 { 379 if (target == NULL_RTX) 380 { 381 target = assign_stack_temp (mode, int_size_in_bytes (type), 0); 382 preserve_temp_slots (target); 383 } 384 } 385 else 386 abort (); 387 388 if (GET_CODE (target) == MEM) 389 targetx = target; 390 else 391 targetx = assign_stack_temp (mode, GET_MODE_SIZE (mode), 0); 392 393 /* expand 1st operand to a pointer to the array */ 394 op0 = expand_expr (force_addr_of (exp0), 395 NULL_RTX, MEM, EXPAND_CONST_ADDRESS); 396 397 /* expand 2nd operand to a pointer to the array */ 398 op1 = expand_expr (force_addr_of (exp1), 399 NULL_RTX, MEM, EXPAND_CONST_ADDRESS); 400 401 if (TREE_CODE (type) == SET_TYPE) 402 { 403 size0 = expand_expr (powersetlen (exp0), 404 NULL_RTX, VOIDmode, 0); 405 size1 = expand_expr (powersetlen (exp1), 406 NULL_RTX, VOIDmode, 0); 407 408 emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__concatps"), 409 0, Pmode, 5, XEXP (targetx, 0), Pmode, 410 op0, GET_MODE (op0), 411 convert_to_mode (TYPE_MODE (sizetype), 412 size0, TREE_UNSIGNED (sizetype)), 413 TYPE_MODE (sizetype), 414 op1, GET_MODE (op1), 415 convert_to_mode (TYPE_MODE (sizetype), 416 size1, TREE_UNSIGNED (sizetype)), 417 TYPE_MODE (sizetype)); 418 } 419 else 420 { 421 /* copy left, then right array to target */ 422 emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__concatstring"), 423 0, Pmode, 5, XEXP (targetx, 0), Pmode, 424 op0, GET_MODE (op0), 425 convert_to_mode (TYPE_MODE (sizetype), 426 size0, TREE_UNSIGNED (sizetype)), 427 TYPE_MODE (sizetype), 428 op1, GET_MODE (op1), 429 convert_to_mode (TYPE_MODE (sizetype), 430 size1, TREE_UNSIGNED (sizetype)), 431 TYPE_MODE (sizetype)); 432 } 433 if (targetx != target) 434 emit_move_insn (target, targetx); 435 return target; 436 } 437 438 /* FIXME: the set_length computed below is a compile-time constant; 439 you'll need to re-write that part for VARYING bit arrays, and 440 possibly the set pointer will need to be adjusted to point past 441 the word containing its dynamic length. */ 442 443 /* void __notpowerset (char *out, char *src, 444 unsigned long bitlength) */ 445 case SET_NOT_EXPR: 446 { 447 448 tree expr = TREE_OPERAND (exp, 0); 449 tree tsize = powersetlen (expr); 450 rtx targetx; 451 452 if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE) 453 tsize = fold (build (MULT_EXPR, sizetype, tsize, 454 size_int (BITS_PER_UNIT))); 455 456 /* expand 1st operand to a pointer to the set */ 457 op0 = expand_expr (force_addr_of (expr), 458 NULL_RTX, MEM, EXPAND_CONST_ADDRESS); 459 460 /* build a temp for the result, target is its address */ 461 if (target == NULL_RTX) 462 { 463 target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)), 464 int_size_in_bytes (TREE_TYPE (exp)), 465 0); 466 preserve_temp_slots (target); 467 } 468 if (GET_CODE (target) == MEM) 469 targetx = target; 470 else 471 targetx = assign_stack_temp (GET_MODE (target), 472 GET_MODE_SIZE (GET_MODE (target)), 473 0); 474 emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__notpowerset"), 475 0, VOIDmode, 3, XEXP (targetx, 0), Pmode, 476 op0, GET_MODE (op0), 477 expand_expr (tsize, NULL_RTX, MEM, 478 EXPAND_CONST_ADDRESS), 479 TYPE_MODE (long_unsigned_type_node)); 480 if (targetx != target) 481 emit_move_insn (target, targetx); 482 return target; 483 } 484 485 case SET_DIFF_EXPR: 486 lib_func = "__diffpowerset"; 487 goto format_2; 488 489 case SET_IOR_EXPR: 490 lib_func = "__orpowerset"; 491 goto format_2; 492 493 case SET_XOR_EXPR: 494 lib_func = "__xorpowerset"; 495 goto format_2; 496 497 /* void __diffpowerset (char *out, char *left, char *right, 498 unsigned bitlength) */ 499 case SET_AND_EXPR: 500 lib_func = "__andpowerset"; 501 format_2: 502 { 503 tree expr = TREE_OPERAND (exp, 0); 504 tree tsize = powersetlen (expr); 505 rtx targetx; 506 507 if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE) 508 tsize = fold (build (MULT_EXPR, long_unsigned_type_node, 509 tsize, 510 size_int (BITS_PER_UNIT))); 511 512 /* expand 1st operand to a pointer to the set */ 513 op0 = expand_expr (force_addr_of (expr), 514 NULL_RTX, MEM, EXPAND_CONST_ADDRESS); 515 516 /* expand 2nd operand to a pointer to the set */ 517 op1 = expand_expr (force_addr_of (TREE_OPERAND (exp, 1)), 518 NULL_RTX, MEM, 519 EXPAND_CONST_ADDRESS); 520 521/* FIXME: re-examine this code - the unary operator code above has recently 522 (93/03/12) been changed a lot. Should this code also change? */ 523 /* build a temp for the result, target is its address */ 524 if (target == NULL_RTX) 525 { 526 target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)), 527 int_size_in_bytes (TREE_TYPE (exp)), 528 0); 529 preserve_temp_slots (target); 530 } 531 if (GET_CODE (target) == MEM) 532 targetx = target; 533 else 534 targetx = assign_stack_temp (GET_MODE (target), 535 GET_MODE_SIZE (GET_MODE (target)), 0); 536 emit_library_call (gen_rtx(SYMBOL_REF, Pmode, lib_func), 537 0, VOIDmode, 4, XEXP (targetx, 0), Pmode, 538 op0, GET_MODE (op0), op1, GET_MODE (op1), 539 expand_expr (tsize, NULL_RTX, MEM, 540 EXPAND_CONST_ADDRESS), 541 TYPE_MODE (long_unsigned_type_node)); 542 if (target != targetx) 543 emit_move_insn (target, targetx); 544 return target; 545 } 546 547 case SET_IN_EXPR: 548 { 549 tree set = TREE_OPERAND (exp, 1); 550 tree pos = convert (long_unsigned_type_node, TREE_OPERAND (exp, 0)); 551 tree set_type = TREE_TYPE (set); 552 tree set_length = discrete_count (TYPE_DOMAIN (set_type)); 553 tree min_val = convert (long_integer_type_node, 554 TYPE_MIN_VALUE (TYPE_DOMAIN (set_type))); 555 tree fcall; 556 557 /* FIXME: Function-call not needed if pos and width are constant! */ 558 if (! mark_addressable (set)) 559 { 560 error ("powerset is not addressable"); 561 return const0_rtx; 562 } 563 /* we use different functions for bitstrings and powersets */ 564 if (CH_BOOLS_TYPE_P (set_type)) 565 fcall = 566 build_chill_function_call ( 567 lookup_name (get_identifier ("__inbitstring")), 568 tree_cons (NULL_TREE, 569 convert (long_unsigned_type_node, pos), 570 tree_cons (NULL_TREE, 571 build1 (ADDR_EXPR, build_pointer_type (set_type), set), 572 tree_cons (NULL_TREE, 573 convert (long_unsigned_type_node, set_length), 574 tree_cons (NULL_TREE, min_val, 575 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), 576 build_tree_list (NULL_TREE, get_chill_linenumber ()))))))); 577 else 578 fcall = 579 build_chill_function_call ( 580 lookup_name (get_identifier ("__inpowerset")), 581 tree_cons (NULL_TREE, 582 convert (long_unsigned_type_node, pos), 583 tree_cons (NULL_TREE, 584 build1 (ADDR_EXPR, build_pointer_type (set_type), set), 585 tree_cons (NULL_TREE, 586 convert (long_unsigned_type_node, set_length), 587 build_tree_list (NULL_TREE, min_val))))); 588 return expand_expr (fcall, NULL_RTX, VOIDmode, 0); 589 } 590 591 case PACKED_ARRAY_REF: 592 { 593 tree array = TREE_OPERAND (exp, 0); 594 tree pos = save_expr (TREE_OPERAND (exp, 1)); 595 tree array_type = TREE_TYPE (array); 596 tree array_length = discrete_count (TYPE_DOMAIN (array_type)); 597 tree min_val = convert (long_integer_type_node, 598 TYPE_MIN_VALUE (TYPE_DOMAIN (array_type))); 599 tree fcall; 600 601 /* FIXME: Function-call not needed if pos and width are constant! */ 602 /* TODO: make sure this makes sense. */ 603 if (! mark_addressable (array)) 604 { 605 error ("array is not addressable"); 606 return const0_rtx; 607 } 608 fcall = 609 build_chill_function_call ( 610 lookup_name (get_identifier ("__inpowerset")), 611 tree_cons (NULL_TREE, 612 convert (long_unsigned_type_node, pos), 613 tree_cons (NULL_TREE, 614 build1 (ADDR_EXPR, build_pointer_type (array_type), array), 615 tree_cons (NULL_TREE, 616 convert (long_unsigned_type_node, array_length), 617 build_tree_list (NULL_TREE, min_val))))); 618 return expand_expr (fcall, NULL_RTX, VOIDmode, 0); 619 } 620 621 case UNDEFINED_EXPR: 622 if (target == 0) 623 { 624 target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)), 625 int_size_in_bytes (TREE_TYPE (exp)), 0); 626 preserve_temp_slots (target); 627 } 628 /* We don't actually need to *do* anything ... */ 629 return target; 630 631 default: 632 break; 633 } 634 635 /* NOTREACHED */ 636 return NULL; 637} 638 639/* Check that the argument list has a length in [min_length .. max_length]. 640 (max_length == -1 means "infinite".) 641 If so return the actual length. 642 Otherwise, return an error message and return -1. */ 643 644static int 645check_arglist_length (args, min_length, max_length, name) 646 tree args; 647 int min_length; 648 int max_length; 649 tree name; 650{ 651 int length = list_length (args); 652 if (length < min_length) 653 error ("Too few arguments in call to `%s'", IDENTIFIER_POINTER (name)); 654 else if (max_length != -1 && length > max_length) 655 error ("Too many arguments in call to `%s'", IDENTIFIER_POINTER (name)); 656 else 657 return length; 658 return -1; 659} 660 661/* 662 * This is the code from c-typeck.c, with the C-specific cruft 663 * removed (possibly I just didn't understand it, but it was 664 * apparently simply discarding part of my LIST). 665 */ 666static tree 667internal_build_compound_expr (list, first_p) 668 tree list; 669 int first_p ATTRIBUTE_UNUSED; 670{ 671 register tree rest; 672 673 if (TREE_CHAIN (list) == 0) 674 return TREE_VALUE (list); 675 676 rest = internal_build_compound_expr (TREE_CHAIN (list), FALSE); 677 678 if (! TREE_SIDE_EFFECTS (TREE_VALUE (list))) 679 return rest; 680 681 return build (COMPOUND_EXPR, TREE_TYPE (rest), TREE_VALUE (list), rest); 682} 683 684 685/* Given a list of expressions, return a compound expression 686 that performs them all and returns the value of the last of them. */ 687/* FIXME: this should be merged with the C version */ 688tree 689build_chill_compound_expr (list) 690 tree list; 691{ 692 return internal_build_compound_expr (list, TRUE); 693} 694 695/* Given an expression PTR for a pointer, return an expression 696 for the value pointed to. 697 do_empty_check is 0, don't perform a NULL pointer check, 698 else do it. */ 699 700tree 701build_chill_indirect_ref (ptr, mode, do_empty_check) 702 tree ptr; 703 tree mode; 704 int do_empty_check; 705{ 706 register tree type; 707 708 if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK) 709 return ptr; 710 if (mode != NULL_TREE && TREE_CODE (mode) == ERROR_MARK) 711 return error_mark_node; 712 713 type = TREE_TYPE (ptr); 714 715 if (TREE_CODE (type) == REFERENCE_TYPE) 716 { 717 type = TREE_TYPE (type); 718 ptr = convert (type, ptr); 719 } 720 721 /* check for ptr is really a POINTER */ 722 if (TREE_CODE (type) != POINTER_TYPE) 723 { 724 error ("cannot dereference, not a pointer."); 725 return error_mark_node; 726 } 727 728 if (mode && TREE_CODE (mode) == IDENTIFIER_NODE) 729 { 730 tree decl = lookup_name (mode); 731 if (decl == NULL_TREE || TREE_CODE (decl) != TYPE_DECL) 732 { 733 if (pass == 2) 734 error ("missing '.' operator or undefined mode name `%s'.", 735 IDENTIFIER_POINTER (mode)); 736#if 0 737 error ("You have forgotten the '.' operator which must"); 738 error (" precede a STRUCT field reference, or `%s' is an undefined mode", 739 IDENTIFIER_POINTER (mode)); 740#endif 741 return error_mark_node; 742 } 743 } 744 745 if (mode) 746 { 747 mode = get_type_of (mode); 748 ptr = convert (build_pointer_type (mode), ptr); 749 } 750 else if (type == ptr_type_node) 751 { 752 error ("Can't dereference PTR value using unary `->'."); 753 return error_mark_node; 754 } 755 756 if (do_empty_check) 757 ptr = check_non_null (ptr); 758 759 type = TREE_TYPE (ptr); 760 761 if (TREE_CODE (type) == POINTER_TYPE) 762 { 763 if (TREE_CODE (ptr) == ADDR_EXPR 764 && !flag_volatile 765 && (TREE_TYPE (TREE_OPERAND (ptr, 0)) 766 == TREE_TYPE (type))) 767 return TREE_OPERAND (ptr, 0); 768 else 769 { 770 tree t = TREE_TYPE (type); 771 register tree ref = build1 (INDIRECT_REF, 772 TYPE_MAIN_VARIANT (t), ptr); 773 774 if (TYPE_SIZE (t) == 0 && TREE_CODE (t) != ARRAY_TYPE) 775 { 776 error ("dereferencing pointer to incomplete type"); 777 return error_mark_node; 778 } 779 if (TREE_CODE (t) == VOID_TYPE) 780 warning ("dereferencing `void *' pointer"); 781 782 /* We *must* set TREE_READONLY when dereferencing a pointer to const, 783 so that we get the proper error message if the result is used 784 to assign to. Also, &* is supposed to be a no-op. 785 And ANSI C seems to specify that the type of the result 786 should be the const type. */ 787 /* A de-reference of a pointer to const is not a const. It is valid 788 to change it via some other pointer. */ 789 TREE_READONLY (ref) = TYPE_READONLY (t); 790 TREE_SIDE_EFFECTS (ref) 791 = TYPE_VOLATILE (t) || TREE_SIDE_EFFECTS (ptr) || flag_volatile; 792 TREE_THIS_VOLATILE (ref) = TYPE_VOLATILE (t) || flag_volatile; 793 return ref; 794 } 795 } 796 else if (TREE_CODE (ptr) != ERROR_MARK) 797 error ("invalid type argument of `->'"); 798 return error_mark_node; 799} 800 801/* NODE is a COMPONENT_REF whose mode is an IDENTIFIER, 802 which is replaced by the proper FIELD_DECL. 803 Also do the right thing for variant records. */ 804 805tree 806resolve_component_ref (node) 807 tree node; 808{ 809 tree datum = TREE_OPERAND (node, 0); 810 tree field_name = TREE_OPERAND (node, 1); 811 tree type = TREE_TYPE (datum); 812 tree field; 813 if (TREE_CODE (datum) == ERROR_MARK) 814 return error_mark_node; 815 if (TREE_CODE (type) == REFERENCE_TYPE) 816 { 817 type = TREE_TYPE (type); 818 TREE_OPERAND (node, 0) = datum = convert (type, datum); 819 } 820 if (TREE_CODE (type) != RECORD_TYPE) 821 { 822 error ("operand of '.' is not a STRUCT"); 823 return error_mark_node; 824 } 825 826 TREE_READONLY (node) = TREE_READONLY (datum); 827 TREE_SIDE_EFFECTS (node) = TREE_SIDE_EFFECTS (datum); 828 829 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) 830 { 831 if (TREE_CODE (TREE_TYPE (field)) == UNION_TYPE) 832 { 833 tree variant; 834 for (variant = TYPE_FIELDS (TREE_TYPE (field)); 835 variant; variant = TREE_CHAIN (variant)) 836 { 837 tree vfield; 838 for (vfield = TYPE_FIELDS (TREE_TYPE (variant)); 839 vfield; vfield = TREE_CHAIN (vfield)) 840 { 841 if (DECL_NAME (vfield) == field_name) 842 { /* Found a variant field */ 843 datum = build (COMPONENT_REF, TREE_TYPE (field), 844 datum, field); 845 datum = build (COMPONENT_REF, TREE_TYPE (variant), 846 datum, variant); 847 TREE_OPERAND (node, 0) = datum; 848 TREE_OPERAND (node, 1) = vfield; 849 TREE_TYPE (node) = TREE_TYPE (vfield); 850 TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node)); 851#if 0 852 if (flag_testing_tags) 853 { 854 tree tagtest = NOT IMPLEMENTED; 855 tree tagf = ridpointers[(int) RID_RANGEFAIL]; 856 node = check_expression (node, tagtest, 857 tagf); 858 } 859#endif 860 return node; 861 } 862 } 863 } 864 } 865 866 if (DECL_NAME (field) == field_name) 867 { /* Found a fixed field */ 868 TREE_OPERAND (node, 1) = field; 869 TREE_TYPE (node) = TREE_TYPE (field); 870 TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node)); 871 return fold (node); 872 } 873 } 874 875 error ("No field named `%s'", IDENTIFIER_POINTER (field_name)); 876 return error_mark_node; 877} 878 879tree 880build_component_ref (datum, field_name) 881 tree datum, field_name; 882{ 883 tree node = build_nt (COMPONENT_REF, datum, field_name); 884 if (pass != 1) 885 node = resolve_component_ref (node); 886 return node; 887} 888 889/* 890 function checks (for build_chill_component_ref) if a given 891 type is really an instance type. CH_IS_INSTANCE_MODE is not 892 strict enough in this case, i.e. SYNMODE foo = STRUCT (a, b UINT) 893 is compatible to INSTANCE. */ 894 895static int 896is_really_instance (type) 897 tree type; 898{ 899 tree decl = TYPE_NAME (type); 900 901 if (decl == NULL_TREE) 902 /* this is not an instance */ 903 return 0; 904 905 if (DECL_NAME (decl) == ridpointers[(int)RID_INSTANCE]) 906 /* this is an instance */ 907 return 1; 908 909 if (TYPE_FIELDS (type) == TYPE_FIELDS (instance_type_node)) 910 /* we have a NEWMODE'd instance */ 911 return 1; 912 913 return 0; 914} 915 916/* This function is called by the parse. 917 Here we check if the user tries to access a field in a type which is 918 layouted as a structure but isn't like INSTANCE, BUFFER, EVENT, ASSOCIATION, 919 ACCESS, TEXT, or VARYING array or character string. 920 We don't do this in build_component_ref cause this function gets 921 called from the compiler to access fields in one of the above mentioned 922 modes. */ 923tree 924build_chill_component_ref (datum, field_name) 925 tree datum, field_name; 926{ 927 tree type = TREE_TYPE (datum); 928 if ((type != NULL_TREE && TREE_CODE (type) == RECORD_TYPE) && 929 ((CH_IS_INSTANCE_MODE (type) && is_really_instance (type)) || 930 CH_IS_BUFFER_MODE (type) || 931 CH_IS_EVENT_MODE (type) || CH_IS_ASSOCIATION_MODE (type) || 932 CH_IS_ACCESS_MODE (type) || CH_IS_TEXT_MODE (type) || 933 chill_varying_type_p (type))) 934 { 935 error ("operand of '.' is not a STRUCT"); 936 return error_mark_node; 937 } 938 return build_component_ref (datum, field_name); 939} 940 941/* 942 * Check for invalid binary operands & unary operands 943 * RIGHT is 1 if checking right operand or unary operand; 944 * it is 0 if checking left operand. 945 * 946 * return 1 if the given operand is NOT compatible as the 947 * operand of the given operator 948 * 949 * return 0 if they might be compatible 950 */ 951static int 952invalid_operand (code, type, right) 953 enum chill_tree_code code; 954 tree type; 955 int right; /* 1 if right operand */ 956{ 957 switch ((int)code) 958 { 959 case ADDR_EXPR: 960 break; 961 case BIT_AND_EXPR: 962 case BIT_IOR_EXPR: 963 case BIT_NOT_EXPR: 964 case BIT_XOR_EXPR: 965 goto relationals; 966 case CASE_EXPR: 967 break; 968 case CEIL_MOD_EXPR: 969 goto numerics; 970 case CONCAT_EXPR: /* must be static or varying char array */ 971 if (TREE_CODE (type) == CHAR_TYPE) 972 return 0; 973 if (TREE_CODE (type) == ARRAY_TYPE 974 && TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE) 975 return 0; 976 if (!chill_varying_type_p (type)) 977 return 1; 978 if (TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type))) 979 == CHAR_TYPE) 980 return 0; 981 else 982 return 1; 983 /* note: CHILL conditional expressions (COND_EXPR) won't come 984 * through here; they're routed straight to C-specific code */ 985 case EQ_EXPR: 986 return 0; /* ANYTHING can be compared equal */ 987 case FLOOR_MOD_EXPR: 988 if (TREE_CODE (type) == REAL_TYPE) 989 return 1; 990 goto numerics; 991 case GE_EXPR: 992 case GT_EXPR: 993 goto relatables; 994 case SET_IN_EXPR: 995 if (TREE_CODE (type) == SET_TYPE) 996 return 0; 997 else 998 return 1; 999 case PACKED_ARRAY_REF: 1000 if (TREE_CODE (type) == ARRAY_TYPE) 1001 return 0; 1002 else 1003 return 1; 1004 case LE_EXPR: 1005 case LT_EXPR: 1006 relatables: 1007 switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */ 1008 { 1009 case ARRAY_TYPE: 1010 if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE) 1011 return 0; 1012 else 1013 return 1; 1014 case BOOLEAN_TYPE: 1015 case CHAR_TYPE: 1016 case COMPLEX_TYPE: 1017 case ENUMERAL_TYPE: 1018 case INTEGER_TYPE: 1019 case OFFSET_TYPE: 1020 case POINTER_TYPE: 1021 case REAL_TYPE: 1022 case SET_TYPE: 1023 return 0; 1024 case FILE_TYPE: 1025 case FUNCTION_TYPE: 1026 case GRANT_TYPE: 1027 case LANG_TYPE: 1028 case METHOD_TYPE: 1029 return 1; 1030 case RECORD_TYPE: 1031 if (chill_varying_type_p (type) 1032 && TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type))) == CHAR_TYPE) 1033 return 0; 1034 else 1035 return 1; 1036 case REFERENCE_TYPE: 1037 case SEIZE_TYPE: 1038 case UNION_TYPE: 1039 case VOID_TYPE: 1040 return 1; 1041 } 1042 break; 1043 case MINUS_EXPR: 1044 case MULT_EXPR: 1045 goto numerics; 1046 case NEGATE_EXPR: 1047 if (TREE_CODE (type) == BOOLEAN_TYPE) 1048 return 0; 1049 else 1050 goto numerics; 1051 case NE_EXPR: 1052 return 0; /* ANYTHING can be compared unequal */ 1053 case NOP_EXPR: 1054 return 0; /* ANYTHING can be converted */ 1055 case PLUS_EXPR: 1056 numerics: 1057 switch ((int)TREE_CODE(type)) /* left operand must be discrete type */ 1058 { 1059 case ARRAY_TYPE: 1060 if (right || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE) 1061 return 1; 1062 else 1063 return 0; 1064 case CHAR_TYPE: 1065 return right; 1066 case BOOLEAN_TYPE: 1067 case COMPLEX_TYPE: 1068 case FILE_TYPE: 1069 case FUNCTION_TYPE: 1070 case GRANT_TYPE: 1071 case LANG_TYPE: 1072 case METHOD_TYPE: 1073 case RECORD_TYPE: 1074 case REFERENCE_TYPE: 1075 case SEIZE_TYPE: 1076 case UNION_TYPE: 1077 case VOID_TYPE: 1078 return 1; 1079 case ENUMERAL_TYPE: 1080 case INTEGER_TYPE: 1081 case OFFSET_TYPE: 1082 case POINTER_TYPE: 1083 case REAL_TYPE: 1084 case SET_TYPE: 1085 return 0; 1086 } 1087 break; 1088 case RANGE_EXPR: 1089 break; 1090 1091 case REPLICATE_EXPR: 1092 switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */ 1093 { 1094 case COMPLEX_TYPE: 1095 case FILE_TYPE: 1096 case FUNCTION_TYPE: 1097 case GRANT_TYPE: 1098 case LANG_TYPE: 1099 case METHOD_TYPE: 1100 case OFFSET_TYPE: 1101 case POINTER_TYPE: 1102 case RECORD_TYPE: 1103 case REAL_TYPE: 1104 case SEIZE_TYPE: 1105 case UNION_TYPE: 1106 case VOID_TYPE: 1107 return 1; 1108 case ARRAY_TYPE: 1109 case BOOLEAN_TYPE: 1110 case CHAR_TYPE: 1111 case ENUMERAL_TYPE: 1112 case INTEGER_TYPE: 1113 case REFERENCE_TYPE: 1114 case SET_TYPE: 1115 return 0; 1116 } 1117 1118 case TRUNC_DIV_EXPR: 1119 goto numerics; 1120 case TRUNC_MOD_EXPR: 1121 if (TREE_CODE (type) == REAL_TYPE) 1122 return 1; 1123 goto numerics; 1124 case TRUTH_ANDIF_EXPR: 1125 case TRUTH_AND_EXPR: 1126 case TRUTH_NOT_EXPR: 1127 case TRUTH_ORIF_EXPR: 1128 case TRUTH_OR_EXPR: 1129 relationals: 1130 switch ((int)TREE_CODE(type)) /* left operand must be discrete type */ 1131 { 1132 case ARRAY_TYPE: 1133 case CHAR_TYPE: 1134 case COMPLEX_TYPE: 1135 case ENUMERAL_TYPE: 1136 case FILE_TYPE: 1137 case FUNCTION_TYPE: 1138 case GRANT_TYPE: 1139 case INTEGER_TYPE: 1140 case LANG_TYPE: 1141 case METHOD_TYPE: 1142 case OFFSET_TYPE: 1143 case POINTER_TYPE: 1144 case REAL_TYPE: 1145 case RECORD_TYPE: 1146 case REFERENCE_TYPE: 1147 case SEIZE_TYPE: 1148 case UNION_TYPE: 1149 case VOID_TYPE: 1150 return 1; 1151 case BOOLEAN_TYPE: 1152 case SET_TYPE: 1153 return 0; 1154 } 1155 break; 1156 1157 default: 1158 return 1; /* perhaps you forgot to add a new DEFTREECODE? */ 1159 } 1160 return 1; 1161} 1162 1163 1164static int 1165invalid_right_operand (code, type) 1166 enum chill_tree_code code; 1167 tree type; 1168{ 1169 return invalid_operand (code, type, 1); 1170} 1171 1172tree 1173build_chill_abs (expr) 1174 tree expr; 1175{ 1176 tree temp; 1177 1178 if (TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE 1179 || discrete_type_p (TREE_TYPE (expr))) 1180 temp = fold (build1 (ABS_EXPR, TREE_TYPE (expr), expr)); 1181 else 1182 { 1183 error("ABS argument must be discrete or real mode"); 1184 return error_mark_node; 1185 } 1186 /* FIXME: should call 1187 * cond_type_range_exception (temp); 1188 */ 1189 return temp; 1190} 1191 1192tree 1193build_chill_abstime (exprlist) 1194 tree exprlist; 1195{ 1196 int mask = 0, i, numargs; 1197 tree args = NULL_TREE; 1198 tree filename, lineno; 1199 int had_errors = 0; 1200 tree tmp; 1201 1202 if (exprlist != NULL_TREE && TREE_CODE (exprlist) == ERROR_MARK) 1203 return error_mark_node; 1204 1205 /* check for integer expressions */ 1206 i = 1; 1207 tmp = exprlist; 1208 while (tmp != NULL_TREE) 1209 { 1210 tree exp = TREE_VALUE (tmp); 1211 1212 if (exp == NULL_TREE || TREE_CODE (exp) == ERROR_MARK) 1213 had_errors = 1; 1214 else if (TREE_CODE (TREE_TYPE (exp)) != INTEGER_TYPE) 1215 { 1216 error ("argument %d to ABSTIME must be of integer type.", i); 1217 had_errors = 1; 1218 } 1219 tmp = TREE_CHAIN (tmp); 1220 i++; 1221 } 1222 if (had_errors) 1223 return error_mark_node; 1224 1225 numargs = list_length (exprlist); 1226 for (i = 0; i < numargs; i++) 1227 mask |= (1 << i); 1228 1229 /* make it all arguments */ 1230 for (i = numargs; i < 6; i++) 1231 exprlist = tree_cons (NULL_TREE, integer_zero_node, exprlist); 1232 1233 args = tree_cons (NULL_TREE, build_int_2 (mask, 0), exprlist); 1234 1235 filename = force_addr_of (get_chill_filename ()); 1236 lineno = get_chill_linenumber (); 1237 args = chainon (args, tree_cons (NULL_TREE, filename, 1238 tree_cons (NULL_TREE, lineno, NULL_TREE))); 1239 1240 return build_chill_function_call ( 1241 lookup_name (get_identifier ("_abstime")), args); 1242} 1243 1244 1245tree 1246build_allocate_memory_call (ptr, size) 1247 tree ptr, size; 1248{ 1249 int err = 0; 1250 1251 /* check for ptr is referable */ 1252 if (! CH_REFERABLE (ptr)) 1253 { 1254 error ("parameter 1 must be referable."); 1255 err++; 1256 } 1257 /* check for pointer */ 1258 else if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE) 1259 { 1260 error ("mode mismatch in parameter 1."); 1261 err++; 1262 } 1263 1264 /* check for size > 0 if it is a constant */ 1265 if (TREE_CODE (size) == INTEGER_CST && TREE_INT_CST_LOW (size) <= 0) 1266 { 1267 error ("parameter 2 must be a positive integer."); 1268 err++; 1269 } 1270 if (err) 1271 return error_mark_node; 1272 1273 if (TREE_TYPE (ptr) != ptr_type_node) 1274 ptr = build_chill_cast (ptr_type_node, ptr); 1275 1276 return build_chill_function_call ( 1277 lookup_name (get_identifier ("_allocate_memory")), 1278 tree_cons (NULL_TREE, ptr, 1279 tree_cons (NULL_TREE, size, 1280 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), 1281 tree_cons (NULL_TREE, get_chill_linenumber (), 1282 NULL_TREE))))); 1283} 1284 1285 1286tree 1287build_allocate_global_memory_call (ptr, size) 1288 tree ptr, size; 1289{ 1290 int err = 0; 1291 1292 /* check for ptr is referable */ 1293 if (! CH_REFERABLE (ptr)) 1294 { 1295 error ("parameter 1 must be referable."); 1296 err++; 1297 } 1298 /* check for pointer */ 1299 else if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE) 1300 { 1301 error ("mode mismatch in parameter 1."); 1302 err++; 1303 } 1304 1305 /* check for size > 0 if it is a constant */ 1306 if (TREE_CODE (size) == INTEGER_CST && TREE_INT_CST_LOW (size) <= 0) 1307 { 1308 error ("parameter 2 must be a positive integer."); 1309 err++; 1310 } 1311 if (err) 1312 return error_mark_node; 1313 1314 if (TREE_TYPE (ptr) != ptr_type_node) 1315 ptr = build_chill_cast (ptr_type_node, ptr); 1316 1317 return build_chill_function_call ( 1318 lookup_name (get_identifier ("_allocate_global_memory")), 1319 tree_cons (NULL_TREE, ptr, 1320 tree_cons (NULL_TREE, size, 1321 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), 1322 tree_cons (NULL_TREE, get_chill_linenumber (), 1323 NULL_TREE))))); 1324} 1325 1326 1327tree 1328build_return_memory (ptr) 1329 tree ptr; 1330{ 1331 /* check input */ 1332 if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK) 1333 return error_mark_node; 1334 1335 /* check for pointer */ 1336 if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE) 1337 { 1338 error ("mode mismatch in parameter 1."); 1339 return error_mark_node; 1340 } 1341 1342 if (TREE_TYPE (ptr) != ptr_type_node) 1343 ptr = build_chill_cast (ptr_type_node, ptr); 1344 1345 return build_chill_function_call ( 1346 lookup_name (get_identifier ("_return_memory")), 1347 tree_cons (NULL_TREE, ptr, 1348 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), 1349 tree_cons (NULL_TREE, get_chill_linenumber (), 1350 NULL_TREE)))); 1351} 1352 1353 1354/* Compute the number of runtime members of the 1355 * given powerset. 1356 */ 1357tree 1358build_chill_card (powerset) 1359 tree powerset; 1360{ 1361 if (pass == 2) 1362 { 1363 tree temp; 1364 tree card_func = lookup_name (get_identifier ("__cardpowerset")); 1365 1366 if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK) 1367 return error_mark_node; 1368 1369 if (TREE_CODE (powerset) == IDENTIFIER_NODE) 1370 powerset = lookup_name (powerset); 1371 1372 if (TREE_CODE (TREE_TYPE(powerset)) == SET_TYPE) 1373 { int size; 1374 1375 /* Do constant folding, if possible. */ 1376 if (TREE_CODE (powerset) == CONSTRUCTOR 1377 && TREE_CONSTANT (powerset) 1378 && (size = int_size_in_bytes (TREE_TYPE (powerset))) >= 0) 1379 { 1380 int bit_size = size * BITS_PER_UNIT; 1381 char* buffer = (char*) alloca (bit_size); 1382 temp = get_set_constructor_bits (powerset, buffer, bit_size); 1383 if (!temp) 1384 { int i; 1385 int count = 0; 1386 for (i = 0; i < bit_size; i++) 1387 if (buffer[i]) 1388 count++; 1389 temp = build_int_2 (count, 0); 1390 TREE_TYPE (temp) = TREE_TYPE (TREE_TYPE (card_func)); 1391 return temp; 1392 } 1393 } 1394 temp = build_chill_function_call (card_func, 1395 tree_cons (NULL_TREE, force_addr_of (powerset), 1396 tree_cons (NULL_TREE, powersetlen (powerset), NULL_TREE))); 1397 /* FIXME: should call 1398 * cond_type_range_exception (op0); 1399 */ 1400 return temp; 1401 } 1402 error("CARD argument must be powerset mode"); 1403 return error_mark_node; 1404 } 1405 return NULL_TREE; 1406} 1407 1408/* function to build the type needed for the DESCR-built-in 1409 */ 1410 1411void build_chill_descr_type () 1412{ 1413 tree decl1, decl2; 1414 1415 if (descr_type != NULL_TREE) 1416 /* already done */ 1417 return; 1418 1419 decl1 = build_decl (FIELD_DECL, get_identifier ("datap"), ptr_type_node); 1420 decl2 = build_decl (FIELD_DECL, get_identifier ("len"), 1421 TREE_TYPE (lookup_name ( 1422 get_identifier ((ignore_case || ! special_UC) ? "ulong" : "ULONG")))); 1423 TREE_CHAIN (decl1) = decl2; 1424 TREE_CHAIN (decl2) = NULL_TREE; 1425 decl2 = build_chill_struct_type (decl1); 1426 descr_type = build_decl (TYPE_DECL, get_identifier ("__tmp_DESCR_type"), decl2); 1427 pushdecl (descr_type); 1428 DECL_SOURCE_LINE (descr_type) = 0; 1429 satisfy_decl (descr_type, 0); 1430} 1431 1432/* build a pointer to a descriptor. 1433 * descriptor = STRUCT (datap PTR, 1434 * len ULONG); 1435 * This descriptor is build in variable descr_type. 1436 */ 1437 1438tree 1439build_chill_descr (expr) 1440 tree expr; 1441{ 1442 if (pass == 2) 1443 { 1444 tree tuple, decl, descr_var, datap, len, tmp; 1445 int is_static; 1446 1447 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 1448 return error_mark_node; 1449 1450 /* check for expression is referable */ 1451 if (! CH_REFERABLE (expr)) 1452 { 1453 error ("expression for DESCR-builtin must be referable."); 1454 return error_mark_node; 1455 } 1456 1457 mark_addressable (expr); 1458#if 0 1459 datap = build1 (ADDR_EXPR, build_chill_pointer_type (descr_type), expr); 1460#else 1461 datap = build_chill_arrow_expr (expr, 1); 1462#endif 1463 len = size_in_bytes (TREE_TYPE (expr)); 1464 1465 descr_var = get_unique_identifier ("DESCR"); 1466 tuple = build_nt (CONSTRUCTOR, NULL_TREE, 1467 tree_cons (NULL_TREE, datap, 1468 tree_cons (NULL_TREE, len, NULL_TREE))); 1469 1470 is_static = (current_function_decl == global_function_decl) && TREE_STATIC (expr); 1471 decl = decl_temp1 (descr_var, TREE_TYPE (descr_type), is_static, 1472 tuple, 0, 0); 1473#if 0 1474 tmp = force_addr_of (decl); 1475#else 1476 tmp = build_chill_arrow_expr (decl, 1); 1477#endif 1478 return tmp; 1479 } 1480 return NULL_TREE; 1481} 1482 1483/* this function process the builtin's 1484 MILLISECS, SECS, MINUTES, HOURS and DAYS. 1485 The built duration value is in milliseconds. */ 1486 1487tree 1488build_chill_duration (expr, multiplier, fnname, maxvalue) 1489 tree expr; 1490 unsigned long multiplier; 1491 tree fnname; 1492 unsigned long maxvalue; 1493{ 1494 tree temp; 1495 1496 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 1497 return error_mark_node; 1498 1499 if (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE) 1500 { 1501 error ("argument to `%s' must be of integer type.", IDENTIFIER_POINTER (fnname)); 1502 return error_mark_node; 1503 } 1504 1505 temp = convert (duration_timing_type_node, expr); 1506 temp = fold (build (MULT_EXPR, duration_timing_type_node, 1507 temp, build_int_2 (multiplier, 0))); 1508 1509 if (range_checking) 1510 temp = check_range (temp, expr, integer_zero_node, build_int_2 (maxvalue, 0)); 1511 1512 return temp; 1513} 1514 1515/* build function call to one of the floating point functions */ 1516static tree 1517build_chill_floatcall (expr, chillname, funcname) 1518 tree expr; 1519 char *chillname; 1520 char *funcname; 1521{ 1522 tree result; 1523 tree type; 1524 1525 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 1526 return error_mark_node; 1527 1528 /* look if expr is a REAL_TYPE */ 1529 type = TREE_TYPE (expr); 1530 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) 1531 return error_mark_node; 1532 if (TREE_CODE (type) != REAL_TYPE) 1533 { 1534 error ("argument 1 to `%s' must be of floating point mode", chillname); 1535 return error_mark_node; 1536 } 1537 result = build_chill_function_call ( 1538 lookup_name (get_identifier (funcname)), 1539 tree_cons (NULL_TREE, expr, NULL_TREE)); 1540 return result; 1541} 1542 1543/* common function for ALLOCATE and GETSTACK */ 1544static tree 1545build_allocate_getstack (mode, value, chill_name, fnname, filename, linenumber) 1546 tree mode; 1547 tree value; 1548 char *chill_name; 1549 char *fnname; 1550 tree filename; 1551 tree linenumber; 1552{ 1553 tree type, result; 1554 tree expr = NULL_TREE; 1555 tree args, tmpvar, fncall, ptr, outlist = NULL_TREE; 1556 1557 if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK) 1558 return error_mark_node; 1559 1560 if (TREE_CODE (mode) == TYPE_DECL) 1561 type = TREE_TYPE (mode); 1562 else 1563 type = mode; 1564 1565 /* check if we have a mode */ 1566 if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') 1567 { 1568 error ("First argument to `%s' must be a mode", chill_name); 1569 return error_mark_node; 1570 } 1571 1572 /* check if we have a value if type is READonly */ 1573 if (TYPE_READONLY_PROPERTY (type) && value == NULL_TREE) 1574 { 1575 error ("READonly modes for %s must have a value", chill_name); 1576 return error_mark_node; 1577 } 1578 1579 if (value != NULL_TREE) 1580 { 1581 if (TREE_CODE (value) == ERROR_MARK) 1582 return error_mark_node; 1583 expr = chill_convert_for_assignment (type, value, "assignment"); 1584 } 1585 1586 /* build function arguments */ 1587 if (filename == NULL_TREE) 1588 args = tree_cons (NULL_TREE, size_in_bytes (type), NULL_TREE); 1589 else 1590 args = tree_cons (NULL_TREE, size_in_bytes (type), 1591 tree_cons (NULL_TREE, force_addr_of (filename), 1592 tree_cons (NULL_TREE, linenumber, NULL_TREE))); 1593 1594 ptr = build_chill_pointer_type (type); 1595 tmpvar = decl_temp1 (get_unique_identifier (chill_name), 1596 ptr, 0, NULL_TREE, 0, 0); 1597 fncall = build_chill_function_call ( 1598 lookup_name (get_identifier (fnname)), args); 1599 outlist = tree_cons (NULL_TREE, 1600 build_chill_modify_expr (tmpvar, fncall), outlist); 1601 if (expr == NULL_TREE) 1602 { 1603 /* set allocated memory to 0 */ 1604 fncall = build_chill_function_call ( 1605 lookup_name (get_identifier ("memset")), 1606 tree_cons (NULL_TREE, convert (ptr_type_node, tmpvar), 1607 tree_cons (NULL_TREE, integer_zero_node, 1608 tree_cons (NULL_TREE, size_in_bytes (type), NULL_TREE)))); 1609 outlist = tree_cons (NULL_TREE, fncall, outlist); 1610 } 1611 else 1612 { 1613 /* write the init value to allocated memory */ 1614 outlist = tree_cons (NULL_TREE, 1615 build_chill_modify_expr (build_chill_indirect_ref (tmpvar, NULL_TREE, 0), 1616 expr), 1617 outlist); 1618 } 1619 outlist = tree_cons (NULL_TREE, tmpvar, outlist); 1620 result = build_chill_compound_expr (nreverse (outlist)); 1621 return result; 1622} 1623 1624/* process the ALLOCATE built-in */ 1625tree 1626build_chill_allocate (mode, value) 1627 tree mode; 1628 tree value; 1629{ 1630 return build_allocate_getstack (mode, value, "ALLOCATE", "__allocate", 1631 get_chill_filename (), get_chill_linenumber ()); 1632} 1633 1634/* process the GETSTACK built-in */ 1635tree 1636build_chill_getstack (mode, value) 1637 tree mode; 1638 tree value; 1639{ 1640 return build_allocate_getstack (mode, value, "GETSTACK", "__builtin_alloca", 1641 NULL_TREE, NULL_TREE); 1642} 1643 1644/* process the TERMINATE built-in */ 1645tree 1646build_chill_terminate (ptr) 1647 tree ptr; 1648{ 1649 tree result; 1650 tree type; 1651 1652 if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK) 1653 return error_mark_node; 1654 1655 type = TREE_TYPE (ptr); 1656 if (type == NULL_TREE || TREE_CODE (type) != POINTER_TYPE) 1657 { 1658 error ("argument to TERMINATE must be a reference primitive value"); 1659 return error_mark_node; 1660 } 1661 result = build_chill_function_call ( 1662 lookup_name (get_identifier ("__terminate")), 1663 tree_cons (NULL_TREE, convert (ptr_type_node, ptr), 1664 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), 1665 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); 1666 return result; 1667} 1668 1669/* build the type passed to _inttime function */ 1670void 1671build_chill_inttime_type () 1672{ 1673 tree idxlist; 1674 tree arrtype; 1675 tree decl; 1676 1677 idxlist = build_tree_list (NULL_TREE, 1678 build_chill_range_type (NULL_TREE, 1679 integer_zero_node, 1680 build_int_2 (5, 0))); 1681 arrtype = build_chill_array_type (ptr_type_node, idxlist, 0, NULL_TREE); 1682 1683 decl = build_decl (TYPE_DECL, get_identifier ("__tmp_INTTIME_type"), arrtype); 1684 pushdecl (decl); 1685 DECL_SOURCE_LINE (decl) = 0; 1686 satisfy_decl (decl, 0); 1687} 1688 1689tree 1690build_chill_inttime (t, loclist) 1691 tree t, loclist; 1692{ 1693 int had_errors = 0, cnt; 1694 tree tmp; 1695 tree init = NULL_TREE; 1696 int numargs; 1697 tree tuple, var; 1698 1699 if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK) 1700 return error_mark_node; 1701 if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK) 1702 return error_mark_node; 1703 1704 /* check first argument to be NEWMODE TIME */ 1705 if (TREE_TYPE (t) != abs_timing_type_node) 1706 { 1707 error ("argument 1 to INTTIME must be of mode TIME."); 1708 had_errors = 1; 1709 } 1710 1711 cnt = 2; 1712 tmp = loclist; 1713 while (tmp != NULL_TREE) 1714 { 1715 tree loc = TREE_VALUE (tmp); 1716 char errmsg[200]; 1717 char *p, *p1; 1718 int write_error = 0; 1719 1720 sprintf (errmsg, "argument %d to INTTIME must be ", cnt); 1721 p = errmsg + strlen (errmsg); 1722 p1 = p; 1723 1724 if (loc == NULL_TREE || TREE_CODE (loc) == ERROR_MARK) 1725 had_errors = 1; 1726 else 1727 { 1728 if (! CH_REFERABLE (loc)) 1729 { 1730 strcpy (p, "referable"); 1731 p += strlen (p); 1732 write_error = 1; 1733 had_errors = 1; 1734 } 1735 if (TREE_CODE (TREE_TYPE (loc)) != INTEGER_TYPE) 1736 { 1737 if (p != p1) 1738 { 1739 strcpy (p, " and "); 1740 p += strlen (p); 1741 } 1742 strcpy (p, "of integer type"); 1743 write_error = 1; 1744 had_errors = 1; 1745 } 1746 /* FIXME: what's about ranges can't hold the result ?? */ 1747 if (write_error) 1748 error ("%s.", errmsg); 1749 } 1750 /* next location */ 1751 tmp = TREE_CHAIN (tmp); 1752 cnt++; 1753 } 1754 1755 if (had_errors) 1756 return error_mark_node; 1757 1758 /* make it always 6 arguments */ 1759 numargs = list_length (loclist); 1760 for (cnt = numargs; cnt < 6; cnt++) 1761 init = tree_cons (NULL_TREE, null_pointer_node, init); 1762 1763 /* append the given one's */ 1764 tmp = loclist; 1765 while (tmp != NULL_TREE) 1766 { 1767 init = chainon (init, 1768 build_tree_list (NULL_TREE, 1769 build_chill_descr (TREE_VALUE (tmp)))); 1770 tmp = TREE_CHAIN (tmp); 1771 } 1772 1773 tuple = build_nt (CONSTRUCTOR, NULL_TREE, init); 1774 var = decl_temp1 (get_unique_identifier ("INTTIME"), 1775 TREE_TYPE (lookup_name (get_identifier ("__tmp_INTTIME_type"))), 1776 0, tuple, 0, 0); 1777 1778 return build_chill_function_call ( 1779 lookup_name (get_identifier ("_inttime")), 1780 tree_cons (NULL_TREE, t, 1781 tree_cons (NULL_TREE, force_addr_of (var), 1782 NULL_TREE))); 1783} 1784 1785 1786/* Compute the runtime length of the given string variable 1787 * or expression. 1788 */ 1789tree 1790build_chill_length (expr) 1791 tree expr; 1792{ 1793 if (pass == 2) 1794 { 1795 tree type; 1796 1797 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 1798 return error_mark_node; 1799 1800 if (TREE_CODE (expr) == IDENTIFIER_NODE) 1801 expr = lookup_name (expr); 1802 1803 type = TREE_TYPE (expr); 1804 1805 if (TREE_CODE(type) == ERROR_MARK) 1806 return type; 1807 if (chill_varying_type_p (type)) 1808 { 1809 tree temp = convert (integer_type_node, 1810 build_component_ref (expr, var_length_id)); 1811 /* FIXME: should call 1812 * cond_type_range_exception (temp); 1813 */ 1814 return temp; 1815 } 1816 1817 if ((TREE_CODE (type) == ARRAY_TYPE || 1818 /* should work for a bitstring too */ 1819 (TREE_CODE (type) == SET_TYPE && TREE_CODE (TREE_TYPE (type)) == BOOLEAN_TYPE)) && 1820 integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (type)))) 1821 { 1822 tree temp = fold (build (PLUS_EXPR, chill_integer_type_node, 1823 integer_one_node, 1824 TYPE_MAX_VALUE (TYPE_DOMAIN (type)))); 1825 return convert (chill_integer_type_node, temp); 1826 } 1827 1828 if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) 1829 { 1830 tree len = max_queue_size (type); 1831 1832 if (len == NULL_TREE) 1833 len = integer_minus_one_node; 1834 return len; 1835 } 1836 1837 if (CH_IS_TEXT_MODE (type)) 1838 { 1839 if (TREE_CODE (expr) == TYPE_DECL) 1840 { 1841 /* text mode name */ 1842 return text_length (type); 1843 } 1844 else 1845 { 1846 /* text location */ 1847 tree temp = build_component_ref ( 1848 build_component_ref (expr, get_identifier ("tloc")), 1849 var_length_id); 1850 return convert (integer_type_node, temp); 1851 } 1852 } 1853 1854 error("LENGTH argument must be string, buffer, event mode, text location or mode"); 1855 return error_mark_node; 1856 } 1857 return NULL_TREE; 1858} 1859 1860/* Compute the declared minimum/maximum value of the variable, 1861 * expression or declared type 1862 */ 1863static tree 1864build_chill_lower_or_upper (what, is_upper) 1865 tree what; 1866 int is_upper; /* o -> LOWER; 1 -> UPPER */ 1867{ 1868 if (pass == 2) 1869 { 1870 tree type; 1871 struct ch_class class; 1872 1873 if (what == NULL_TREE || TREE_CODE (what) == ERROR_MARK) 1874 return error_mark_node; 1875 1876 if (TREE_CODE_CLASS (TREE_CODE (what)) == 't') 1877 type = what; 1878 else 1879 type = TREE_TYPE (what); 1880 if (type == NULL_TREE) 1881 { 1882 if (is_upper) 1883 error ("UPPER argument must have a mode, or be a mode"); 1884 else 1885 error ("LOWER argument must have a mode, or be a mode"); 1886 return error_mark_node; 1887 } 1888 while (TREE_CODE (type) == REFERENCE_TYPE) 1889 type = TREE_TYPE (type); 1890 if (chill_varying_type_p (type)) 1891 type = CH_VARYING_ARRAY_TYPE (type); 1892 1893 if (discrete_type_p (type)) 1894 { 1895 tree val = is_upper ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type); 1896 class.kind = CH_VALUE_CLASS; 1897 class.mode = type; 1898 return convert_to_class (class, val); 1899 } 1900 else if (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == SET_TYPE) 1901 { 1902 if (TYPE_STRING_FLAG (type)) 1903 { 1904 class.kind = CH_DERIVED_CLASS; 1905 class.mode = integer_type_node; 1906 } 1907 else 1908 { 1909 class.kind = CH_VALUE_CLASS; 1910 class.mode = TYPE_DOMAIN (type); 1911 } 1912 type = TYPE_DOMAIN (type); 1913 return convert_to_class (class, 1914 is_upper 1915 ? TYPE_MAX_VALUE (type) 1916 : TYPE_MIN_VALUE (type)); 1917 } 1918 if (is_upper) 1919 error("UPPER argument must be string, array, mode or integer"); 1920 else 1921 error("LOWER argument must be string, array, mode or integer"); 1922 return error_mark_node; 1923 } 1924 return NULL_TREE; 1925} 1926 1927tree 1928build_chill_lower (what) 1929 tree what; 1930{ 1931 return build_chill_lower_or_upper (what, 0); 1932} 1933 1934static tree 1935build_max_min (expr, max_min) 1936 tree expr; 1937 int max_min; /* 0: calculate MIN; 1: calculate MAX */ 1938{ 1939 if (pass == 2) 1940 { 1941 tree type, temp, setminval; 1942 tree set_base_type; 1943 int size_in_bytes; 1944 1945 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 1946 return error_mark_node; 1947 1948 if (TREE_CODE (expr) == IDENTIFIER_NODE) 1949 expr = lookup_name (expr); 1950 1951 type = TREE_TYPE (expr); 1952 set_base_type = TYPE_DOMAIN (type); 1953 setminval = TYPE_MIN_VALUE (set_base_type); 1954 1955 if (TREE_CODE (type) != SET_TYPE) 1956 { 1957 error("%s argument must be POWERSET mode", 1958 max_min ? "MAX" : "MIN"); 1959 return error_mark_node; 1960 } 1961 1962 /* find max/min of constant powerset at compile time */ 1963 if (TREE_CODE (expr) == CONSTRUCTOR && TREE_CONSTANT (expr) 1964 && (size_in_bytes = int_size_in_bytes (type)) >= 0) 1965 { 1966 HOST_WIDE_INT min_val = -1, max_val = -1; 1967 HOST_WIDE_INT i, i_hi = 0; 1968 HOST_WIDE_INT size_in_bits = size_in_bytes * BITS_PER_UNIT; 1969 char *buffer = (char*) alloca (size_in_bits); 1970 if (buffer == NULL 1971 || get_set_constructor_bits (expr, buffer, size_in_bits)) 1972 abort (); 1973 for (i = 0; i < size_in_bits; i++) 1974 { 1975 if (buffer[i]) 1976 { 1977 if (min_val < 0) 1978 min_val = i; 1979 max_val = i; 1980 } 1981 } 1982 if (min_val < 0) 1983 error ("%s called for empty POWERSET", max_min ? "MAX" : "MIN"); 1984 i = max_min ? max_val : min_val; 1985 temp = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))); 1986 add_double (i, i_hi, 1987 TREE_INT_CST_LOW (temp), TREE_INT_CST_HIGH (temp), 1988 &i, &i_hi); 1989 temp = build_int_2 (i, i_hi); 1990 TREE_TYPE (temp) = set_base_type; 1991 return temp; 1992 } 1993 else 1994 { 1995 tree parmlist, filename, lineno; 1996 char *funcname; 1997 1998 /* set up to call appropriate runtime function */ 1999 if (max_min) 2000 funcname = "__flsetpowerset"; 2001 else 2002 funcname = "__ffsetpowerset"; 2003 2004 setminval = convert (long_integer_type_node, setminval); 2005 filename = force_addr_of (get_chill_filename()); 2006 lineno = get_chill_linenumber(); 2007 parmlist = tree_cons (NULL_TREE, force_addr_of (expr), 2008 tree_cons (NULL_TREE, powersetlen (expr), 2009 tree_cons (NULL_TREE, setminval, 2010 tree_cons (NULL_TREE, filename, 2011 build_tree_list (NULL_TREE, lineno))))); 2012 temp = lookup_name (get_identifier (funcname)); 2013 temp = build_chill_function_call (temp, parmlist); 2014 TREE_TYPE (temp) = set_base_type; 2015 return temp; 2016 } 2017 } 2018 return NULL_TREE; 2019} 2020 2021 2022/* Compute the current runtime maximum value of the powerset 2023 */ 2024tree 2025build_chill_max (expr) 2026 tree expr; 2027{ 2028 return build_max_min (expr, 1); 2029} 2030 2031 2032/* Compute the current runtime minimum value of the powerset 2033 */ 2034tree 2035build_chill_min (expr) 2036 tree expr; 2037{ 2038 return build_max_min (expr, 0); 2039} 2040 2041 2042/* Build a conversion from the given expression to an INT, 2043 * but only when the expression's type is the same size as 2044 * an INT. 2045 */ 2046tree 2047build_chill_num (expr) 2048 tree expr; 2049{ 2050 if (pass == 2) 2051 { 2052 tree temp; 2053 int need_unsigned; 2054 2055 if (expr == NULL_TREE || TREE_CODE(expr) == ERROR_MARK) 2056 return error_mark_node; 2057 2058 if (TREE_CODE (expr) == IDENTIFIER_NODE) 2059 expr = lookup_name (expr); 2060 2061 expr = convert_to_discrete (expr); 2062 if (expr == NULL_TREE) 2063 { 2064 error ("argument to NUM is not discrete"); 2065 return error_mark_node; 2066 } 2067 2068 /* enumeral types and string slices of length 1 must be kept unsigned */ 2069 need_unsigned = (TREE_CODE (TREE_TYPE (expr)) == ENUMERAL_TYPE) 2070 || TREE_UNSIGNED (TREE_TYPE (expr)); 2071 2072 temp = type_for_size (TYPE_PRECISION (TREE_TYPE (expr)), 2073 need_unsigned); 2074 if (temp == NULL_TREE) 2075 { 2076 error ("No integer mode which matches expression's mode"); 2077 return integer_zero_node; 2078 } 2079 temp = convert (temp, expr); 2080 2081 if (TREE_CONSTANT (temp)) 2082 { 2083 if (tree_int_cst_lt (temp, 2084 TYPE_MIN_VALUE (TREE_TYPE (temp)))) 2085 error ("NUM's parameter is below its mode range"); 2086 if (tree_int_cst_lt (TYPE_MAX_VALUE (TREE_TYPE (temp)), 2087 temp)) 2088 error ("NUM's parameter is above its mode range"); 2089 } 2090#if 0 2091 else 2092 { 2093 if (range_checking) 2094 cond_overflow_exception (temp, 2095 TYPE_MIN_VALUE (TREE_TYPE (temp)), 2096 TYPE_MAX_VALUE (TREE_TYPE (temp))); 2097 } 2098#endif 2099 2100 /* NUM delivers the INT derived class */ 2101 CH_DERIVED_FLAG (temp) = 1; 2102 2103 return temp; 2104 } 2105 return NULL_TREE; 2106} 2107 2108 2109static tree 2110build_chill_pred_or_succ (expr, op) 2111 tree expr; 2112 enum tree_code op; /* PLUS_EXPR for SUCC; MINUS_EXPR for PRED. */ 2113{ 2114 struct ch_class class; 2115 tree etype, cond; 2116 2117 if (pass == 1) 2118 return NULL_TREE; 2119 2120 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 2121 return error_mark_node; 2122 2123 /* disallow numbered SETs */ 2124 if (TREE_CODE (TREE_TYPE (expr)) == ENUMERAL_TYPE 2125 && CH_ENUM_IS_NUMBERED (TREE_TYPE (expr))) 2126 { 2127 error ("Cannot take SUCC or PRED of a numbered SET"); 2128 return error_mark_node; 2129 } 2130 2131 if (TREE_CODE (TREE_TYPE (expr)) == POINTER_TYPE) 2132 { 2133 if (TREE_TYPE (TREE_TYPE (expr)) == void_type_node) 2134 { 2135 error ("SUCC or PRED must not be done on a PTR."); 2136 return error_mark_node; 2137 } 2138 pedwarn ("SUCC or PRED for a reference type is not standard."); 2139 return fold (build (op, TREE_TYPE (expr), 2140 expr, 2141 size_in_bytes (TREE_TYPE (TREE_TYPE (expr))))); 2142 } 2143 2144 expr = convert_to_discrete (expr); 2145 2146 if (expr == NULL_TREE) 2147 { 2148 error ("SUCC or PRED argument must be a discrete mode"); 2149 return error_mark_node; 2150 } 2151 2152 class = chill_expr_class (expr); 2153 if (class.mode) 2154 class.mode = CH_ROOT_MODE (class.mode); 2155 etype = class.mode; 2156 expr = convert (etype, expr); 2157 2158 /* Exception if expression is already at the 2159 min (PRED)/max(SUCC) valid value for its type. */ 2160 cond = fold (build (op == PLUS_EXPR ? GE_EXPR : LE_EXPR, 2161 boolean_type_node, 2162 expr, 2163 convert (etype, 2164 op == PLUS_EXPR ? TYPE_MAX_VALUE (etype) 2165 : TYPE_MIN_VALUE (etype)))); 2166 if (TREE_CODE (cond) == INTEGER_CST 2167 && tree_int_cst_equal (cond, integer_one_node)) 2168 { 2169 error ("Taking the %s of a value already at its %s value", 2170 op == PLUS_EXPR ? "SUCC" : "PRED", 2171 op == PLUS_EXPR ? "maximum" : "minimum"); 2172 return error_mark_node; 2173 } 2174 2175 if (range_checking) 2176 expr = check_expression (expr, cond, 2177 ridpointers[(int) RID_OVERFLOW]); 2178 2179 expr = fold (build (op, etype, expr, 2180 convert (etype, integer_one_node))); 2181 return convert_to_class (class, expr); 2182} 2183 2184/* Compute the value of the CHILL `size' operator just 2185 * like the C 'sizeof' operator (code stolen from c-typeck.c) 2186 * TYPE may be a location or mode tree. In pass 1, we build 2187 * a function-call syntax tree; in pass 2, we evaluate it. 2188 */ 2189tree 2190build_chill_sizeof (type) 2191 tree type; 2192{ 2193 if (pass == 2) 2194 { 2195 tree temp; 2196 struct ch_class class; 2197 enum tree_code code; 2198 tree signame = NULL_TREE; 2199 2200 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) 2201 return error_mark_node; 2202 2203 if (TREE_CODE (type) == IDENTIFIER_NODE) 2204 type = lookup_name (type); 2205 2206 code = TREE_CODE (type); 2207 if (code == ERROR_MARK) 2208 return error_mark_node; 2209 2210 if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') 2211 { 2212 if (TREE_CODE (type) == TYPE_DECL && CH_DECL_SIGNAL (type)) 2213 signame = DECL_NAME (type); 2214 type = TREE_TYPE (type); 2215 } 2216 2217 if (code == FUNCTION_TYPE) 2218 { 2219 if (pedantic || warn_pointer_arith) 2220 pedwarn ("size applied to a function mode"); 2221 return error_mark_node; 2222 } 2223 if (code == VOID_TYPE) 2224 { 2225 if (pedantic || warn_pointer_arith) 2226 pedwarn ("sizeof applied to a void mode"); 2227 return error_mark_node; 2228 } 2229 if (TYPE_SIZE (type) == 0) 2230 { 2231 error ("sizeof applied to an incomplete mode"); 2232 return error_mark_node; 2233 } 2234 2235 temp = size_binop (CEIL_DIV_EXPR, TYPE_SIZE (type), 2236 size_int (TYPE_PRECISION (char_type_node))); 2237 if (signame != NULL_TREE) 2238 { 2239 /* we have a signal definition. This signal may have no 2240 data items specified. The definition however says that 2241 there are data, cause we cannot build a structure without 2242 fields. In this case return 0. */ 2243 if (IDENTIFIER_SIGNAL_DATA (signame) == 0) 2244 temp = integer_zero_node; 2245 } 2246 2247 /* FIXME: should call 2248 * cond_type_range_exception (temp); 2249 */ 2250 class.kind = CH_DERIVED_CLASS; 2251 class.mode = integer_type_node; 2252 return convert_to_class (class, temp); 2253 } 2254 return NULL_TREE; 2255} 2256 2257/* Compute the declared maximum value of the variable, 2258 * expression or declared type 2259 */ 2260tree 2261build_chill_upper (what) 2262 tree what; 2263{ 2264 return build_chill_lower_or_upper (what, 1); 2265} 2266 2267/* 2268 * Here at the site of a function/procedure call.. We need to build 2269 * temps for the INOUT and OUT parameters, and copy the actual parameters 2270 * into the temps. After the call, we 'copy back' the values from the 2271 * temps to the actual parameter variables. This somewhat verbose pol- 2272 * icy meets the requirement that the actual parameters are undisturbed 2273 * if the function/procedure causes an exception. They are updated only 2274 * upon a normal return from the function. 2275 * 2276 * Note: the expr_list, which collects all of the above assignments, etc, 2277 * is built in REVERSE execution order. The list is corrected by nreverse 2278 * inside the build_chill_compound_expr call. 2279 */ 2280tree 2281build_chill_function_call (function, expr) 2282 tree function, expr; 2283{ 2284 register tree typetail, valtail, typelist; 2285 register tree temp, actual_args = NULL_TREE; 2286 tree name = NULL_TREE; 2287 tree function_call; 2288 tree fntype; 2289 int parmno = 1; /* parameter number for error message */ 2290 int callee_raise_exception = 0; 2291 2292 /* list of assignments to run after the actual call, 2293 copying from the temps back to the user's variables. */ 2294 tree copy_back = NULL_TREE; 2295 2296 /* list of expressions to run before the call, copying from 2297 the user's variable to the temps that are passed to the function */ 2298 tree expr_list = NULL_TREE; 2299 2300 if (function == NULL_TREE || TREE_CODE (function) == ERROR_MARK) 2301 return error_mark_node; 2302 2303 if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK) 2304 return error_mark_node; 2305 2306 if (pass < 2) 2307 return error_mark_node; 2308 2309 fntype = TREE_TYPE (function); 2310 if (TREE_CODE (function) == FUNCTION_DECL) 2311 { 2312 callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE; 2313 2314 /* Differs from default_conversion by not setting TREE_ADDRESSABLE 2315 (because calling an inline function does not mean the function 2316 needs to be separately compiled). */ 2317 fntype = build_type_variant (fntype, 2318 TREE_READONLY (function), 2319 TREE_THIS_VOLATILE (function)); 2320 name = DECL_NAME (function); 2321 2322 /* check that function is not a PROCESS */ 2323 if (CH_DECL_PROCESS (function)) 2324 { 2325 error ("cannot call a PROCESS, you START a PROCESS"); 2326 return error_mark_node; 2327 } 2328 2329 function = build1 (ADDR_EXPR, build_pointer_type (fntype), function); 2330 } 2331 else if (TREE_CODE (fntype) == POINTER_TYPE) 2332 { 2333 fntype = TREE_TYPE (fntype); 2334 callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE; 2335 2336 /* Z.200 6.7 Call Action: 2337 "A procedure call causes the EMPTY exception if the 2338 procedure primitive value delivers NULL. */ 2339 if (TREE_CODE (function) != ADDR_EXPR 2340 || TREE_CODE (TREE_OPERAND (function, 0)) != FUNCTION_DECL) 2341 function = check_non_null (function); 2342 } 2343 2344 typelist = TYPE_ARG_TYPES (fntype); 2345 if (callee_raise_exception) 2346 { 2347 /* remove last two arguments from list for subsequent checking. 2348 They will get added automatically after checking */ 2349 int len = list_length (typelist); 2350 int i; 2351 tree newtypelist = NULL_TREE; 2352 tree wrk = typelist; 2353 2354 for (i = 0; i < len - 3; i++) 2355 { 2356 newtypelist = tree_cons (TREE_PURPOSE (wrk), TREE_VALUE (wrk), newtypelist); 2357 wrk = TREE_CHAIN (wrk); 2358 } 2359 /* add the void_type_node */ 2360 newtypelist = tree_cons (NULL_TREE, void_type_node, newtypelist); 2361 typelist = nreverse (newtypelist); 2362 } 2363 2364 /* Scan the given expressions and types, producing individual 2365 converted arguments and pushing them on ACTUAL_ARGS in 2366 reverse order. */ 2367 for (valtail = expr, typetail = typelist; 2368 valtail != NULL_TREE && typetail != NULL_TREE; parmno++, 2369 valtail = TREE_CHAIN (valtail), typetail = TREE_CHAIN (typetail)) 2370 { 2371 register tree actual = TREE_VALUE (valtail); 2372 register tree attr = TREE_PURPOSE (typetail) 2373 ? TREE_PURPOSE (typetail) : ridpointers[(int) RID_IN]; 2374 register tree type = TREE_VALUE (typetail); 2375 char place[30]; 2376 sprintf (place, "parameter %d", parmno); 2377 2378 /* if we have reached void_type_node in typelist we are at the 2379 end of formal parameters and then we have too many actual 2380 parameters */ 2381 if (type == void_type_node) 2382 break; 2383 2384 /* check if actual is a TYPE_DECL. FIXME: what else ? */ 2385 if (TREE_CODE (actual) == TYPE_DECL) 2386 { 2387 error ("invalid %s", place); 2388 actual = error_mark_node; 2389 } 2390 /* INOUT or OUT param to handle? */ 2391 else if (attr == ridpointers[(int) RID_OUT] 2392 || attr == ridpointers[(int)RID_INOUT]) 2393 { 2394 char temp_name[20]; 2395 tree parmtmp; 2396 tree in_actual = NULL_TREE, out_actual; 2397 2398 /* actual parameter must be a location so we can 2399 build a reference to it */ 2400 if (!CH_LOCATION_P (actual)) 2401 { 2402 error ("%s parameter %d must be a location", 2403 (attr == ridpointers[(int) RID_OUT]) ? 2404 "OUT" : "INOUT", parmno); 2405 continue; 2406 } 2407 if (TYPE_READONLY_PROPERTY (TREE_TYPE (actual)) 2408 || TREE_READONLY (actual)) 2409 { 2410 error ("%s parameter %d is READ-only", 2411 (attr == ridpointers[(int) RID_OUT]) ? 2412 "OUT" : "INOUT", parmno); 2413 continue; 2414 } 2415 2416 sprintf (temp_name, "PARM_%d_%s", parmno, 2417 (attr == ridpointers[(int)RID_OUT]) ? 2418 "OUT" : "INOUT"); 2419 parmtmp = decl_temp1 (get_unique_identifier (temp_name), 2420 TREE_TYPE (type), 0, NULL_TREE, 0, 0); 2421 /* this temp *must not* be optimized into a register */ 2422 mark_addressable (parmtmp); 2423 2424 if (attr == ridpointers[(int)RID_INOUT]) 2425 { 2426 tree in_actual = chill_convert_for_assignment (TREE_TYPE (type), 2427 actual, place); 2428 tree tmp = build_chill_modify_expr (parmtmp, in_actual); 2429 expr_list = tree_cons (NULL_TREE, tmp, expr_list); 2430 } 2431 if (in_actual != error_mark_node) 2432 { 2433 /* list of copy back assignments to perform, from the temp 2434 back to the actual parameter */ 2435 out_actual = chill_convert_for_assignment (TREE_TYPE (actual), 2436 parmtmp, place); 2437 copy_back = tree_cons (NULL_TREE, 2438 build_chill_modify_expr (actual, 2439 out_actual), 2440 copy_back); 2441 } 2442 /* we can do this because build_chill_function_type 2443 turned these parameters into REFERENCE_TYPEs. */ 2444 actual = build1 (ADDR_EXPR, type, parmtmp); 2445 } 2446 else if (attr == ridpointers[(int) RID_LOC]) 2447 { 2448 int is_location = chill_location (actual); 2449 if (is_location) 2450 { 2451 if (is_location == 1) 2452 { 2453 error ("LOC actual parameter %d is a non-referable location", 2454 parmno); 2455 actual = error_mark_node; 2456 } 2457 else if (! CH_READ_COMPATIBLE (type, TREE_TYPE (actual))) 2458 { 2459 error ("mode mismatch in parameter %d", parmno); 2460 actual = error_mark_node; 2461 } 2462 else 2463 actual = convert (type, actual); 2464 } 2465 else 2466 { 2467 sprintf (place, "parameter_%d", parmno); 2468 actual = decl_temp1 (get_identifier (place), 2469 TREE_TYPE (type), 0, actual, 0, 0); 2470 actual = convert (type, actual); 2471 } 2472 mark_addressable (actual); 2473 } 2474 else 2475 actual = chill_convert_for_assignment (type, actual, place); 2476 2477 actual_args = tree_cons (NULL_TREE, actual, actual_args); 2478 } 2479 2480 if (valtail != 0 && TREE_VALUE (valtail) != void_type_node) 2481 { 2482 char *errstr = "too many arguments to procedure"; 2483 if (name) 2484 error ("%s `%s'", errstr, IDENTIFIER_POINTER (name)); 2485 else 2486 error (errstr); 2487 return error_mark_node; 2488 } 2489 else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node) 2490 { 2491 char *errstr = "too few arguments to procedure"; 2492 if (name) 2493 error ("%s `%s'", errstr, IDENTIFIER_POINTER (name)); 2494 else 2495 error (errstr); 2496 return error_mark_node; 2497 } 2498 2499 if (callee_raise_exception) 2500 { 2501 /* add linenumber and filename of the caller as arguments */ 2502 actual_args = tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), 2503 actual_args); 2504 actual_args = tree_cons (NULL_TREE, get_chill_linenumber (), actual_args); 2505 } 2506 2507 function_call = build (CALL_EXPR, TREE_TYPE (fntype), 2508 function, nreverse (actual_args), NULL_TREE); 2509 TREE_SIDE_EFFECTS (function_call) = 1; 2510 2511 if (copy_back == NULL_TREE && expr_list == NULL_TREE) 2512 return function_call; /* no copying to do, either way */ 2513 else 2514 { 2515 tree result_type = TREE_TYPE (fntype); 2516 tree result_tmp = NULL_TREE; 2517 2518 /* no result wanted from procedure call */ 2519 if (result_type == NULL_TREE || result_type == void_type_node) 2520 expr_list = tree_cons (NULL_TREE, function_call, expr_list); 2521 else 2522 { 2523 /* create a temp for the function's result. this is so that we can 2524 evaluate this temp as the last expression in the list, which will 2525 make the function's return value the value of the whole list of 2526 expressions (by the C rules for compound expressions) */ 2527 result_tmp = decl_temp1 (get_unique_identifier ("FUNC_RESULT"), 2528 result_type, 0, NULL_TREE, 0, 0); 2529 expr_list = tree_cons (NULL_TREE, 2530 build_chill_modify_expr (result_tmp, function_call), 2531 expr_list); 2532 } 2533 2534 expr_list = chainon (copy_back, expr_list); 2535 2536 /* last, but not least, the function's result */ 2537 if (result_tmp != NULL_TREE) 2538 expr_list = tree_cons (NULL_TREE, result_tmp, expr_list); 2539 temp = build_chill_compound_expr (nreverse (expr_list)); 2540 return temp; 2541 } 2542} 2543 2544/* We saw something that looks like a function call, 2545 but if it's pass 1, we're not sure. */ 2546 2547tree 2548build_generalized_call (func, args) 2549 tree func, args; 2550{ 2551 tree type = TREE_TYPE (func); 2552 2553 if (pass == 1) 2554 return build (CALL_EXPR, NULL_TREE, func, args, NULL_TREE); 2555 2556 /* Handle string repetition */ 2557 if (TREE_CODE (func) == INTEGER_CST) 2558 { 2559 if (args == NULL_TREE || TREE_CHAIN (args) != NULL_TREE) 2560 { 2561 error ("syntax error (integer used as function)"); 2562 return error_mark_node; 2563 } 2564 if (TREE_CODE (args) == TREE_LIST) 2565 args = TREE_VALUE (args); 2566 return build_chill_repetition_op (func, args); 2567 } 2568 2569 if (args != NULL_TREE) 2570 { 2571 if (TREE_CODE (args) == RANGE_EXPR) 2572 { 2573 tree lo = TREE_OPERAND (args, 0), hi = TREE_OPERAND (args, 1); 2574 if (TREE_CODE_CLASS (TREE_CODE (func)) == 't') 2575 return build_chill_range_type (func, lo, hi); 2576 else 2577 return build_chill_slice_with_range (func, lo, hi); 2578 } 2579 else if (TREE_CODE (args) != TREE_LIST) 2580 { 2581 error ("syntax error - missing operator, comma, or '('?"); 2582 return error_mark_node; 2583 } 2584 } 2585 2586 if (TREE_CODE (func) == TYPE_DECL) 2587 { 2588 if (CH_DECL_SIGNAL (func)) 2589 return build_signal_descriptor (func, args); 2590 func = TREE_TYPE (func); 2591 } 2592 2593 if (TREE_CODE_CLASS (TREE_CODE (func)) == 't' 2594 && args != NULL_TREE && TREE_CHAIN (args) == NULL_TREE) 2595 return build_chill_cast (func, TREE_VALUE (args)); 2596 2597 if (TREE_CODE (type) == FUNCTION_TYPE 2598 || (TREE_CODE (type) == POINTER_TYPE 2599 && TREE_TYPE (type) != NULL_TREE 2600 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)) 2601 { 2602 /* Check for a built-in Chill function. */ 2603 if (TREE_CODE (func) == FUNCTION_DECL 2604 && DECL_BUILT_IN (func) 2605 && DECL_FUNCTION_CODE (func) > END_BUILTINS) 2606 { 2607 tree fnname = DECL_NAME (func); 2608 switch ((enum chill_built_in_function)DECL_FUNCTION_CODE (func)) 2609 { 2610 case BUILT_IN_CH_ABS: 2611 if (check_arglist_length (args, 1, 1, fnname) < 0) 2612 return error_mark_node; 2613 return build_chill_abs (TREE_VALUE (args)); 2614 case BUILT_IN_ABSTIME: 2615 if (check_arglist_length (args, 0, 6, fnname) < 0) 2616 return error_mark_node; 2617 return build_chill_abstime (args); 2618 case BUILT_IN_ADDR: 2619 if (check_arglist_length (args, 1, 1, fnname) < 0) 2620 return error_mark_node; 2621#if 0 2622 return build_chill_addr_expr (TREE_VALUE (args), (char *)0); 2623#else 2624 return build_chill_arrow_expr (TREE_VALUE (args), 0); 2625#endif 2626 case BUILT_IN_ALLOCATE_GLOBAL_MEMORY: 2627 if (check_arglist_length (args, 2, 2, fnname) < 0) 2628 return error_mark_node; 2629 return build_allocate_global_memory_call 2630 (TREE_VALUE (args), 2631 TREE_VALUE (TREE_CHAIN (args))); 2632 case BUILT_IN_ALLOCATE: 2633 if (check_arglist_length (args, 1, 2, fnname) < 0) 2634 return error_mark_node; 2635 return build_chill_allocate (TREE_VALUE (args), 2636 TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args))); 2637 case BUILT_IN_ALLOCATE_MEMORY: 2638 if (check_arglist_length (args, 2, 2, fnname) < 0) 2639 return error_mark_node; 2640 return build_allocate_memory_call 2641 (TREE_VALUE (args), 2642 TREE_VALUE (TREE_CHAIN (args))); 2643 case BUILT_IN_ASSOCIATE: 2644 if (check_arglist_length (args, 2, 3, fnname) < 0) 2645 return error_mark_node; 2646 return build_chill_associate 2647 (TREE_VALUE (args), 2648 TREE_VALUE (TREE_CHAIN (args)), 2649 TREE_CHAIN (TREE_CHAIN (args))); 2650 case BUILT_IN_ARCCOS: 2651 if (check_arglist_length (args, 1, 1, fnname) < 0) 2652 return error_mark_node; 2653 return build_chill_floatcall (TREE_VALUE (args), 2654 IDENTIFIER_POINTER (fnname), 2655 "__acos"); 2656 case BUILT_IN_ARCSIN: 2657 if (check_arglist_length (args, 1, 1, fnname) < 0) 2658 return error_mark_node; 2659 return build_chill_floatcall (TREE_VALUE (args), 2660 IDENTIFIER_POINTER (fnname), 2661 "__asin"); 2662 case BUILT_IN_ARCTAN: 2663 if (check_arglist_length (args, 1, 1, fnname) < 0) 2664 return error_mark_node; 2665 return build_chill_floatcall (TREE_VALUE (args), 2666 IDENTIFIER_POINTER (fnname), 2667 "__atan"); 2668 case BUILT_IN_CARD: 2669 if (check_arglist_length (args, 1, 1, fnname) < 0) 2670 return error_mark_node; 2671 return build_chill_card (TREE_VALUE (args)); 2672 case BUILT_IN_CONNECT: 2673 if (check_arglist_length (args, 3, 5, fnname) < 0) 2674 return error_mark_node; 2675 return build_chill_connect 2676 (TREE_VALUE (args), 2677 TREE_VALUE (TREE_CHAIN (args)), 2678 TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))), 2679 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))); 2680 case BUILT_IN_COPY_NUMBER: 2681 if (check_arglist_length (args, 1, 1, fnname) < 0) 2682 return error_mark_node; 2683 return build_copy_number (TREE_VALUE (args)); 2684 case BUILT_IN_CH_COS: 2685 if (check_arglist_length (args, 1, 1, fnname) < 0) 2686 return error_mark_node; 2687 return build_chill_floatcall (TREE_VALUE (args), 2688 IDENTIFIER_POINTER (fnname), 2689 "__cos"); 2690 case BUILT_IN_CREATE: 2691 if (check_arglist_length (args, 1, 1, fnname) < 0) 2692 return error_mark_node; 2693 return build_chill_create (TREE_VALUE (args)); 2694 case BUILT_IN_DAYS: 2695 if (check_arglist_length (args, 1, 1, fnname) < 0) 2696 return error_mark_node; 2697 return build_chill_duration (TREE_VALUE (args), DAYS_MULTIPLIER, 2698 fnname, DAYS_MAX); 2699 case BUILT_IN_CH_DELETE: 2700 if (check_arglist_length (args, 1, 1, fnname) < 0) 2701 return error_mark_node; 2702 return build_chill_delete (TREE_VALUE (args)); 2703 case BUILT_IN_DESCR: 2704 if (check_arglist_length (args, 1, 1, fnname) < 0) 2705 return error_mark_node; 2706 return build_chill_descr (TREE_VALUE (args)); 2707 case BUILT_IN_DISCONNECT: 2708 if (check_arglist_length (args, 1, 1, fnname) < 0) 2709 return error_mark_node; 2710 return build_chill_disconnect (TREE_VALUE (args)); 2711 case BUILT_IN_DISSOCIATE: 2712 if (check_arglist_length (args, 1, 1, fnname) < 0) 2713 return error_mark_node; 2714 return build_chill_dissociate (TREE_VALUE (args)); 2715 case BUILT_IN_EOLN: 2716 if (check_arglist_length (args, 1, 1, fnname) < 0) 2717 return error_mark_node; 2718 return build_chill_eoln (TREE_VALUE (args)); 2719 case BUILT_IN_EXISTING: 2720 if (check_arglist_length (args, 1, 1, fnname) < 0) 2721 return error_mark_node; 2722 return build_chill_existing (TREE_VALUE (args)); 2723 case BUILT_IN_EXP: 2724 if (check_arglist_length (args, 1, 1, fnname) < 0) 2725 return error_mark_node; 2726 return build_chill_floatcall (TREE_VALUE (args), 2727 IDENTIFIER_POINTER (fnname), 2728 "__exp"); 2729 case BUILT_IN_GEN_CODE: 2730 if (check_arglist_length (args, 1, 1, fnname) < 0) 2731 return error_mark_node; 2732 return build_gen_code (TREE_VALUE (args)); 2733 case BUILT_IN_GEN_INST: 2734 if (check_arglist_length (args, 2, 2, fnname) < 0) 2735 return error_mark_node; 2736 return build_gen_inst (TREE_VALUE (args), 2737 TREE_VALUE (TREE_CHAIN (args))); 2738 case BUILT_IN_GEN_PTYPE: 2739 if (check_arglist_length (args, 1, 1, fnname) < 0) 2740 return error_mark_node; 2741 return build_gen_ptype (TREE_VALUE (args)); 2742 case BUILT_IN_GETASSOCIATION: 2743 if (check_arglist_length (args, 1, 1, fnname) < 0) 2744 return error_mark_node; 2745 return build_chill_getassociation (TREE_VALUE (args)); 2746 case BUILT_IN_GETSTACK: 2747 if (check_arglist_length (args, 1, 2, fnname) < 0) 2748 return error_mark_node; 2749 return build_chill_getstack (TREE_VALUE (args), 2750 TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args))); 2751 case BUILT_IN_GETTEXTACCESS: 2752 if (check_arglist_length (args, 1, 1, fnname) < 0) 2753 return error_mark_node; 2754 return build_chill_gettextaccess (TREE_VALUE (args)); 2755 case BUILT_IN_GETTEXTINDEX: 2756 if (check_arglist_length (args, 1, 1, fnname) < 0) 2757 return error_mark_node; 2758 return build_chill_gettextindex (TREE_VALUE (args)); 2759 case BUILT_IN_GETTEXTRECORD: 2760 if (check_arglist_length (args, 1, 1, fnname) < 0) 2761 return error_mark_node; 2762 return build_chill_gettextrecord (TREE_VALUE (args)); 2763 case BUILT_IN_GETUSAGE: 2764 if (check_arglist_length (args, 1, 1, fnname) < 0) 2765 return error_mark_node; 2766 return build_chill_getusage (TREE_VALUE (args)); 2767 case BUILT_IN_HOURS: 2768 if (check_arglist_length (args, 1, 1, fnname) < 0) 2769 return error_mark_node; 2770 return build_chill_duration (TREE_VALUE (args), HOURS_MULTIPLIER, 2771 fnname, HOURS_MAX); 2772 case BUILT_IN_INDEXABLE: 2773 if (check_arglist_length (args, 1, 1, fnname) < 0) 2774 return error_mark_node; 2775 return build_chill_indexable (TREE_VALUE (args)); 2776 case BUILT_IN_INTTIME: 2777 if (check_arglist_length (args, 2, 7, fnname) < 0) 2778 return error_mark_node; 2779 return build_chill_inttime (TREE_VALUE (args), 2780 TREE_CHAIN (args)); 2781 case BUILT_IN_ISASSOCIATED: 2782 if (check_arglist_length (args, 1, 1, fnname) < 0) 2783 return error_mark_node; 2784 return build_chill_isassociated (TREE_VALUE (args)); 2785 case BUILT_IN_LENGTH: 2786 if (check_arglist_length (args, 1, 1, fnname) < 0) 2787 return error_mark_node; 2788 return build_chill_length (TREE_VALUE (args)); 2789 case BUILT_IN_LN: 2790 if (check_arglist_length (args, 1, 1, fnname) < 0) 2791 return error_mark_node; 2792 return build_chill_floatcall (TREE_VALUE (args), 2793 IDENTIFIER_POINTER (fnname), 2794 "__log"); 2795 case BUILT_IN_LOG: 2796 if (check_arglist_length (args, 1, 1, fnname) < 0) 2797 return error_mark_node; 2798 return build_chill_floatcall (TREE_VALUE (args), 2799 IDENTIFIER_POINTER (fnname), 2800 "__log10"); 2801 case BUILT_IN_LOWER: 2802 if (check_arglist_length (args, 1, 1, fnname) < 0) 2803 return error_mark_node; 2804 return build_chill_lower (TREE_VALUE (args)); 2805 case BUILT_IN_MAX: 2806 if (check_arglist_length (args, 1, 1, fnname) < 0) 2807 return error_mark_node; 2808 return build_chill_max (TREE_VALUE (args)); 2809 case BUILT_IN_MILLISECS: 2810 if (check_arglist_length (args, 1, 1, fnname) < 0) 2811 return error_mark_node; 2812 return build_chill_duration (TREE_VALUE (args), MILLISECS_MULTIPLIER, 2813 fnname, MILLISECS_MAX); 2814 case BUILT_IN_MIN: 2815 if (check_arglist_length (args, 1, 1, fnname) < 0) 2816 return error_mark_node; 2817 return build_chill_min (TREE_VALUE (args)); 2818 case BUILT_IN_MINUTES: 2819 if (check_arglist_length (args, 1, 1, fnname) < 0) 2820 return error_mark_node; 2821 return build_chill_duration (TREE_VALUE (args), MINUTES_MULTIPLIER, 2822 fnname, MINUTES_MAX); 2823 case BUILT_IN_MODIFY: 2824 if (check_arglist_length (args, 1, -1, fnname) < 0) 2825 return error_mark_node; 2826 return build_chill_modify (TREE_VALUE (args), TREE_CHAIN (args)); 2827 case BUILT_IN_NUM: 2828 if (check_arglist_length (args, 1, 1, fnname) < 0) 2829 return error_mark_node; 2830 return build_chill_num (TREE_VALUE (args)); 2831 case BUILT_IN_OUTOFFILE: 2832 if (check_arglist_length (args, 1, 1, fnname) < 0) 2833 return error_mark_node; 2834 return build_chill_outoffile (TREE_VALUE (args)); 2835 case BUILT_IN_PRED: 2836 if (check_arglist_length (args, 1, 1, fnname) < 0) 2837 return error_mark_node; 2838 return build_chill_pred_or_succ (TREE_VALUE (args), MINUS_EXPR); 2839 case BUILT_IN_PROC_TYPE: 2840 if (check_arglist_length (args, 1, 1, fnname) < 0) 2841 return error_mark_node; 2842 return build_proc_type (TREE_VALUE (args)); 2843 case BUILT_IN_QUEUE_LENGTH: 2844 if (check_arglist_length (args, 1, 1, fnname) < 0) 2845 return error_mark_node; 2846 return build_queue_length (TREE_VALUE (args)); 2847 case BUILT_IN_READABLE: 2848 if (check_arglist_length (args, 1, 1, fnname) < 0) 2849 return error_mark_node; 2850 return build_chill_readable (TREE_VALUE (args)); 2851 case BUILT_IN_READRECORD: 2852 if (check_arglist_length (args, 1, 3, fnname) < 0) 2853 return error_mark_node; 2854 return build_chill_readrecord (TREE_VALUE (args), TREE_CHAIN (args)); 2855 case BUILT_IN_READTEXT: 2856 if (check_arglist_length (args, 2, -1, fnname) < 0) 2857 return error_mark_node; 2858 return build_chill_readtext (TREE_VALUE (args), 2859 TREE_CHAIN (args)); 2860 case BUILT_IN_RETURN_MEMORY: 2861 if (check_arglist_length (args, 1, 1, fnname) < 0) 2862 return error_mark_node; 2863 return build_return_memory (TREE_VALUE (args)); 2864 case BUILT_IN_SECS: 2865 if (check_arglist_length (args, 1, 1, fnname) < 0) 2866 return error_mark_node; 2867 return build_chill_duration (TREE_VALUE (args), SECS_MULTIPLIER, 2868 fnname, SECS_MAX); 2869 case BUILT_IN_SEQUENCIBLE: 2870 if (check_arglist_length (args, 1, 1, fnname) < 0) 2871 return error_mark_node; 2872 return build_chill_sequencible (TREE_VALUE (args)); 2873 case BUILT_IN_SETTEXTACCESS: 2874 if (check_arglist_length (args, 2, 2, fnname) < 0) 2875 return error_mark_node; 2876 return build_chill_settextaccess (TREE_VALUE (args), 2877 TREE_VALUE (TREE_CHAIN (args))); 2878 case BUILT_IN_SETTEXTINDEX: 2879 if (check_arglist_length (args, 2, 2, fnname) < 0) 2880 return error_mark_node; 2881 return build_chill_settextindex (TREE_VALUE (args), 2882 TREE_VALUE (TREE_CHAIN (args))); 2883 case BUILT_IN_SETTEXTRECORD: 2884 if (check_arglist_length (args, 2, 2, fnname) < 0) 2885 return error_mark_node; 2886 return build_chill_settextrecord (TREE_VALUE (args), 2887 TREE_VALUE (TREE_CHAIN (args))); 2888 case BUILT_IN_CH_SIN: 2889 if (check_arglist_length (args, 1, 1, fnname) < 0) 2890 return error_mark_node; 2891 return build_chill_floatcall (TREE_VALUE (args), 2892 IDENTIFIER_POINTER (fnname), 2893 "__sin"); 2894 case BUILT_IN_SIZE: 2895 if (check_arglist_length (args, 1, 1, fnname) < 0) 2896 return error_mark_node; 2897 return build_chill_sizeof (TREE_VALUE (args)); 2898 case BUILT_IN_SQRT: 2899 if (check_arglist_length (args, 1, 1, fnname) < 0) 2900 return error_mark_node; 2901 return build_chill_floatcall (TREE_VALUE (args), 2902 IDENTIFIER_POINTER (fnname), 2903 "__sqrt"); 2904 case BUILT_IN_SUCC: 2905 if (check_arglist_length (args, 1, 1, fnname) < 0) 2906 return error_mark_node; 2907 return build_chill_pred_or_succ (TREE_VALUE (args), PLUS_EXPR); 2908 case BUILT_IN_TAN: 2909 if (check_arglist_length (args, 1, 1, fnname) < 0) 2910 return error_mark_node; 2911 return build_chill_floatcall (TREE_VALUE (args), 2912 IDENTIFIER_POINTER (fnname), 2913 "__tan"); 2914 case BUILT_IN_TERMINATE: 2915 if (check_arglist_length (args, 1, 1, fnname) < 0) 2916 return error_mark_node; 2917 return build_chill_terminate (TREE_VALUE (args)); 2918 case BUILT_IN_UPPER: 2919 if (check_arglist_length (args, 1, 1, fnname) < 0) 2920 return error_mark_node; 2921 return build_chill_upper (TREE_VALUE (args)); 2922 case BUILT_IN_VARIABLE: 2923 if (check_arglist_length (args, 1, 1, fnname) < 0) 2924 return error_mark_node; 2925 return build_chill_variable (TREE_VALUE (args)); 2926 case BUILT_IN_WRITEABLE: 2927 if (check_arglist_length (args, 1, 1, fnname) < 0) 2928 return error_mark_node; 2929 return build_chill_writeable (TREE_VALUE (args)); 2930 case BUILT_IN_WRITERECORD: 2931 if (check_arglist_length (args, 2, 3, fnname) < 0) 2932 return error_mark_node; 2933 return build_chill_writerecord (TREE_VALUE (args), TREE_CHAIN (args)); 2934 case BUILT_IN_WRITETEXT: 2935 if (check_arglist_length (args, 2, -1, fnname) < 0) 2936 return error_mark_node; 2937 return build_chill_writetext (TREE_VALUE (args), 2938 TREE_CHAIN (args)); 2939 2940 case BUILT_IN_EXPIRED: 2941 case BUILT_IN_WAIT: 2942 sorry ("unimplemented builtin function `%s'", 2943 IDENTIFIER_POINTER (fnname)); 2944 break; 2945 default: 2946 error ("internal error - bad builtin function `%s'", 2947 IDENTIFIER_POINTER (fnname)); 2948 } 2949 } 2950 return build_chill_function_call (func, args); 2951 } 2952 2953 if (chill_varying_type_p (TREE_TYPE (func))) 2954 type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); 2955 2956 if (CH_STRING_TYPE_P (type)) 2957 { 2958 if (args == NULL_TREE) 2959 { 2960 error ("empty expression in string index"); 2961 return error_mark_node; 2962 } 2963 if (TREE_CHAIN (args) != NULL) 2964 { 2965 error ("only one expression allowed in string index"); 2966 return error_mark_node; 2967 } 2968 if (flag_old_strings) 2969 return build_chill_slice_with_length (func, 2970 TREE_VALUE (args), 2971 integer_one_node); 2972 else if (CH_BOOLS_TYPE_P (type)) 2973 return build_chill_bitref (func, args); 2974 else 2975 return build_chill_array_ref (func, args); 2976 } 2977 2978 else if (TREE_CODE (type) == ARRAY_TYPE) 2979 return build_chill_array_ref (func, args); 2980 2981 if (TREE_CODE (func) != ERROR_MARK) 2982 error ("invalid: primval ( untyped_exprlist )"); 2983 return error_mark_node; 2984} 2985 2986/* Given a set stored as one bit per char (in BUFFER[0 .. BIT_SIZE-1]), 2987 return a CONTRUCTOR, of type TYPE (a SET_TYPE). */ 2988tree 2989expand_packed_set (buffer, bit_size, type) 2990 char *buffer; 2991 int bit_size; 2992 tree type; 2993{ 2994 /* The ordinal number corresponding to the first stored bit. */ 2995 HOST_WIDE_INT first_bit_no = 2996 TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (type))); 2997 tree list = NULL_TREE; 2998 int i; 2999 3000 for (i = 0; i < bit_size; i++) 3001 if (buffer[i]) 3002 { 3003 int next_0; 3004 for (next_0 = i + 1; 3005 next_0 < bit_size && buffer[next_0]; next_0++) 3006 ; 3007 if (next_0 == i + 1) 3008 list = tree_cons (NULL_TREE, 3009 build_int_2 (i + first_bit_no, 0), list); 3010 else 3011 { 3012 list = tree_cons (build_int_2 (i + first_bit_no, 0), 3013 build_int_2 (next_0 - 1 + first_bit_no, 0), list); 3014 /* advance i past the range of 1-bits */ 3015 i = next_0; 3016 } 3017 } 3018 list = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list)); 3019 TREE_CONSTANT (list) = 1; 3020 return list; 3021} 3022 3023/* 3024 * fold a set represented as a CONSTRUCTOR list. 3025 * An empty set has a NULL_TREE in its TREE_OPERAND (set, 1) slot. 3026 */ 3027static tree 3028fold_set_expr (code, op0, op1) 3029 enum chill_tree_code code; 3030 tree op0, op1; 3031{ 3032 tree temp; 3033 char *buffer0, *buffer1 = NULL, *bufferr; 3034 int i, size0, size1, first_unused_bit; 3035 3036 if (! TREE_CONSTANT (op0) || TREE_CODE (op0) != CONSTRUCTOR) 3037 return NULL_TREE; 3038 3039 if (op1 3040 && (! TREE_CONSTANT (op1) || TREE_CODE (op1) != CONSTRUCTOR)) 3041 return NULL_TREE; 3042 3043 size0 = int_size_in_bytes (TREE_TYPE (op0)) * BITS_PER_UNIT; 3044 if (size0 < 0) 3045 { 3046 error ("operand is variable-size bitstring/power-set"); 3047 return error_mark_node; 3048 } 3049 buffer0 = (char*) alloca (size0); 3050 3051 temp = get_set_constructor_bits (op0, buffer0, size0); 3052 if (temp) 3053 return NULL_TREE; 3054 3055 if (op0 && op1) 3056 { 3057 size1 = int_size_in_bytes (TREE_TYPE (op1)) * BITS_PER_UNIT; 3058 if (size1 < 0) 3059 { 3060 error ("operand is variable-size bitstring/power-set"); 3061 return error_mark_node; 3062 } 3063 if (size0 != size1) 3064 return NULL_TREE; 3065 buffer1 = (char*) alloca (size1); 3066 temp = get_set_constructor_bits (op1, buffer1, size1); 3067 if (temp) 3068 return NULL_TREE; 3069 } 3070 3071 bufferr = (char*) alloca (size0); /* result buffer */ 3072 3073 switch ((int)code) 3074 { 3075 case SET_NOT_EXPR: 3076 case BIT_NOT_EXPR: 3077 for (i = 0; i < size0; i++) 3078 bufferr[i] = 1 & ~buffer0[i]; 3079 goto build_result; 3080 case SET_AND_EXPR: 3081 case BIT_AND_EXPR: 3082 for (i = 0; i < size0; i++) 3083 bufferr[i] = buffer0[i] & buffer1[i]; 3084 goto build_result; 3085 case SET_IOR_EXPR: 3086 case BIT_IOR_EXPR: 3087 for (i = 0; i < size0; i++) 3088 bufferr[i] = buffer0[i] | buffer1[i]; 3089 goto build_result; 3090 case SET_XOR_EXPR: 3091 case BIT_XOR_EXPR: 3092 for (i = 0; i < size0; i++) 3093 bufferr[i] = (buffer0[i] ^ buffer1[i]) & 1; 3094 goto build_result; 3095 case SET_DIFF_EXPR: 3096 case MINUS_EXPR: 3097 for (i = 0; i < size0; i++) 3098 bufferr[i] = buffer0[i] & ~buffer1[i]; 3099 goto build_result; 3100 build_result: 3101 /* mask out unused bits. Same as runtime library does. */ 3102 first_unused_bit = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (op0)))) 3103 - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (op0)))) + 1; 3104 for (i = first_unused_bit; i < size0 ; i++) 3105 bufferr[i] = 0; 3106 return expand_packed_set (bufferr, size0, TREE_TYPE (op0)); 3107 case EQ_EXPR: 3108 for (i = 0; i < size0; i++) 3109 if (buffer0[i] != buffer1[i]) 3110 return boolean_false_node; 3111 return boolean_true_node; 3112 3113 case NE_EXPR: 3114 for (i = 0; i < size0; i++) 3115 if (buffer0[i] != buffer1[i]) 3116 return boolean_true_node; 3117 return boolean_false_node; 3118 3119 default: 3120 return NULL_TREE; 3121 } 3122} 3123 3124/* 3125 * build a set or bit-array expression. Type-checking is 3126 * done elsewhere. 3127 */ 3128static tree 3129build_compare_set_expr (code, op0, op1) 3130 enum tree_code code; 3131 tree op0, op1; 3132{ 3133 tree result_type = NULL_TREE; 3134 char *fnname; 3135 tree x; 3136 3137 /* These conversions are needed if -fold-strings. */ 3138 if (TREE_CODE (TREE_TYPE (op0)) == BOOLEAN_TYPE) 3139 { 3140 if (CH_BOOLS_ONE_P (TREE_TYPE (op1))) 3141 return build_compare_discrete_expr (code, 3142 op0, 3143 convert (boolean_type_node, op1)); 3144 else 3145 op0 = convert (bitstring_one_type_node, op0); 3146 } 3147 if (TREE_CODE (TREE_TYPE (op1)) == BOOLEAN_TYPE) 3148 { 3149 if (CH_BOOLS_ONE_P (TREE_TYPE (op0))) 3150 return build_compare_discrete_expr (code, 3151 convert (boolean_type_node, op0), 3152 op1); 3153 else 3154 op1 = convert (bitstring_one_type_node, op1); 3155 } 3156 3157 switch ((int)code) 3158 { 3159 case EQ_EXPR: 3160 { 3161 tree temp = fold_set_expr (EQ_EXPR, op0, op1); 3162 if (temp) 3163 return temp; 3164 fnname = "__eqpowerset"; 3165 goto compare_powerset; 3166 } 3167 break; 3168 3169 case GE_EXPR: 3170 /* switch operands and fall thru */ 3171 x = op0; 3172 op0 = op1; 3173 op1 = x; 3174 3175 case LE_EXPR: 3176 fnname = "__lepowerset"; 3177 goto compare_powerset; 3178 3179 case GT_EXPR: 3180 /* switch operands and fall thru */ 3181 x = op0; 3182 op0 = op1; 3183 op1 = x; 3184 3185 case LT_EXPR: 3186 fnname = "__ltpowerset"; 3187 goto compare_powerset; 3188 3189 case NE_EXPR: 3190 return invert_truthvalue (build_compare_set_expr (EQ_EXPR, op0, op1)); 3191 3192 compare_powerset: 3193 { 3194 tree tsize = powersetlen (op0); 3195 3196 if (TREE_CODE (TREE_TYPE (op0)) != SET_TYPE) 3197 tsize = fold (build (MULT_EXPR, sizetype, tsize, 3198 size_int (BITS_PER_UNIT))); 3199 3200 return build_chill_function_call (lookup_name (get_identifier (fnname)), 3201 tree_cons (NULL_TREE, force_addr_of (op0), 3202 tree_cons (NULL_TREE, force_addr_of (op1), 3203 tree_cons (NULL_TREE, tsize, NULL_TREE)))); 3204 } 3205 break; 3206 3207 default: 3208 if ((int) code >= (int)LAST_AND_UNUSED_TREE_CODE) 3209 { 3210 error ("tree code `%s' unhandled in build_compare_set_expr", 3211 tree_code_name[(int)code]); 3212 return error_mark_node; 3213 } 3214 break; 3215 } 3216 3217 return build ((enum tree_code)code, result_type, 3218 op0, op1); 3219} 3220 3221/* Convert a varying string (or array) to dynamic non-varying string: 3222 EXP becomes EXP.var_data(0 UP EXP.var_length). */ 3223 3224tree 3225varying_to_slice (exp) 3226 tree exp; 3227{ 3228 if (!chill_varying_type_p (TREE_TYPE (exp))) 3229 return exp; 3230 else 3231 { tree size, data, data_domain, min; 3232 tree novelty = CH_NOVELTY (TREE_TYPE (exp)); 3233 exp = save_if_needed (exp); 3234 size = build_component_ref (exp, var_length_id); 3235 data = build_component_ref (exp, var_data_id); 3236 TREE_TYPE (data) = copy_novelty (novelty, TREE_TYPE (data)); 3237 data_domain = TYPE_DOMAIN (TREE_TYPE (data)); 3238 if (data_domain != NULL_TREE 3239 && TYPE_MIN_VALUE (data_domain) != NULL_TREE) 3240 min = TYPE_MIN_VALUE (data_domain); 3241 else 3242 min = integer_zero_node; 3243 return build_chill_slice (data, min, size); 3244 } 3245} 3246 3247/* Convert a scalar argument to a string or array type. This is a subroutine 3248 of `build_concat_expr'. */ 3249 3250static tree 3251scalar_to_string (exp) 3252 tree exp; 3253{ 3254 tree type = TREE_TYPE (exp); 3255 3256 if (SCALAR_P (type)) 3257 { 3258 int was_const = TREE_CONSTANT (exp); 3259 if (TREE_TYPE (exp) == char_type_node) 3260 exp = convert (string_one_type_node, exp); 3261 else if (TREE_TYPE (exp) == boolean_type_node) 3262 exp = convert (bitstring_one_type_node, exp); 3263 else 3264 exp = convert (build_array_type_for_scalar (type), exp); 3265 TREE_CONSTANT (exp) = was_const; 3266 return exp; 3267 } 3268 return varying_to_slice (exp); 3269} 3270 3271/* FIXME: Generalize this to general arrays (not just strings), 3272 at least for the compiler-generated case of padding fixed-length arrays. */ 3273 3274static tree 3275build_concat_expr (op0, op1) 3276 tree op0, op1; 3277{ 3278 tree orig_op0 = op0, orig_op1 = op1; 3279 tree type0, type1, size0, size1, res; 3280 3281 op0 = scalar_to_string (op0); 3282 type0 = TREE_TYPE (op0); 3283 op1 = scalar_to_string (op1); 3284 type1 = TREE_TYPE (op1); 3285 size1 = size_in_bytes (type1); 3286 3287 /* try to fold constant string literals */ 3288 if (TREE_CODE (op0) == STRING_CST 3289 && (TREE_CODE (op1) == STRING_CST 3290 || TREE_CODE (op1) == UNDEFINED_EXPR) 3291 && TREE_CODE (size1) == INTEGER_CST) 3292 { 3293 int len0 = TREE_STRING_LENGTH (op0); 3294 int len1 = TREE_INT_CST_LOW (size1); 3295 char *result = xmalloc (len0 + len1 + 1); 3296 memcpy (result, TREE_STRING_POINTER (op0), len0); 3297 if (TREE_CODE (op1) == UNDEFINED_EXPR) 3298 memset (&result[len0], '\0', len1); 3299 else 3300 memcpy (&result[len0], TREE_STRING_POINTER (op1), len1); 3301 return build_chill_string (len0 + len1, result); 3302 } 3303 else if (TREE_CODE (type0) == TREE_CODE (type1)) 3304 { 3305 tree result_size; 3306 struct ch_class result_class; 3307 struct ch_class class0; 3308 struct ch_class class1; 3309 3310 class0 = chill_expr_class (orig_op0); 3311 class1 = chill_expr_class (orig_op1); 3312 3313 if (TREE_CODE (type0) == SET_TYPE) 3314 { 3315 result_size = size_binop (PLUS_EXPR, 3316 discrete_count (TYPE_DOMAIN (type0)), 3317 discrete_count (TYPE_DOMAIN (type1))); 3318 result_class.mode = build_bitstring_type (result_size); 3319 } 3320 else 3321 { 3322 tree max0 = TYPE_MAX_VALUE (type0); 3323 tree max1 = TYPE_MAX_VALUE (type1); 3324 3325 /* new array's dynamic size (in bytes). */ 3326 size0 = size_in_bytes (type0); 3327 /* size1 was computed above. */ 3328 3329 result_size = size_binop (PLUS_EXPR, size0, size1); 3330 /* new array's type. */ 3331 result_class.mode = build_string_type (char_type_node, result_size); 3332 3333 if (max0 || max1) 3334 { 3335 max0 = max0 == 0 ? size0 : convert (sizetype, max0); 3336 max1 = max1 == 0 ? size1 : convert (sizetype, max1); 3337 TYPE_MAX_VALUE (result_class.mode) 3338 = size_binop (PLUS_EXPR, max0, max1); 3339 } 3340 } 3341 3342 if (class0.kind == CH_VALUE_CLASS || class1.kind == CH_VALUE_CLASS) 3343 { 3344 tree novelty0 = CH_NOVELTY (TREE_TYPE (orig_op0)); 3345 result_class.kind = CH_VALUE_CLASS; 3346 if (class0.kind == CH_VALUE_CLASS && novelty0 != NULL_TREE) 3347 SET_CH_NOVELTY_NONNIL (result_class.mode, novelty0); 3348 else if (class1.kind == CH_VALUE_CLASS) 3349 SET_CH_NOVELTY (result_class.mode, 3350 CH_NOVELTY (TREE_TYPE (orig_op1))); 3351 } 3352 else 3353 result_class.kind = CH_DERIVED_CLASS; 3354 3355 if (TREE_CODE (result_class.mode) == SET_TYPE 3356 && TREE_CONSTANT (op0) && TREE_CONSTANT (op1) 3357 && TREE_CODE (op0) == CONSTRUCTOR && TREE_CODE (op1) == CONSTRUCTOR) 3358 { 3359 HOST_WIDE_INT size0, size1; char *buffer; 3360 size0 = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type0))) + 1; 3361 size1 = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type1))) + 1; 3362 buffer = (char*) alloca (size0 + size1); 3363 if (size0 < 0 || size1 < 0 3364 || get_set_constructor_bits (op0, buffer, size0) 3365 || get_set_constructor_bits (op1, buffer + size0, size1)) 3366 abort (); 3367 res = expand_packed_set (buffer, size0 + size1, result_class.mode); 3368 } 3369 else 3370 res = build (CONCAT_EXPR, result_class.mode, op0, op1); 3371 return convert_to_class (result_class, res); 3372 } 3373 else 3374 { 3375 error ("incompatible modes in concat expression"); 3376 return error_mark_node; 3377 } 3378} 3379 3380/* 3381 * handle varying and fixed array compare operations 3382 */ 3383static tree 3384build_compare_string_expr (code, op0, op1) 3385 enum tree_code code; 3386 tree op0, op1; 3387{ 3388 if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK) 3389 return error_mark_node; 3390 if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK) 3391 return error_mark_node; 3392 3393 if (tree_int_cst_equal (TYPE_SIZE (TREE_TYPE (op0)), 3394 TYPE_SIZE (TREE_TYPE (op1))) 3395 && ! chill_varying_type_p (TREE_TYPE (op0)) 3396 && ! chill_varying_type_p (TREE_TYPE (op1))) 3397 { 3398 tree size = size_in_bytes (TREE_TYPE (op0)); 3399 tree temp = lookup_name (get_identifier ("memcmp")); 3400 temp = build_chill_function_call (temp, 3401 tree_cons (NULL_TREE, force_addr_of (op0), 3402 tree_cons (NULL_TREE, force_addr_of (op1), 3403 tree_cons (NULL_TREE, size, NULL_TREE)))); 3404 return build_compare_discrete_expr (code, temp, integer_zero_node); 3405 } 3406 3407 switch ((int)code) 3408 { 3409 case EQ_EXPR: 3410 code = STRING_EQ_EXPR; 3411 break; 3412 case GE_EXPR: 3413 return invert_truthvalue (build_compare_string_expr (LT_EXPR, op0, op1)); 3414 case LE_EXPR: 3415 return invert_truthvalue (build_compare_string_expr (LT_EXPR, op1, op0)); 3416 case GT_EXPR: 3417 return build_compare_string_expr (LT_EXPR, op1, op0); 3418 case LT_EXPR: 3419 code = STRING_LT_EXPR; 3420 break; 3421 case NE_EXPR: 3422 return invert_truthvalue (build_compare_string_expr (EQ_EXPR, op0, op1)); 3423 default: 3424 error ("Invalid operation on array of chars"); 3425 return error_mark_node; 3426 } 3427 3428 return build (code, boolean_type_node, op0, op1); 3429} 3430 3431tree 3432compare_records (exp0, exp1) 3433 tree exp0, exp1; 3434{ 3435 tree type = TREE_TYPE (exp0); 3436 tree field; 3437 int have_variants = 0; 3438 3439 tree result = boolean_true_node; 3440 extern int maximum_field_alignment; 3441 3442 if (TREE_CODE (type) != RECORD_TYPE) 3443 abort (); 3444 3445 exp0 = save_if_needed (exp0); 3446 exp1 = save_if_needed (exp1); 3447 3448 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) 3449 { 3450 if (DECL_NAME (field) == NULL_TREE) 3451 { 3452 have_variants = 1; 3453 break; 3454 } 3455 } 3456 3457 /* in case of -fpack we always do a memcmp */ 3458 if (maximum_field_alignment != 0) 3459 { 3460 tree memcmp_func = lookup_name (get_identifier ("memcmp")); 3461 tree arg1 = force_addr_of (exp0); 3462 tree arg2 = force_addr_of (exp1); 3463 tree arg3 = size_in_bytes (type); 3464 tree fcall = build_chill_function_call (memcmp_func, 3465 tree_cons (NULL_TREE, arg1, 3466 tree_cons (NULL_TREE, arg2, 3467 tree_cons (NULL_TREE, arg3, NULL_TREE)))); 3468 3469 if (have_variants) 3470 warning ("comparison of variant structures is unsafe"); 3471 result = build_chill_binary_op (EQ_EXPR, fcall, integer_zero_node); 3472 return result; 3473 } 3474 3475 if (have_variants) 3476 { 3477 sorry ("compare with variant records"); 3478 return error_mark_node; 3479 } 3480 3481 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) 3482 { 3483 tree exp0fld = build_component_ref (exp0, DECL_NAME (field)); 3484 tree exp1fld = build_component_ref (exp1, DECL_NAME (field)); 3485 tree eq_flds = build_chill_binary_op (EQ_EXPR, exp0fld, exp1fld); 3486 result = build_chill_binary_op (TRUTH_AND_EXPR, result, eq_flds); 3487 } 3488 return result; 3489} 3490 3491int 3492compare_int_csts (op, val1, val2) 3493 enum tree_code op; 3494 tree val1, val2; 3495{ 3496 int result; 3497 tree tmp; 3498 tree type1 = TREE_TYPE (val1); 3499 tree type2 = TREE_TYPE (val2); 3500 switch (op) 3501 { 3502 case GT_EXPR: 3503 case GE_EXPR: 3504 tmp = val1; val1 = val2; val2 = tmp; 3505 tmp = type1; type1 = type2; type2 = tmp; 3506 op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR; 3507 /* ... fall through ... */ 3508 case LT_EXPR: 3509 case LE_EXPR: 3510 if (!TREE_UNSIGNED (type1)) 3511 { 3512 if (!TREE_UNSIGNED (type2)) 3513 result = INT_CST_LT (val1, val2); 3514 else if (TREE_INT_CST_HIGH (val1) < 0) 3515 result = 1; 3516 else 3517 result = INT_CST_LT_UNSIGNED (val1, val2); 3518 } 3519 else 3520 { 3521 if (!TREE_UNSIGNED (type2) && TREE_INT_CST_HIGH (val2) < 0) 3522 result = 0; 3523 else 3524 result = INT_CST_LT_UNSIGNED (val1, val2); 3525 } 3526 if (op == LT_EXPR || result == 1) 3527 break; 3528 /* else fall through ... */ 3529 case NE_EXPR: 3530 case EQ_EXPR: 3531 if (TREE_INT_CST_LOW (val1) == TREE_INT_CST_LOW (val2) 3532 && TREE_INT_CST_HIGH (val1) == TREE_INT_CST_HIGH (val2) 3533 /* They're bitwise equal. 3534 Check for one being negative and the other unsigned. */ 3535 && (TREE_INT_CST_HIGH (val2) >= 0 3536 || TREE_UNSIGNED (TREE_TYPE (val1)) 3537 == TREE_UNSIGNED (TREE_TYPE (val2)))) 3538 result = 1; 3539 else 3540 result = 0; 3541 if (op == NE_EXPR) 3542 result = !result; 3543 break; 3544 default: 3545 abort(); 3546 } 3547 return result; 3548} 3549 3550/* Build an expression to compare discrete values VAL1 and VAL2. 3551 This does not check that they are discrete, nor that they are 3552 compatible; if you need such checks use build_compare_expr. */ 3553 3554tree 3555build_compare_discrete_expr (op, val1, val2) 3556 enum tree_code op; 3557 tree val1, val2; 3558{ 3559 tree type1 = TREE_TYPE (val1); 3560 tree type2 = TREE_TYPE (val2); 3561 tree tmp; 3562 3563 if (TREE_CODE (val1) == INTEGER_CST && TREE_CODE (val2) == INTEGER_CST) 3564 { 3565 if (compare_int_csts (op, val1, val2)) 3566 return boolean_true_node; 3567 else 3568 return boolean_false_node; 3569 } 3570 3571 if (TREE_UNSIGNED (type1) != TREE_UNSIGNED (type2)) 3572 { 3573 switch (op) 3574 { 3575 case GT_EXPR: 3576 case GE_EXPR: 3577 tmp = val1; val1 = val2; val2 = tmp; 3578 tmp = type1; type1 = type2; type2 = tmp; 3579 op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR; 3580 /* ... fall through ... */ 3581 case LT_EXPR: 3582 case LE_EXPR: 3583 if (TREE_UNSIGNED (type2)) 3584 { 3585 tmp = build_int_2_wide (0, 0); 3586 TREE_TYPE (tmp) = type1; 3587 val1 = save_expr (val1); 3588 tmp = fold (build (LT_EXPR, boolean_type_node, val1, tmp)); 3589 if (TYPE_PRECISION (type2) < TYPE_PRECISION (type1)) 3590 { 3591 type2 = unsigned_type (type1); 3592 val2 = convert_to_integer (type2, val2); 3593 } 3594 val1 = convert_to_integer (type2, val1); 3595 return fold (build (TRUTH_OR_EXPR, boolean_type_node, 3596 tmp, 3597 fold (build (op, boolean_type_node, 3598 val1, val2)))); 3599 } 3600 unsigned_vs_signed: /* val1 is unsigned, val2 is signed */ 3601 tmp = build_int_2_wide (0, 0); 3602 TREE_TYPE (tmp) = type2; 3603 val2 = save_expr (val2); 3604 tmp = fold (build (GE_EXPR, boolean_type_node, val2, tmp)); 3605 if (TYPE_PRECISION (type1) < TYPE_PRECISION (type2)) 3606 { 3607 type1 = unsigned_type (type2); 3608 val1 = convert_to_integer (type1, val1); 3609 } 3610 val2 = convert_to_integer (type1, val2); 3611 return fold (build (TRUTH_AND_EXPR, boolean_type_node, tmp, 3612 fold (build (op, boolean_type_node, 3613 val1, val2)))); 3614 case EQ_EXPR: 3615 if (TREE_UNSIGNED (val2)) 3616 { 3617 tmp = val1; val1 = val2; val2 = tmp; 3618 tmp = type1; type1 = type2; type2 = tmp; 3619 } 3620 goto unsigned_vs_signed; 3621 case NE_EXPR: 3622 tmp = build_compare_expr (EQ_EXPR, val1, val2); 3623 return build_chill_unary_op (TRUTH_NOT_EXPR, tmp); 3624 default: 3625 abort(); 3626 } 3627 } 3628 if (TYPE_PRECISION (type1) > TYPE_PRECISION (type2)) 3629 val2 = convert (type1, val2); 3630 else if (TYPE_PRECISION (type1) < TYPE_PRECISION (type2)) 3631 val1 = convert (type2, val1); 3632 return fold (build (op, boolean_type_node, val1, val2)); 3633} 3634 3635tree 3636build_compare_expr (op, val1, val2) 3637 enum tree_code op; 3638 tree val1, val2; 3639{ 3640 tree tmp; 3641 tree type1, type2; 3642 val1 = check_have_mode (val1, "relational expression"); 3643 val2 = check_have_mode (val2, "relational expression"); 3644 if (val1 == NULL_TREE || TREE_CODE (val1) == ERROR_MARK) 3645 return error_mark_node; 3646 if (val2 == NULL_TREE || TREE_CODE (val2) == ERROR_MARK) 3647 return error_mark_node; 3648 3649 if (pass == 1) 3650 return build (op, NULL_TREE, val1, val2); 3651 3652 if (!CH_COMPATIBLE_CLASSES (val1, val2)) 3653 { 3654 error ("incompatible operands to %s", boolean_code_name [op]); 3655 return error_mark_node; 3656 } 3657 3658 tmp = CH_ROOT_MODE (TREE_TYPE (val1)); 3659 if (tmp != TREE_TYPE (val1)) 3660 val1 = convert (tmp, val1); 3661 tmp = CH_ROOT_MODE (TREE_TYPE (val2)); 3662 if (tmp != TREE_TYPE (val2)) 3663 val2 = convert (tmp, val2); 3664 3665 type1 = TREE_TYPE (val1); 3666 type2 = TREE_TYPE (val2); 3667 3668 if (TREE_CODE (type1) == SET_TYPE) 3669 tmp = build_compare_set_expr (op, val1, val2); 3670 3671 else if (discrete_type_p (type1)) 3672 tmp = build_compare_discrete_expr (op, val1, val2); 3673 3674 else if (chill_varying_type_p (type1) || chill_varying_type_p (type2) 3675 || (TREE_CODE (type1) == ARRAY_TYPE 3676 && TREE_CODE (TREE_TYPE (type1)) == CHAR_TYPE) 3677 || (TREE_CODE (type2) == ARRAY_TYPE 3678 && TREE_CODE (TREE_TYPE (type2)) == CHAR_TYPE) ) 3679 tmp = build_compare_string_expr (op, val1, val2); 3680 3681 else if ((TREE_CODE (type1) == RECORD_TYPE 3682 || TREE_CODE (type2) == RECORD_TYPE) 3683 && (op == EQ_EXPR || op == NE_EXPR)) 3684 { 3685 /* This is for handling INSTANCEs being compared against NULL. */ 3686 if (val1 == null_pointer_node) 3687 val1 = convert (type2, val1); 3688 if (val2 == null_pointer_node) 3689 val2 = convert (type1, val2); 3690 3691 tmp = compare_records (val1, val2); 3692 if (op == NE_EXPR) 3693 tmp = build_chill_unary_op (TRUTH_NOT_EXPR, tmp); 3694 } 3695 3696 else if (TREE_CODE (type1) == REAL_TYPE || TREE_CODE (type2) == REAL_TYPE 3697 || (op == EQ_EXPR || op == NE_EXPR)) 3698 { 3699 tmp = build (op, boolean_type_node, val1, val2); 3700 CH_DERIVED_FLAG (tmp) = 1; /* Optimization to avoid copy_node. */ 3701 tmp = fold (tmp); 3702 } 3703 3704 else 3705 { 3706 error ("relational operator not allowed for this mode"); 3707 return error_mark_node; 3708 } 3709 3710 if (!CH_DERIVED_FLAG (tmp)) 3711 { 3712 tmp = copy_node (tmp); 3713 CH_DERIVED_FLAG (tmp) = 1; 3714 } 3715 return tmp; 3716} 3717 3718tree 3719finish_chill_binary_op (node) 3720 tree node; 3721{ 3722 tree op0 = check_have_mode (TREE_OPERAND (node, 0), "binary expression"); 3723 tree op1 = check_have_mode (TREE_OPERAND (node, 1), "binary expression"); 3724 tree type0 = TREE_TYPE (op0); 3725 tree type1 = TREE_TYPE (op1); 3726 tree folded; 3727 3728 if (TREE_CODE (op0) == ERROR_MARK || TREE_CODE (op1) == ERROR_MARK) 3729 return error_mark_node; 3730 3731 if (UNSATISFIED (op0) || UNSATISFIED (op1)) 3732 { 3733 UNSATISFIED_FLAG (node) = 1; 3734 return node; 3735 } 3736#if 0 3737 /* assure that both operands have a type */ 3738 if (! type0 && type1) 3739 { 3740 op0 = convert (type1, op0); 3741 type0 = TREE_TYPE (op0); 3742 } 3743 if (! type1 && type0) 3744 { 3745 op1 = convert (type0, op1); 3746 type1 = TREE_TYPE (op1); 3747 } 3748#endif 3749 UNSATISFIED_FLAG (node) = 0; 3750#if 0 3751 3752 { int op0f = TREE_CODE (op0) == FUNCTION_DECL; 3753 int op1f = TREE_CODE (op1) == FUNCTION_DECL; 3754 if (op0f) 3755 op0 = convert (build_pointer_type (TREE_TYPE (op0)), op0); 3756 if (op1f) 3757 op1 = convert (build_pointer_type (TREE_TYPE (op1)), op1); 3758 if ((op0f || op1f) 3759 && code != EQ_EXPR && code != NE_EXPR) 3760 error ("Cannot use %s operator on PROC mode variable", 3761 tree_code_name[(int)code]); 3762 } 3763 3764 if (invalid_left_operand (type0, code)) 3765 { 3766 error ("invalid left operand of %s", tree_code_name[(int)code]); 3767 return error_mark_node; 3768 } 3769 if (invalid_right_operand (code, type1)) 3770 { 3771 error ("invalid right operand of %s", tree_code_name[(int)code]); 3772 return error_mark_node; 3773 } 3774#endif 3775 3776 switch (TREE_CODE (node)) 3777 { 3778 case CONCAT_EXPR: 3779 return build_concat_expr (op0, op1); 3780 3781 case REPLICATE_EXPR: 3782 op0 = fold (op0); 3783 if (!TREE_CONSTANT (op0) || !TREE_CONSTANT (op1)) 3784 { 3785 error ("repetition expression must be constant"); 3786 return error_mark_node; 3787 } 3788 else 3789 return build_chill_repetition_op (op0, op1); 3790 3791 case FLOOR_MOD_EXPR: 3792 case TRUNC_MOD_EXPR: 3793 if (TREE_CODE (type0) != INTEGER_TYPE) 3794 { 3795 error ("left argument to MOD/REM operator must be integral"); 3796 return error_mark_node; 3797 } 3798 if (TREE_CODE (type1) != INTEGER_TYPE) 3799 { 3800 error ("right argument to MOD/REM operator must be integral"); 3801 return error_mark_node; 3802 } 3803 break; 3804 3805 case MINUS_EXPR: 3806 if (TREE_CODE (type1) == SET_TYPE) 3807 { 3808 tree temp = fold_set_expr (MINUS_EXPR, op0, op1); 3809 3810 if (temp) 3811 return temp; 3812 if (TYPE_MODE (type1) == BLKmode) 3813 TREE_SET_CODE (node, SET_DIFF_EXPR); 3814 else 3815 { 3816 op1 = build_chill_unary_op (BIT_NOT_EXPR, op1); 3817 TREE_OPERAND (node, 1) = op1; 3818 TREE_SET_CODE (node, BIT_AND_EXPR); 3819 } 3820 } 3821 break; 3822 3823 case TRUNC_DIV_EXPR: 3824 if (TREE_CODE (type0) == REAL_TYPE || TREE_CODE (type1) == REAL_TYPE) 3825 TREE_SET_CODE (node, RDIV_EXPR); 3826 break; 3827 3828 case BIT_AND_EXPR: 3829 if (TYPE_MODE (type1) == BLKmode) 3830 TREE_SET_CODE (node, SET_AND_EXPR); 3831 goto fold_set_binop; 3832 case BIT_IOR_EXPR: 3833 if (TYPE_MODE (type1) == BLKmode) 3834 TREE_SET_CODE (node, SET_IOR_EXPR); 3835 goto fold_set_binop; 3836 case BIT_XOR_EXPR: 3837 if (TYPE_MODE (type1) == BLKmode) 3838 TREE_SET_CODE (node, SET_XOR_EXPR); 3839 goto fold_set_binop; 3840 case SET_AND_EXPR: 3841 case SET_IOR_EXPR: 3842 case SET_XOR_EXPR: 3843 case SET_DIFF_EXPR: 3844 fold_set_binop: 3845 if (TREE_CODE (type0) == SET_TYPE) 3846 { 3847 tree temp = fold_set_expr (TREE_CODE (node), op0, op1); 3848 3849 if (temp) 3850 return temp; 3851 } 3852 break; 3853 3854 case SET_IN_EXPR: 3855 if (TREE_CODE (type1) != SET_TYPE || CH_BOOLS_TYPE_P (type1)) 3856 { 3857 error ("right operand of IN is not a powerset"); 3858 return error_mark_node; 3859 } 3860 if (!CH_COMPATIBLE (op0, TYPE_DOMAIN (type1))) 3861 { 3862 error ("left operand of IN incompatible with right operand"); 3863 return error_mark_node; 3864 } 3865 type0 = CH_ROOT_MODE (type0); 3866 if (type0 != TREE_TYPE (op0)) 3867 TREE_OPERAND (node, 0) = op0 = convert (type0, op0); 3868 TREE_TYPE (node) = boolean_type_node; 3869 CH_DERIVED_FLAG (node) = 1; 3870 node = fold (node); 3871 if (!CH_DERIVED_FLAG (node)) 3872 { 3873 node = copy_node (node); 3874 CH_DERIVED_FLAG (node) = 1; 3875 } 3876 return node; 3877 case NE_EXPR: 3878 case EQ_EXPR: 3879 case GE_EXPR: 3880 case GT_EXPR: 3881 case LE_EXPR: 3882 case LT_EXPR: 3883 return build_compare_expr (TREE_CODE (node), op0, op1); 3884 default: 3885 ; 3886 } 3887 3888 if (!CH_COMPATIBLE_CLASSES (op0, op1)) 3889 { 3890 error ("incompatible operands to %s", tree_code_name[(int) TREE_CODE (node)]); 3891 return error_mark_node; 3892 } 3893 3894 if (TREE_TYPE (node) == NULL_TREE) 3895 { 3896 struct ch_class class; 3897 class = CH_ROOT_RESULTING_CLASS (op0, op1); 3898 TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0); 3899 type0 = TREE_TYPE (op0); 3900 TREE_OPERAND (node, 1) = op1 = convert_to_class (class, op1); 3901 type1 = TREE_TYPE (op1); 3902 TREE_TYPE (node) = class.mode; 3903 folded = convert_to_class (class, fold (node)); 3904 } 3905 else 3906 folded = fold (node); 3907#if 0 3908 if (folded == node) 3909 TREE_CONSTANT (folded) = TREE_CONSTANT (op0) & TREE_CONSTANT (op1); 3910#endif 3911 if (TREE_CODE (node) == TRUNC_DIV_EXPR) 3912 { 3913 if (TREE_CONSTANT (op1)) 3914 { 3915 if (tree_int_cst_equal (op1, integer_zero_node)) 3916 { 3917 error ("division by zero"); 3918 return integer_zero_node; 3919 } 3920 } 3921 else if (range_checking) 3922 { 3923#if 0 3924 tree test = 3925 build (EQ_EXPR, boolean_type_node, op1, integer_zero_node); 3926 /* Should this be overflow? */ 3927 folded = check_expression (folded, test, 3928 ridpointers[(int) RID_RANGEFAIL]); 3929#endif 3930 } 3931 } 3932 return folded; 3933} 3934 3935/* 3936 * This implements the '->' operator, which, like the '&' in C, 3937 * returns a pointer to an object, which has the type of 3938 * pointer-to-that-object. 3939 * 3940 * FORCE is 0 when we're evaluating a user-level syntactic construct, 3941 * and 1 when we're calling from inside the compiler. 3942 */ 3943tree 3944build_chill_arrow_expr (ref, force) 3945 tree ref; 3946 int force; 3947{ 3948 tree addr_type; 3949 tree result; 3950 3951 if (pass == 1) 3952 { 3953 error ("-> operator not allow in constant expression"); 3954 return error_mark_node; 3955 } 3956 3957 if (ref == NULL_TREE || TREE_CODE (ref) == ERROR_MARK) 3958 return ref; 3959 3960 while (TREE_CODE (TREE_TYPE (ref)) == REFERENCE_TYPE) 3961 ref = convert (TREE_TYPE (TREE_TYPE (ref)), ref); 3962 3963 if (!force && ! CH_LOCATION_P (ref)) 3964 { 3965 if (TREE_CODE (ref) == STRING_CST) 3966 pedwarn ("taking the address of a string literal is non-standard"); 3967 else if (TREE_CODE (TREE_TYPE (ref)) == FUNCTION_TYPE) 3968 pedwarn ("taking the address of a function is non-standard"); 3969 else 3970 { 3971 error ("ADDR requires a LOCATION argument"); 3972 return error_mark_node; 3973 } 3974 /* FIXME: Should we be sure that ref isn't a 3975 function if we're being pedantic? */ 3976 } 3977 3978 addr_type = build_pointer_type (TREE_TYPE (ref)); 3979 3980#if 0 3981 /* This transformation makes chill_expr_class return CH_VALUE_CLASS 3982 when it should return CH_REFERENCE_CLASS. That could be fixed, 3983 but we probably don't want this transformation anyway. */ 3984 if (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */ 3985 { 3986 tree addr; 3987 while (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */ 3988 ref = TREE_OPERAND (ref, 0); 3989 mark_addressable (ref); 3990 addr = build1 (ADDR_EXPR, 3991 build_pointer_type (TREE_TYPE (ref)), ref); 3992 return build1 (NOP_EXPR, /* RETYPE_EXPR */ 3993 addr_type, 3994 addr); 3995 } 3996 else 3997#endif 3998 { 3999 if (! mark_addressable (ref)) 4000 { 4001 error ("-> expression is not addressable"); 4002 return error_mark_node; 4003 } 4004 result = build1 (ADDR_EXPR, addr_type, ref); 4005 if (staticp (ref) 4006 && ! (TREE_CODE (ref) == FUNCTION_DECL 4007 && DECL_CONTEXT (ref) != 0)) 4008 TREE_CONSTANT (result) = 1; 4009 return result; 4010 } 4011} 4012 4013/* 4014 * This implements the ADDR builtin function, which returns a 4015 * free reference, analogous to the C 'void *'. 4016 */ 4017tree 4018build_chill_addr_expr (ref, errormsg) 4019 tree ref; 4020 char *errormsg; 4021{ 4022 if (ref == error_mark_node) 4023 return ref; 4024 4025 if (! CH_LOCATION_P (ref) 4026 && TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE) 4027 { 4028 error ("ADDR parameter must be a LOCATION"); 4029 return error_mark_node; 4030 } 4031 ref = build_chill_arrow_expr (ref, 1); 4032 4033 if (ref != NULL_TREE && TREE_CODE (ref) != ERROR_MARK) 4034 TREE_TYPE (ref) = ptr_type_node; 4035 else if (errormsg == NULL) 4036 { 4037 error ("possible internal error in build_chill_arrow_expr"); 4038 return error_mark_node; 4039 } 4040 else 4041 { 4042 error ("%s is not addressable", errormsg); 4043 return error_mark_node; 4044 } 4045 return ref; 4046} 4047 4048tree 4049build_chill_binary_op (code, op0, op1) 4050 enum chill_tree_code code; 4051 tree op0, op1; 4052{ 4053 register tree result; 4054 4055 if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK) 4056 return error_mark_node; 4057 if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK) 4058 return error_mark_node; 4059 4060 result = build (code, NULL_TREE, op0, op1); 4061 4062 if (pass != 1) 4063 result = finish_chill_binary_op (result); 4064 return result; 4065} 4066 4067/* 4068 * process a string repetition phrase '(' COUNT ')' STRING 4069 */ 4070tree 4071string_char_rep (count, string) 4072 int count; 4073 tree string; 4074{ 4075 int slen, charindx, repcnt; 4076 char ch; 4077 char *temp; 4078 char *inp; 4079 char *outp; 4080 tree type; 4081 4082 if (string == NULL_TREE || TREE_CODE (string) == ERROR_MARK) 4083 return error_mark_node; 4084 4085 type = TREE_TYPE (string); 4086 slen = int_size_in_bytes (type); 4087 temp = xmalloc (slen * count); 4088 inp = &ch; 4089 outp = temp; 4090 if (TREE_CODE (string) == STRING_CST) 4091 inp = TREE_STRING_POINTER (string); 4092 else /* single character */ 4093 ch = (char)TREE_INT_CST_LOW (string); 4094 4095 /* copy the string/char COUNT times into the output buffer */ 4096 for (outp = temp, repcnt = 0; repcnt < count; repcnt++) 4097 for (charindx = 0; charindx < slen; charindx++) 4098 *outp++ = inp[charindx]; 4099 return build_chill_string (slen * count, temp); 4100} 4101 4102/* Build a bit-string constant containing with the given LENGTH 4103 containing all ones (if VALUE is true), or all zeros (if VALUE is false). */ 4104 4105tree 4106build_boring_bitstring (length, value) 4107 long length; 4108 int value; 4109{ 4110 tree result; 4111 tree list; /* Value of CONSTRUCTOR_ELTS in the result. */ 4112 if (value && length > 0) 4113 list = tree_cons (integer_zero_node, size_int (length - 1), NULL_TREE); 4114 else 4115 list = NULL_TREE; 4116 4117 result = build (CONSTRUCTOR, 4118 build_bitstring_type (size_int (length)), 4119 NULL_TREE, 4120 list); 4121 TREE_CONSTANT (result) = 1; 4122 CH_DERIVED_FLAG (result) = 1; 4123 return result; 4124} 4125 4126/* 4127 * handle a string repetition, with the syntax: 4128 * ( COUNT ) 'STRING' 4129 * COUNT is required to be constant, positive and folded. 4130 */ 4131tree 4132build_chill_repetition_op (count_op, string) 4133 tree count_op; 4134 tree string; 4135{ 4136 int count; 4137 tree type = TREE_TYPE (string); 4138 4139 if (TREE_CODE (count_op) != INTEGER_CST) 4140 { 4141 error ("repetition count is not an integer constant"); 4142 return error_mark_node; 4143 } 4144 4145 count = TREE_INT_CST_LOW (count_op); 4146 4147 if (count < 0) 4148 { 4149 error ("repetition count < 0"); 4150 return error_mark_node; 4151 } 4152 if (! TREE_CONSTANT (string)) 4153 { 4154 error ("repetition value not constant"); 4155 return error_mark_node; 4156 } 4157 4158 if (TREE_CODE (string) == STRING_CST) 4159 return string_char_rep (count, string); 4160 4161 switch ((int)TREE_CODE (type)) 4162 { 4163 case BOOLEAN_TYPE: 4164 if (TREE_CODE (string) == INTEGER_CST) 4165 return build_boring_bitstring (count, TREE_INT_CST_LOW (string)); 4166 error ("bitstring repetition of non-constant boolean"); 4167 return error_mark_node; 4168 4169 case CHAR_TYPE: 4170 return string_char_rep (count, string); 4171 4172 case SET_TYPE: 4173 { int i, tree_const = 1; 4174 tree new_list = NULL_TREE; 4175 tree vallist; 4176 tree result; 4177 tree domain = TYPE_DOMAIN (type); 4178 tree orig_length; 4179 HOST_WIDE_INT orig_len; 4180 4181 if (!CH_BOOLS_TYPE_P (type)) /* cannot replicate a powerset */ 4182 break; 4183 4184 orig_length = discrete_count (domain); 4185 4186 if (TREE_CODE (string) != CONSTRUCTOR || !TREE_CONSTANT (string) 4187 || TREE_CODE (orig_length) != INTEGER_CST) 4188 { 4189 error ("string repetition operand is non-constant bitstring"); 4190 return error_mark_node; 4191 } 4192 4193 4194 orig_len = TREE_INT_CST_LOW (orig_length); 4195 4196 /* if the set is empty, this is NULL */ 4197 vallist = TREE_OPERAND (string, 1); 4198 4199 if (vallist == NULL_TREE) /* No bits are set. */ 4200 return build_boring_bitstring (count * orig_len, 0); 4201 else if (TREE_CHAIN (vallist) == NULL_TREE 4202 && (TREE_PURPOSE (vallist) == NULL_TREE 4203 ? (orig_len == 1 4204 && tree_int_cst_equal (TYPE_MIN_VALUE (domain), 4205 TREE_VALUE (vallist))) 4206 : (tree_int_cst_equal (TYPE_MIN_VALUE (domain), 4207 TREE_PURPOSE (vallist)) 4208 && tree_int_cst_equal (TYPE_MAX_VALUE (domain), 4209 TREE_VALUE (vallist))))) 4210 return build_boring_bitstring (count * orig_len, 1); 4211 4212 for (i = 0; i < count; i++) 4213 { 4214 tree origin = build_int_2 (i * orig_len, 0); 4215 tree temp; 4216 4217 /* scan down the given value list, building 4218 new bit-positions */ 4219 for (temp = vallist; temp; temp = TREE_CHAIN (temp)) 4220 { 4221 tree new_value 4222 = fold (size_binop (PLUS_EXPR, origin, TREE_VALUE (temp))); 4223 tree new_purpose = NULL_TREE; 4224 if (! TREE_CONSTANT (TREE_VALUE (temp))) 4225 tree_const = 0; 4226 if (TREE_PURPOSE (temp)) 4227 { 4228 new_purpose = fold (size_binop (PLUS_EXPR, 4229 origin, 4230 TREE_PURPOSE (temp))); 4231 if (! TREE_CONSTANT (TREE_PURPOSE (temp))) 4232 tree_const = 0; 4233 } 4234 4235 new_list = tree_cons (new_purpose, 4236 new_value, new_list); 4237 } 4238 } 4239 result = build (CONSTRUCTOR, 4240 build_bitstring_type (size_int (count * orig_len)), 4241 NULL_TREE, nreverse (new_list)); 4242 TREE_CONSTANT (result) = tree_const; 4243 CH_DERIVED_FLAG (result) = CH_DERIVED_FLAG (string); 4244 return result; 4245 } 4246 4247 default: 4248 error ("non-char, non-bit string repetition"); 4249 return error_mark_node; 4250 } 4251 return error_mark_node; 4252} 4253 4254tree 4255finish_chill_unary_op (node) 4256 tree node; 4257{ 4258 enum chill_tree_code code = TREE_CODE (node); 4259 tree op0 = check_have_mode (TREE_OPERAND (node, 0), "unary expression"); 4260 tree type0 = TREE_TYPE (op0); 4261 struct ch_class class; 4262 4263 if (TREE_CODE (op0) == ERROR_MARK) 4264 return error_mark_node; 4265 /* The expression codes of the data types of the arguments tell us 4266 whether the arguments are integers, floating, pointers, etc. */ 4267 4268 if (TREE_CODE (type0) == REFERENCE_TYPE) 4269 { 4270 op0 = convert (TREE_TYPE (type0), op0); 4271 type0 = TREE_TYPE (op0); 4272 } 4273 4274 if (invalid_right_operand (code, type0)) 4275 { 4276 error ("invalid operand of %s", 4277 tree_code_name[(int)code]); 4278 return error_mark_node; 4279 } 4280 switch ((int)TREE_CODE (type0)) 4281 { 4282 case ARRAY_TYPE: 4283 if (TREE_CODE ( TREE_TYPE (type0)) == BOOLEAN_TYPE) 4284 code = SET_NOT_EXPR; 4285 else 4286 { 4287 error ("right operand of %s is not array of boolean", 4288 tree_code_name[(int)code]); 4289 return error_mark_node; 4290 } 4291 break; 4292 case BOOLEAN_TYPE: 4293 switch ((int)code) 4294 { 4295 case BIT_NOT_EXPR: 4296 case TRUTH_NOT_EXPR: 4297 return invert_truthvalue (truthvalue_conversion (op0)); 4298 4299 default: 4300 error ("%s operator applied to boolean variable", 4301 tree_code_name[(int)code]); 4302 return error_mark_node; 4303 } 4304 break; 4305 4306 case SET_TYPE: 4307 switch ((int)code) 4308 { 4309 case BIT_NOT_EXPR: 4310 case NEGATE_EXPR: 4311 { 4312 tree temp = fold_set_expr (BIT_NOT_EXPR, op0, NULL_TREE); 4313 4314 if (temp) 4315 return temp; 4316 4317 code = SET_NOT_EXPR; 4318 } 4319 break; 4320 4321 default: 4322 error ("invalid right operand of %s", tree_code_name[(int)code]); 4323 return error_mark_node; 4324 } 4325 4326 } 4327 4328 class = chill_expr_class (op0); 4329 if (class.mode) 4330 class.mode = CH_ROOT_MODE (class.mode); 4331 TREE_SET_CODE (node, code); 4332 TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0); 4333 TREE_TYPE (node) = TREE_TYPE (op0); 4334 4335 node = convert_to_class (class, fold (node)); 4336 4337 /* FIXME: should call 4338 * cond_type_range_exception (op0); 4339 */ 4340 return node; 4341} 4342 4343/* op is TRUTH_NOT_EXPR, BIT_NOT_EXPR, or NEGATE_EXPR */ 4344 4345tree 4346build_chill_unary_op (code, op0) 4347 enum chill_tree_code code; 4348 tree op0; 4349{ 4350 register tree result = NULL_TREE; 4351 4352 if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK) 4353 return error_mark_node; 4354 4355 result = build1 (code, NULL_TREE, op0); 4356 4357 if (pass != 1) 4358 result = finish_chill_unary_op (result); 4359 return result; 4360} 4361 4362tree 4363truthvalue_conversion (expr) 4364 tree expr; 4365{ 4366 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) 4367 return error_mark_node; 4368 4369#if 0 /* what about a LE_EXPR (integer_type, integer_type ) */ 4370 if (TREE_CODE (TREE_TYPE (expr)) != BOOLEAN_TYPE) 4371 error ("non-boolean mode in conditional expression"); 4372#endif 4373 4374 switch ((int)TREE_CODE (expr)) 4375 { 4376 /* It is simpler and generates better code to have only TRUTH_*_EXPR 4377 or comparison expressions as truth values at this level. */ 4378#if 0 4379 case COMPONENT_REF: 4380 /* A one-bit unsigned bit-field is already acceptable. */ 4381 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) 4382 && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) 4383 return expr; 4384 break; 4385#endif 4386 4387 case EQ_EXPR: 4388 /* It is simpler and generates better code to have only TRUTH_*_EXPR 4389 or comparison expressions as truth values at this level. */ 4390 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: 4391 case TRUTH_ANDIF_EXPR: 4392 case TRUTH_ORIF_EXPR: 4393 case TRUTH_AND_EXPR: 4394 case TRUTH_OR_EXPR: 4395 case ERROR_MARK: 4396 return expr; 4397 4398 case INTEGER_CST: 4399 return integer_zerop (expr) ? boolean_false_node : boolean_true_node; 4400 4401 case REAL_CST: 4402 return real_zerop (expr) ? boolean_false_node : boolean_true_node; 4403 4404 case ADDR_EXPR: 4405 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) 4406 return build (COMPOUND_EXPR, boolean_type_node, 4407 TREE_OPERAND (expr, 0), boolean_true_node); 4408 else 4409 return boolean_true_node; 4410 4411 case NEGATE_EXPR: 4412 case ABS_EXPR: 4413 case FLOAT_EXPR: 4414 case FFS_EXPR: 4415 /* These don't change whether an object is non-zero or zero. */ 4416 return truthvalue_conversion (TREE_OPERAND (expr, 0)); 4417 4418 case LROTATE_EXPR: 4419 case RROTATE_EXPR: 4420 /* These don't change whether an object is zero or non-zero, but 4421 we can't ignore them if their second arg has side-effects. */ 4422 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) 4423 return build (COMPOUND_EXPR, boolean_type_node, TREE_OPERAND (expr, 1), 4424 truthvalue_conversion (TREE_OPERAND (expr, 0))); 4425 else 4426 return truthvalue_conversion (TREE_OPERAND (expr, 0)); 4427 4428 case COND_EXPR: 4429 /* Distribute the conversion into the arms of a COND_EXPR. */ 4430 return fold (build (COND_EXPR, boolean_type_node, TREE_OPERAND (expr, 0), 4431 truthvalue_conversion (TREE_OPERAND (expr, 1)), 4432 truthvalue_conversion (TREE_OPERAND (expr, 2)))); 4433 4434 case CONVERT_EXPR: 4435 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, 4436 since that affects how `default_conversion' will behave. */ 4437 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE 4438 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) 4439 break; 4440 /* fall through... */ 4441 case NOP_EXPR: 4442 /* If this is widening the argument, we can ignore it. */ 4443 if (TYPE_PRECISION (TREE_TYPE (expr)) 4444 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) 4445 return truthvalue_conversion (TREE_OPERAND (expr, 0)); 4446 break; 4447 4448 case BIT_XOR_EXPR: 4449 case MINUS_EXPR: 4450 /* These can be changed into a comparison of the two objects. */ 4451 if (TREE_TYPE (TREE_OPERAND (expr, 0)) 4452 == TREE_TYPE (TREE_OPERAND (expr, 1))) 4453 return build_chill_binary_op (NE_EXPR, TREE_OPERAND (expr, 0), 4454 TREE_OPERAND (expr, 1)); 4455 return build_chill_binary_op (NE_EXPR, TREE_OPERAND (expr, 0), 4456 fold (build1 (NOP_EXPR, 4457 TREE_TYPE (TREE_OPERAND (expr, 0)), 4458 TREE_OPERAND (expr, 1)))); 4459 } 4460 4461 return build_chill_binary_op (NE_EXPR, expr, boolean_false_node); 4462} 4463 4464 4465/* 4466 * return a folded tree for the powerset's length in bits. If a 4467 * non-set is passed, we assume it's an array or boolean bytes. 4468 */ 4469tree 4470powersetlen (powerset) 4471 tree powerset; 4472{ 4473 if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK) 4474 return error_mark_node; 4475 4476 return discrete_count (TYPE_DOMAIN (TREE_TYPE (powerset))); 4477} 4478