diff options
Diffstat (limited to 'gcc/ch')
37 files changed, 0 insertions, 57476 deletions
diff --git a/gcc/ch/ChangeLog b/gcc/ch/ChangeLog deleted file mode 100644 index 8356aa22a4a..00000000000 --- a/gcc/ch/ChangeLog +++ /dev/null @@ -1,12190 +0,0 @@ -Sun Feb 4 15:52:44 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * convert.c (convert): Call abort instead of fatal. - * except.c (pop_handler, chill_check_no_handlers): Likewise. - * expr.c (chill_expand_expr): Likewise. - * parse.c (peek_token_, pushback_token, require): Likewise. - * grant.c (write_grant_file): Call fatal_io_error instead of - pfatal_with_name. - * lex.c (init_parse, same_file, yywrap): Likewise. - * lang.c (GNU_xref_begin, GNU_xref_end): Deleted. - * lex.c (convert_bitstring): Delete check for alloca failure. - -2001-01-28 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * ch-tree.h (integer_minus_one_node): Moved to top level gcc - directory. - - * decl.c (integer_minus_one_node): Likewise. - (init_decl_processing): Don't set integer_minus_one_node. - -2001-01-27 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in: Remove all dependencies on defaults.h. - * decl.c: Don't include defaults.h. - * timing.c: Likewise. - -2000-12-08 Joseph S. Myers <jsm28@cam.ac.uk> - - * Make-lang.in (CHILL.info): Depend on info files in source - directory. - (ch/chill.info): Build info files in source directory. - (CHILL.install-info): Install info files from source directory. - -2000-12-07 Zack Weinberg <zack@wolery.stanford.edu> - - * lex.c: Don't bother checking whether ISUPPER(c) before - calling TOLOWER(c). Don't bother checking whether isascii(c) - before testing ISSPACE(c); ISSPACE(c) includes '\n'. - -2000-12-06 Rodney Brown <RodneyBrown@mynd.com> - - * actions.h: Standarize copyright statement. - * except.c inout.c lang.c lex.c lex.h loop.c nloop.c: Likewise. - * parse.c tasking.c tasking.h timing.c xtypeck.c: Likewise. - -2000-11-07 Joseph S. Myers <jsm28@cam.ac.uk> - - * actions.c (check_missing_cases), typeck.c (build_chill_slice, - build_chill_cast): Use memset () instead of bzero (). - -2000-11-05 Joseph S. Myers <jsm28@cam.ac.uk> - - * Make-lang.in (CHILL.distdir): Remove. - -2000-11-02 Geoffrey Keating <geoffk@cygnus.com> - - * Make-lang.in: Remove 'CYGNUS LOCAL' markers. - * Makefile.in: Likewise. - * configure: Likewise. - -2000-10-07 Joseph S. Myers <jsm28@cam.ac.uk> - - * Makefile.in ($(srcdir)/hash.h): Refer to GNU FTP site for - updated gperf. - -2000-10-05 Richard Henderson <rth@cygnus.com> - - * decl.c (finish_chill_function): Don't init can_reach_end. - -2000-09-10 Zack Weinberg <zack@wolery.cumb.org> - - * decl.c, timing.c: Include defaults.h if not already included. - Don't define the *_TYPE_SIZE macros. - * Makefile.in: Update dependencies. - -2000-08-29 Zack Weinberg <zack@wolery.cumb.org> - - * inout.c (add_enum_to_list): Use DECL_NAME directly, don't get - its IDENTIFIER_POINTER and immediately call get_identifier on it. - * lex.c (yywrap): Constify a char *. - -2000-08-24 Mark Mitchell <mark@codesourcery.com> - - * Make-lang.in (cc1chill): Don't depend on c-iterate.o. - -2000-08-21 Nix <nix@esperi.demon.co.uk> - - * lang-specs.h: Do not process -o or run the assembler if - -fsyntax-only. - -2000-08-07 Kazu Hirata <kazu@hxi.com> - - * decl.c: Fix a comment typo. - -2000-08-04 Zack Weinberg <zack@wolery.cumb.org> - - * Make-lang.in (cc1chill): Depend on $(BACKEND), not stamp-objlist. - * Makefile.in (cc1chill): Link with $(BACKEND). Define BACKEND, - eliminate C_OBJS (was commented out), OBJS, OBJDEPS. - -2000-07-31 Zack Weinberg <zack@wolery.cumb.org> - - * lang-specs.h: Rename cpp to cpp0 and/or tradcpp to tradcpp0. - -Mon Jul 31 07:58:31 2000 Casper Dik <Casper.Dik@holland.sun.com> - - * Makefile.in: Remove naked "^L". - -2000-07-13 Zack Weinberg <zack@wolery.cumb.org> - - * lang-specs.h: Use the new named specs. Remove unnecessary braces. - -2000-06-13 Jakub Jelinek <jakub@redhat.com> - - * decl.c (init_decl_processing): Set TYPE_USER_ALIGN. - (layout_enum): Set DECL_USER_ALIGN resp. TYPE_USER_ALIGN. - * typeck.c (layout_chill_range_type): Set TYPE_USER_ALIGN. - (apply_chill_field_layout): Set DECL_USER_ALIGN. - (layout_chill_struct_type): Set TYPE_USER_ALIGN. - -Tue Jun 13 15:30:46 2000 Maciej W. Rozycki <macro@ds2.pg.gda.pl> - - * Make-lang.in (CHILL.install-common): Use $(INSTALL_SCRIPT), not - $(INSTALL_PROGRAM) for chill.install. - -2000-06-11 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (EXPR_H): New dependency variable. - (actions.o, expr.o): Use EXPR_H. - (lang.o): Depend on RTL_H and EXPR_H. - - * lang.c: Include rtl.h and expr.h. - (lang_get_alias_set): Mark parameter with ATTRIBUTE_UNUSED. - -2000-06-04 Philipp Thomas <pthomas@suse.de> - - * Makefile.in(INTLLIBS): New macro. - (LIBS): Add INTLLIBS. - (DEPLIBS): Likewise. - * config-lang(outputs): Specify ch/Makefile. - -Sat Jun 3 15:31:07 2000 Jeffrey A Law (law@cygnus.com) - - * chill.texi (INFO-DIR-ENTRY): Fix chill entry. - -2000-06-02 Richard Henderson <rth@cygnus.com> - - * lang.c (lang_get_alias_set): New. - -Sat May 27 11:24:26 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * lang.c (deep_const_expr): Use first_rtl_op. - * satisfy.c (satisfy): Use TREE_CODE_LENGTH. - -2000-05-18 Chris Demetriou <cgd@netbsd.org> - - * Makefile.in (hash.h): Delete a redundant use of gawk and sed. - -Wed May 17 17:27:44 2000 Andrew Cagney <cagney@b1.cygnus.com> - - * decl.c (c_decode_option): Update -Wall unused flags by - calling set_Wunused. - (poplevel): Replace warn_unused with warn_unused_label. - -2000-05-09 Zack Weinberg <zack@wolery.cumb.org> - - * ch-tree.h: Update prototypes. Remove prototypes for - functions declared elsewhere. - * decl.c (define_label): Constify filename parameter. - * grant.c (globalize_decl, set_default_grant_file): Constify - local char * variables. Don't declare - first_global_object_name or asm_out_file. - * lang.c (chill_real_input_filename): Constify. - * lex.c (init_parse): Constify parameter and return value. - * parse.c: Don't declare input_filename. - (ch_expand_asm_operands): Constify filename parameter. - (parse_multi_dimension_case_action): Constify local char *. - * satisfy.c (safe_satisfy_decl): Constify local char *. - -2000-05-04 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * ch-tree.h (init_function_start): Constify. - -2000-04-18 Zack Weinberg <zack@wolery.cumb.org> - - * ch/lex.c: Remove references to cccp.c. - -2000-04-03 Zack Weinberg <zack@wolery.cumb.org> - - * lang-specs.h: Pass -fno-show-column to the preprocessor. - -Thu Mar 30 06:32:51 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * expr.c (chill_expand_expr): Pass bit alignment to emit_block_move. - -Sat Mar 25 09:12:10 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * actions.c (check_missing_cases): BYTES_NEEDED is HOST_WIDE_INT. - * typeck.c (expand_constant_to_buffer): Use int_byte_position. - (extract_constant_from_buffer): Likewise. - -Fri Mar 17 08:09:14 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * typeck.c (min_precision): New function. - (build_chill_slice): Use host_integerp and tree_low_cst. - (expand_constant_to_buffer): Likewise and also int_bit_position. - LO is unsigned HOST_WIDE_INT - (build_chill_array_ref_1): Make `i' be HOST_WIDE_INT; use tree_low_cst. - (extract_constant_from_buffer): Sizes are now HOST_WIDE_INT. - Use host_integerp and tree_low_cst. - (build_chill_bin_type): Use host_integerp and tree_low_cst. - (layout_chill_range_type): Use tree_int_cst_sgn, compare_tree_int, - tree_low_cst, and min_precision. - (apply_chill_array_layout): Cleanups for types of variables - and use tree_int_cst_sgn, compare_tree_int, and tree_low_cst. - (apply_chill_field_layout): Likewise. - -2000-03-07 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * grant.c (globalize_decl): Constify a char*. - -Mon Mar 6 17:52:48 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * actions.c (chill_convert_for_assignment): INDEX is unsigned - HOST_WIDE_INT. - * ch-tree.h (DECL_NESTING_LEVEL): Use TREE_INT_CST_HIGH since unsigned. - * except.c (chill_handle_on_labels): ALTERNATIVE is unsigned. - Use compare_tree_int. - (expand_goto_except_cleanup): Likewise. - -2000-03-01 Martin von Loewis <loewis@informatik.hu-berlin.de> - - * decl.c (current_function_decl): Move to toplev.c. - -Mon Feb 28 08:12:26 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * ch-tree.h (DECL_ACTION_NESTING_LEVEL): Use new tree union name. - * decl.c (finish_struct): Don't clear DECL_FIELD_SIZE. - * typeck.c (make_chill_struct_type): Likewise. - (apply_decl_field_layout): General cleanup. - Set DECL_SIZE instead of DECL_FIELD_SIZE. - -Sun Feb 27 16:40:33 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * actions.c (chill_convert_for_assignment): Don't use size_binop - for things that aren't sizes. - (expand_varying_length_assignment): Likewise. - * convert.c (digest_array_tuple, convert): Likewise. - * typeck.c (build_chill_slice, smash_dummy_type): Likewise. - (build_chill_slice_with_range): Likewise. - (build_chill_slice_with_length): Likewise. - (build_array_from_set): Adjust types for size_binop. - * expr.c (build_concat_expr, build_chill_repetition_op): Likewise. - (build_chill_sizeof): Use TYPE_SIZE_UNIT. - * tree.c (build_string_type): Pass proper type to size_binop. - -Sat Feb 19 18:43:13 2000 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * decl.c (layout_enum): Set DECL_SIZE_UNIT. - * satisfy.c (safe_satisfy_decl): Likewise. - -2000-02-15 Jonathan Larmour <jlarmour@redhat.co.uk> - - * lang-specs.h: Add new __GNUC_PATCHLEVEL__ define to default spec. - -2000-02-15 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * grant.c: Don't declare `version_string'. - -2000-02-11 Nathan Sidwell <nathan@acm.org> - - * decl.c (init_decl_processing): Remove duplicate decl of - set_alignment. - -2000-02-11 Franz Sirl <Franz.Sirl-kernel@lauterbach.com> - - * expr.c (compare_records): Delete maximum_field_alignment declaration. - * inout.c (inout_init): Likewise. - (build_chill_gettextaccess): Likewise. - (build_enum_tables): Likewise. - * lang.c: Likewise. - * satisfy.c (satisfy): Likewise. - * tasking.c (build_tasking_struct): Likewise. - (build_tasking_message_type): Likewise. - * typeck.c (build_init_struct): Likewise. - - * except.c (emit_setup_handler): Make save_maximum_field_alignment - unsigned int to match maximum_field_alignment. - * inout.c (inout_init): Likewise. - (build_chill_gettextaccess): Likewise. - (build_enum_tables): Likewise. - * tasking.c (build_tasking_struct): Likewise. - (build_tasking_message_type): Likewise. - * typeck.c (build_init_struct): Likewise. - -2000-02-10 Franz Sirl <Franz.Sirl-kernel@lauterbach.com> - - * except.c (maximum_field_alignment): Remove duplicate declaration. - -2000-01-17 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * All files: PROTO -> PARAMS. - -2000-01-10 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * lex.c: Include tm_p.h. - -2000-01-04 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * actions.c (update_else_range_for_int_const): Initialize - variables `lowval' and `highval'. - (update_else_range_for_range): Likewise for `low_range_val' and - `high_range_val'. - -1999-12-11 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * typeck.c (apply_chill_array_layout, apply_chill_field_layout): - Avoid the use of ANSI string concatenation. - - * expr.c (chill_expand_case_expr): Likewise. - -1999-11-23 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * expr.c (build_chill_function_call): Don't call a variadic - function with a non-literal format string. - - * grant.c (write_spec_module): Likewise. - - * parse.c (require, expect): Likewise. - - * tasking.c (get_struct_type_name, get_struct_debug_type_name, - get_tasking_code_name, get_struct_variable_name, - get_process_wrapper_name, build_start_process): Likewise. - - * typeck.c (valid_array_index_p): Likewise. - -Sun Oct 31 22:33:33 1999 Jeffrey A Law (law@cygnus.com) - - * Makefile.in (convert.o, typeck.o): Depend on output.h - * convert.c: Include output.h. - * typeck.c: Include output.h. - (initializer_constant_valid_p): Delete fucntion. - * ch-tree.h (initializer_constant_valid_p): Delete prototype. - -1999-10-26 Mark Mitchell <mark@codesourcery.com> - - * ch-tree.h (remember_end_note): Remove prototype. - * decl.c (poplevel): Don't call remember_end_note. - -Fri Sep 24 10:48:10 1999 Bernd Schmidt <bernds@cygnus.co.uk> - - * ch-tree.h (builtin_function): Don't declare. - * decl.c (builtin_function): New arg CLASS. Arg FUNCTION_CODE now of - type int. All callers changed. - Set the builtin's DECL_BUILT_IN_CLASS. - -1999-09-20 Nick Clifton <nickc@cygnus.com> - - * lang.c (lang_decode_option): Extend comment. - -1999-09-16 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * lex.c (maybe_downcase, getlc, handle_generic_pragma, - check_newline): Use uppercase ctype macro from system.h. - -1999-09-15 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * actions.c (warn_unhandled): Use xstrdup, not xmalloc/strcpy. - -Fri Sep 10 10:32:32 1999 Bernd Schmidt <bernds@cygnus.co.uk> - - * ch-tree.h: Delete declarations for all tree nodes now moved to - global_trees. - * expr.c: Likewise. - * typeck.c: Likewise. - * decl.c: Delete their definitions. - (init_decl_processing): Call build_common_tree_nodes and - build_common_tree_nodes_2 instead of building their nodes here. - Use set_sizetype instead of assigning sizetype. - -1999-09-08 Bruce Korb autogen@linuxbox.com - - * Makefile.in: Give the gperf user a hint about why "gperf -F" fails. - -Tue Sep 7 15:59:56 1999 Dave Brolley <brolley@cygnus.com> - - * parse.h: Undefine DELAY if it's defined. - (PACK,NOPACK,POS): Remove erroneous comments regarding these tokens. - Also, move them to their proper place alphabetically. - -1999-09-04 Mark Mitchell <mark@codesourcery.com> - - * Make-lang.in (cc1chill): Depend on ggc-callbacks.o. - * Makefile.in (CHILL_OBJS): Add ggc-callbacks.o. - -1999-08-30 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * parse.c (language_string): Constify. - -1999-08-30 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (LIBS, LIBDEPS): Link with & depend on libiberty.a. - Remove hacks for stuff which now comes from libiberty. - -1999-08-29 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * lang.c (chill_print_error_function): Constify a char*. - -1999-08-29 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (ch-version.c): Constify a char*. - - * actions.c (id_cmp, warn_unhandled, adjust_return_value, - update_else_range_for_int_const, update_else_range_for_range, - update_else_range_for_range_expr, update_else_range_for_type, - compute_else_range, check_case_value, - chill_handle_case_label_range, - chill_handle_multi_case_label_range, - chill_handle_multi_case_else_label, chill_handle_multi_case_label, - chill_handle_multi_case_label_list print_missing_cases): Add - static prototypes. - (build_exception_variant): Cast the function argument of qsort. - (build_rts_call, warn_unhandled, chill_convert_for_assignment, - adjust_return_value, chill_expand_result, - build_multi_case_selector_expression, print_missing_cases): - Constify a char*. - (print_missing_cases): Introduce an intermediary non-const ptr. - Add brackets and indent. - - * ch-tree.h (maybe_building_objc_message_expr, - maybe_objc_comptypes, comptypes_record_hook): Remove declarations. - (push_handler, pop_handler): Add prototypes. - (builtin_function, valid_array_index_p, - build_chill_exception_decl, build_rts_call, - chill_convert_for_assignment, display_int_cst, - build_chill_addr_expr, check_have_mode, get_identifier3, - build_chill_string, register_seize_path, get_unique_identifier, - add_taskstuff_to_list, gnuchill_version): Constify a char*. - (finish_chill_function): Add void prototype argument. - - * convert.c (convert_to_reference, convert_to_boolean, - convert_to_char, base_type_size_in_bytes, remove_tree_element, - check_ps_range, digest_powerset_tuple, digest_structure_tuple, - digest_array_tuple, convert1): Add static prototypes. - (base_type_size_in_bytes): Hide unused function. - (display_int_cst, digest_array_tuple): Constify a char*. - - * decl.c (set_nesting_level, make_chill_variants, fix_identifier, - proclaim_decl, maybe_acons, push_scope_decls, pop_scope_decls, - build_implied_names, bind_sub_modules, layout_array_type, - do_based_decl, handle_one_level, label_value_cmp, - find_implied_types): Add static prototypes. - (boolean_code_name, chill_tree_code_type, chill_tree_code_name): - Constify a char*. - (layout_chill_variants): Cast the function argument of qsort. - (start_chill_function, fix_identifier, init_decl_processing): - Constify a char*. - (init_decl_processing): Prefer memcpy over bcopy to avoid casts. - Use xcalloc instead of xmalloc/bzero. - (builtin_function, build_chill_exception_decl, - finish_outer_function): Constify a char*. - - * except.c (start_handler_array, finish_handler_array): Add static - prototypes. - - * expr.c (chill_expand_expr, chill_expand_case_expr, - check_arglist_length, internal_build_compound_expr, - is_really_instance, invalid_operand, invalid_right_operand, - build_chill_abstime, build_allocate_memory_call, - build_allocate_global_memory_call, build_return_memory, - build_chill_duration, build_chill_floatcall, - build_allocate_getstack, build_chill_allocate, - build_chill_getstack, build_chill_terminate, build_chill_inttime, - build_chill_lower_or_upper, build_max_min, - build_chill_pred_or_succ, expand_packed_set, fold_set_expr, - build_compare_set_expr, scalar_to_string, build_concat_expr, - build_compare_string_expr, compare_records, string_char_rep, - build_boring_bitstring): Add static prototypes. - (check_have_mode, chill_expand_expr, build_chill_floatcall, - build_allocate_getstack, build_max_min, build_chill_function_call, - expand_packed_set, build_compare_set_expr, build_chill_addr_expr, - string_char_rep): Constify a char*. - - * gperf (hash, in_word_set): Add prototypes. - - * grant.c (newstring, strfree, append, prepend, - grant_use_seizefile, decode_layout, grant_array_type, - grant_array_type_selective, get_tag_value, - get_tag_value_selective, print_enumeral, print_enumeral_selective, - print_integer_type, find_enum_parent, print_integer_selective, - print_struct, print_struct_selective, print_proc_exceptions, - print_proc_tail, print_proc_tail_selective, find_in_decls, - in_ridpointers, grant_seized_identifier, globalize_decl, - grant_one_decl_selective, compare_memory_file, search_in_list, - really_grant_this): Add static prototypes. - (newstring, append, prepend, grant_use_seizefile, - print_integer_type, decode_constant, grant_one_decl_selective, - header_template): Constify a char *. - - * inout.c (add_enum_to_list, build_chill_io_list_type, - build_io_types, declare_predefined_file, build_access_part, - textlocation_mode, check_assoc, assoc_call, check_transfer, - connect_process_optionals, connect_text, connect_access, - check_access, check_text, get_final_type_and_range, - process_io_list, check_format_string, get_max_size, - check_exprlist): Add static prototypes. - (declare_predefined_file, check_assoc, assoc_call, check_transfer, - check_access, check_text, process_io_list): Constify a char*. - - * lang.c (deep_const_expr, chill_print_error_function): Add static - prototypes. - - * lex.c (close_input_file, maybe_number, string_or_char): Constify - a char*. - (ch_lex_init, skip_directive, same_file, getlc, yywrap, - yy_refill): Add static prototypes. - (build_chill_string, same_file, register_seize_path): Constify a - char*. - - * lex.h (finish_chill_seizes): Remove unused prototypes. - - * loop.c (build_temporary_variable, maybe_make_for_temp, - get_unique_identifier): Constify a char*. - - * parse.c (ch_parse_init, check_end_label, end_function, - build_prefix_clause, PEEK_TOKEN, peek_token_, pushback_token, - forward_token_, require, check_token, expect, define__PROCNAME__): - Add static prototypes. - (build_prefix_clause, expect): Constify a char*. - (parse_expression, parse_primval, parse_untyped_expr, - parse_opt_untyped_expr, parse_opt_actions): Add void prototype - argument. - (parse_opt_name_string, parse_simple_name_string, - parse_name_string, parse_defining_occurrence, parse_name, - parse_optlabel, parse_opt_end_label_semi_colon, parse_modulion, - parse_spec_module, parse_semi_colon, - parse_defining_occurrence_list, parse_mode_definition, - parse_mode_definition_statement, parse_synonym_definition, - parse_synonym_definition_statement, parse_on_exception_list, - parse_on_alternatives, parse_loc_declaration, - parse_declaration_statement, parse_optforbid, parse_postfix, - parse_postfix_list, parse_rename_clauses, parse_opt_prefix_clause, - parse_grant_statement, parse_seize_statement, - parse_param_name_list, parse_param_attr, parse_formpar, - parse_formparlist, parse_opt_result_spec, parse_opt_except, - parse_opt_recursive, parse_procedureattr, parse_proc_body, - parse_procedure_definition, parse_processpar, - parse_processparlist, parse_process_definition, - parse_signal_definition, parse_signal_definition_statement, - parse_then_clause, parse_opt_else_clause, parse_expr_list, - parse_range_list_clause, pushback_paren_expr, parse_case_label, - parse_case_label_list, parse_case_label_specification, - parse_single_dimension_case_action, - parse_multi_dimension_case_action, parse_case_action, - parse_asm_operands, parse_asm_clobbers, ch_expand_asm_operands, - parse_asm_action, parse_begin_end_block, parse_if_action, - parse_iteration, parse_delay_case_event_list, - parse_delay_case_action, parse_do_action, parse_receive_spec, - parse_receive_case_action, parse_send_action, parse_start_action, - parse_call, parse_tuple_fieldname_list, parse_tuple_element, - parse_opt_element_list, parse_tuple, parse_operand6, - parse_operand5, parse_operand4, parse_operand3, parse_operand2, - parse_operand1, parse_operand0, parse_case_expression, - parse_then_alternative, parse_else_alternative, - parse_if_expression, parse_index_mode, parse_set_mode, parse_pos, - parse_step, parse_opt_layout, parse_field_name_list, - parse_fixed_field, parse_variant_field_list, - parse_variant_alternative, parse_field, parse_structure_mode, - parse_opt_queue_size, parse_procedure_mode, parse_program, - parse_pass_1_2): Add static prototypes. - (parse_process_definition): Remove extra argument in function call. - (parse_range_list_clause): Likewise. - - * satisfy.c (satisfy, cycle_error_print, safe_satisfy_decl, - satisfy_list, satisfy_list_values): Add static prototype. - (safe_satisfy_decl): Cast DECL_TASKING_CODE_DECL() to (tree). - - * tasking.c (make_process_struct): Remove unused prototype. - (validate_process_parameters, get_struct_variable_name, - decl_tasking_code_variable, get_struct_debug_type_name, - get_process_wrapper_name, build_tasking_enum, - build_tasking_message_type, build_receive_signal_case_label, - build_receive_buffer_case_label, build_receive_buffer_case_end, - build_receive_signal_case_end): Add static prototypes. - (struct_name, struct_debug_name, data_name, wrapper_name, - get_struct_type_name, get_struct_debug_type_name, - get_tasking_code_name, get_struct_variable_name, - get_process_wrapper_name): Constify a char*. - (validate_process_parameters, get_struct_variable_name, - decl_tasking_code_variable): Hide unused functions. - (build_start_process, add_taskstuff_to_list, build_queue_length): - Constify a char*. - - * tree.c (make_powerset_type): Add static prototype. - (get_identifier3, build_alias_decl, decl_check_rename): Constify a - char*. - - * typeck.c (extract_constant_from_buffer, - expand_constant_to_buffer, build_empty_string, - make_chill_pointer_type, make_chill_range_type, - apply_chill_array_layout, field_decl_cmp, make_chill_struct_type, - apply_chill_field_layout): Add static prototype. - (valid_array_index_p, extract_constant_from_buffer, - chill_expand_tuple): Constify a char*. - (layout_chill_struct_type): Cast the function argument of qsort. - -1999-08-09 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * actions.c (lang_identify): Constify a char*. - - * lang.c (chill_print_error_function): Likewise. - (lang_init): Remove redundant prototype for `print_error_function'. - -1999-07-25 Richard Henderson <rth@cygnus.com> - - * decl.c (va_list_type_node): New. - -1999-06-25 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Make-lang.in (CHILL.stage1): Depend on stage1-start. - (CHILL.stage2): Likewise for stage2-start. - (CHILL.stage3): Likewise for stage3-start. - (CHILL.stage4): Likewise for stage4-start. - -Tue May 18 00:21:34 1999 Zack Weinberg <zack@rabi.phys.columbia.edu> - - * lang-specs.h: Define __GNUC__ and __GNUC_MINOR__ only if -no-gcc - was not given. - -1999-05-10 18:21 -0400 Zack Weinberg <zack@rabi.phys.columbia.edu> - - * lang-specs.h: Pass -$ to the preprocessor. - -Tue May 4 14:52:53 1999 Dave Brolley <brolley@cygnus.com> - - * actions.c (chill_expand_assignment): Use powersetlen to calculate the - length of an array of packed bits. - -Tue Apr 20 23:37:01 1999 Nathan Sidwell <nathan@acm.org> - - * Make-lang.in (ch/chill.info): Put MAKEINFO parameters in correct - order. - -Wed Apr 14 21:07:30 1999 Mumit Khan <khan@xraylith.wisc.edu> - - * config-lang.in (compilers): Add exeext. - (stagestuff): Likewise. - -Fri Apr 2 15:49:44 1999 Jeffrey A Law (law@cygnus.com) - - * Make-lang.in (CHILL_FLAGS_TO_PASS): Do not pass $(CC). - -Wed Mar 31 10:44:47 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (hash.h): Generate using gperf language 'C', not - 'KR-C', so gperf uses the `const' keyword on strings. - - * gperf (resword): Const-ify a char*. - -Sun Mar 28 00:30:36 1999 Jeffrey A Law (law@cygnus.com) - - * Make-lang.in (CHILL.dvi): New target. - (CHILL.mostlyclean): Remove remnants of old runtime library structure. - -1999-02-20 Craig Burley <craig@jcb-sc.com> - - * Make-lang.in (CHILL.info): Depend on intermediate ch/chill.info - target instead of the chill.texi file. - (ch/chill.info): New target, depends on the chill.texi source file. - Its command writes ch/chill.info instead of chill.info. - (CHILL.install-info): Install from ch/chill.info instead of - chill.info. - If any ch/chill.info* files exist, delete *all* chill.info* files - in $infodir first, not just the ones corresponding to the - files to be installed (just in case the docs get smaller). - -Sun Jan 31 20:34:29 1999 Zack Weinberg <zack@rabi.columbia.edu> - - * decl2.c: Don't define flag_no_ident here. Don't process - -f(no-)ident here. - * ch-tree.h: Don't declare flag_no_ident here. - * lang-specs.h: Map -Qn to -fno-ident. - -Tue Jan 19 23:24:36 1999 Jeffrey A Law (law@cygnus.com) - - * Makefile.in (typeck.o): Depend on insn-codes.h. - * actions.c (chill_handle_multi_case_label): Initialize "expr". - * decl.c (poplevel): Initialize "block_previously_created". - * expr.c (chill_expand_expr): Initialize "size0" and "size1". - (fold_set_expr): Initialize "buffer1". - * inout.c (process_io_list): Initialize "to_assign". - (check_exprlist): Initialize "result". - * parse.c (expand_expr): Declare. - (parse_multi_dimension_case_action): Initialize "end_case_label". - * tasking.c (build_start_process): Initialize "struct_type_node". - * typeck.c (apply_chill_field_layout): Initialize "word". - (type_for_mode); Unconditionally cast RHS & LHS to ints to shut up - signed/unsigned comparison warning. - -Mon Jan 18 11:55:06 1999 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * ch-tree.h: Remove conflicting prototypes for pedwarn, - warning_with_decl, and make_dcl_rtl. - -Sun Jan 17 21:53:23 1999 Jeffrey A Law (law@cygnus.com) - - * Makefile.in: Do not put ^Ls at the start of a line. - -Wed Jan 6 02:53:38 1999 Jeffrey A Law (law@cygnus.com) - - * Makefile.in: Add some missing $(exeext). Remove some obsolete - runtime stuff. - * Make-lang.in: Similarly. - -Tue Nov 24 09:57:34 1998 Jeffrey A Law (law@cygnus.com) - - * Makefile.in (lex.c): Do not depend on hash.h. - (lex.o): Depend on hash.h. - -Mon Oct 19 12:13:47 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (lex.o): Depend on dwarfout.h. - - * lang-specs.h: Add missing braces in initializer. - - * lex.c: Include dwarfout.h, if DWARF_DEBUGGING_INFO is defined. - -Thu Oct 15 09:25:21 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * expr.c (build_chill_card): Use &&, not &, when comparing truth - values. - - * parse.c (parse_spec_module): Remove unused variable - `module_name', but preserve function call from initialization. - (parse_operand6): Mark variable `location' with ATTRIBUTE_UNUSED. - - * inout.c (init_text_location): Remove unused variable `textlength'. - -Wed Oct 14 22:19:48 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * typeck.c (build_chill_cast): Fix typo in assignment statement. - - * tasking.c (build_signal_descriptor): Use IDENTIFIER_POINTER() - when printing a `tree'. - -Fri Oct 9 13:01:23 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * ch-tree.h (build_delay_case_end): Remove unused parameter. - (build_receive_case_end): Likewise. - (check_queue_size): Likewise. - - * parse.c: Callers changed. - - * satisfy.c: Likewise. - - * tasking.c (build_receive_buffer_case_end): Remove unused - parameter `label_cnt'. - (build_receive_signal_case_end): Likewise. - (build_receive_case_end): Likewise. - (build_delay_case_end): Likewise. - (check_queue_size): Likewise for parameter `type'. - All callers changed. - -Thu Oct 8 05:57:41 1998 Jeffrey A Law (law@cygnus.com) - - * typeck (type_for_mode): Only return TItype nodes when - HOST_BITS_PER_WIDE_INT is >= 64 bits. - (type_for_size): Similarly. - * decl.c (intTI_type_node, unsigned_intTI_type_node): Only declare - when HOST_BITS_PER_WIDE_INT is >= 64 bits. - (init_decl_processing): Only create TItype nodes when - HOST_BITS_PER_WIDE_INT is >= 64 bits. - -Wed Oct 7 12:19:21 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (hash.h): Add -L KR-C -F ', 0, 0, 0' flags to gperf. - (hash.h): Regenerate using gperf 2.7.1 (19981006 egcs). - -Thu Oct 1 10:43:45 1998 Nick Clifton <nickc@cygnus.com> - - * lex.c: Replace occurances of HANDLE_SYSV_PRAGMA with - HANDLE_GENERIC_PRAGMAS. - (handle_generic_pragma): New function: Parse generic pragmas. - -Wed Sep 30 20:22:34 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * parse.c (emit_label): Fix return-type of prototype. - -Wed Sep 30 19:41:36 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * actions.c (chill_handle_multi_case_label): Always return a value - in function returning non-void. - - * except.c: Include OS headers before any local ones. - - * typeck.c (layout_chill_range_type): Change type of variable - `negprecision' to int. - (apply_chill_array_layout): Initialize variables `stepsize' and - `start_bit'. - (layout_chill_struct_type): Change type of variable `min_align' to - unsigned int. - (smash_dummy_type): Change name of variable `main' to `main_tree'. - -Wed Sep 30 19:24:41 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * actions.c (id_cmp): Do pointer arithmetic as `long' not `int' to - ensure enough bits for calculation. - - * ch-tree.h (check_text_length): Remove unused parameter. - - * convert.c (display_int_cst): Cast a HOST_WIDE_INT argument to - function sprintf into the appropriate type for printing. - - * decl.c (print_lang_decl): Use HOST_WIDE_INT_PRINT_DEC as the - format specifier. - (print_mode): Likewise. - (init_decl_processing): Cast the arguments of bcopy/bzero to char *. - - * grant.c (grant_array_type): Use HOST_WIDE_INT_PRINT_DEC as - the format specifier. - - * inout.c (check_text_length): Remove unused parameter `type'. - (build_chill_associate): Initialize variables `arg1', `arg2', - `arg3', `arg4' and `arg5'. - (build_chill_modify): Likewise. - (scanformcont): Change type of variable `curr' to `unsigned char'. - - * lex.c (maybe_downcase): Cast the argument of `tolower' to - `unsigned char'. - - * satisfy.c (satisfy): Remove unused parameter in call to - `check_text_length'. - - * tasking.c (generate_tasking_code_variable): Pass a HOST_WIDE_INT - as a `long' in call to function `error'. - (decl_tasking_code_variable): Likewise. - -Wed Sep 30 19:03:02 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * grant.c (decode_decl_selective): Cast switch's enum argument to - an int. - (really_grant_this): Add default case in switch. - - * typeck.c (chill_resulting_class): Add default cases in switch. - Also add `break' statements after each case. - -Tue Sep 29 21:37:33 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * ch-tree.h (build_compare_expr): Change first argument's type - from `enum chill_tree_code' to `enum tree_code'. - (build_compare_discrete_expr): Likewise. - - * expr.c (build_compare_set_expr): Likewise. - (build_compare_string_expr): Likewise. - (build_compare_expr): Likewise. - (build_compare_discrete_expr): Likewise. Also add default case in - switch statement. - (compare_int_csts): Add default case in switch statement. - -Sun Sep 20 11:02:55 1998 Robert Lipe <robertl@dgii.com> - - * except.c: Include system.h. - - * Makefile.in (except.o): Depend on system.h. - -Sun Sep 20 09:25:13 1998 Kaveh R. Ghazi <ghazi@caip.rutgers.edu> - - * Makefile.in (actions.o, convert.o, decl.o, expr.o, lang.o, - lex.o, loop.o, parse.o, satisfy.o, timing.o, tasking.o, tree.o, - typeck.o): Depend on system.h and toplev.h. - (except.o): Depend on toplev.h. - (grant.o): Depend on system.h, toplev.h and output.h. - - * actions.c: Include system.h and toplev.h. Remove redundant - prototypes. - (build_cause_exception): Add default case in switch. - (update_else_range_for_range): Add parentheses around && within ||. - (chill_handle_multi_case_label_list): Remove unused variable - `selector_value'. - (print_missing_cases): Reconcile format specifiers vs arguments in - calls to sprintf. - - * ch-tree.h: Don't include stdio.h. Wrap prototypes using FILE* - with macro BUFSIZ. Add missing prototypes. - - * convert.c: Include system.h and toplev.h. Remove redundant - prototypes. - (convert): Remove unused variable `errstr'. - - * decl.c: Include system.h and toplev.h. Remove redundant - prototypes. - (builtin_scope): Add missing initializers. - (clear_scope): Likewise. - (allocate_lang_decl): Mark parameter `t' with ATTRIBUTE_UNUSED. - (copy_lang_decl): Likewise for parameter `node'. - (c_decode_option): Likewise for parameter `argc'. - (push_extern_function): Likewise for parameter `granting'. - (switch_to_pass_2): Hide declaration of errorcount/sorrycount. - (pushdecl): Remove unused variable `t'. - (lookup_name_current_level): Make static and hide. - (lookup_name_for_seizing): Make static. - (finish_decl): Remove unused variable `type'. - (maybe_build_cleanup): Mark parameter `decl' with ATTRIBUTE_UNUSED. - (complete_array_type): Mark parameters `type', `initial_value' and - `do_default' with ATTRIBUTE_UNUSED. - (start_struct): Mark parameter `name' with ATTRIBUTE_UNUSED. - (start_enum): Likewise. - (shadow_record_fields): Remove unused variables `type' and `parent'. - - * except.c: Include toplev.h. Remove redundant prototypes. - - * expr.c: Include system.h and toplev.h. Don't define NULL. - Remove redundant prototypes. - (internal_build_compound_expr): Mark parameter `first_p' with - ATTRIBUTE_UNUSED. - (build_allocate_getstack): Remove unused variable `init'. - (build_chill_pred_or_succ): Likewise for variable `limit'. - (varying_to_slice): Likewise for variable `doamin' [sic]. - (finish_chill_binary_op): Likewise for variables `code0' and - `code1'. Remove unused label `finish'. Add explicit braces to - avoid ambiguous `else'. - (build_chill_addr_expr): Remove extra parameter in call to `error'. - (build_chill_unary_op): Remove unused variables `class' and `type0'. - (powersetlen): Remove unused variables `domain' and `temp'. - - * grant.c: Include system.h, toplev.h and output.h. Don't handle - strchr/strrchr. Remove redundant prototypes. - (decode_constant_selective): Remove unused variables `op' and `wrk'. - (push_granted): Mark parameters `name' and `decl' with - ATTRIBUTE_UNUSED. - - * inout.c: Include system.h and toplev.h. Remove redundant - prototypes. - (textlocation_mode): Use &&, not &, when comparing two truth - values. - (scanformcont): Remove unused label `do_the_action'. - - * lang.c: Include system.h and toplev.h. Remove redundant - prototypes. - (lookup_interface): Mark parameter `arg' with ATTRIBUTE_UNUSED. - (maybe_objc_comptypes): Likewise for parameters `lhs' and `rhs'. - (lang_print_xnode): Likewise for parameters `file', `node' and - `indent'. - (lang_decode_option): Explicitly declare `explicit_ignore_case'. - (incomplete_type_error): Mark parameters `value' and `type' with - ATTRIBUTE_UNUSED. - - * lex.c: Include system.h and toplev.h. Remove redundant - prototypes. Don't handle strchr/strrchr. Use CAPITALIZED - versions of ctype macros from system.h. Cast ctype arguments to - unsigned char when necessary. - (last_token, RETURN_TOKEN): Hide definition. - (push_back): Remove unused function. - (readstring): Change variable `i' to unsigned. - (yywrap): Remove unused variable `node'. - - * loop.c: Include system.h and toplev.h. Remove redundant - prototypes. - (chill_unsigned_type): Hide prototype and definition. - (begin_loop_scope): Remove unused variable `firstp'. - (nonvalue_begin_loop_scope): Likewise. - - * parse.c: Include system.h and toplev.h. Remove redundant - prototypes. - (quasi_signal): Hide. - (PEEK_TOKEN): Change return type to `enum terminal'. - (parse_mode_definition_statement): Remove unused variable `names'. - (parse_formpar): Remove unused parameter `in_spec_module'. All - callers changed. - (parse_formparlist): Likewise. - (parse_processpar): Remove unused variable `parms'. - (parse_definition): Add explicit braces to avoid ambiguous `else'. - (parse_multi_dimension_case_action): Initialize variable - `begin_test_label'. Remove unused variable `new_test'. - (parse_case_action): Remove unused variable `caseaction_flag'. - (parse_asm_clobbers): Remove unused variable `expr'. - (parse_delay_case_action): Initialize variable `label_cnt'. - (parse_action): Make function static. - (parse_tuple_element): Remove unused variable `list'. - (parse_primval): Add default case in switch. - (parse_variant_alternative): Remove unused variables `x' and - `variant_fields'. - - * satisfy.c: Include system.h and toplev.h. Remove redundant - prototypes. - - * tasking.c Include system.h and toplev.h. Remove redundant - prototypes. - (data_name): Hide. - (get_struct_variable_name): Likewise. - (validate_process_parameters): Mark parameter `parms' with - ATTRIBUTE_UNUSED. - (build_start_process): Initialize variable `tuple'. - (build_receive_buffer_case_end): Remove unused variable `buffer_ptr'. - - * timing.c: Include system.h and toplev.h. - (build_after_timeout_start): Remove unused variable `goto_where'. - - * tree.c: Include system.h and toplev.h. Remove redundant - prototypes. - - * typeck.c: Include system.h and toplev.h. Remove redundant - prototypes. - (extract_constant_from_buffer): Make function static. Add - explicit braces to avoid ambiguous `else'. - (expand_constant_to_buffer): Likewise. - (build_chill_slice): remove unused variable `is_static'. - (chill_compatible): Add explicit braces to avoid ambiguous `else'. - (apply_chill_array_layout): Remove unused variable `offset'. - (smash_dummy_type): Remove unused variable `save_lang_specific'. - (initializer_constant_valid_p): Add default case in switch. - -Mon Sep 14 16:46:36 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (build_chill_slice): Always use TYPE_DOMAIN to get the - domain type of the array. - - * expr.c (build_chill_function_call): Remove redundant call to - chill_convert_to_assignment - -Thu Sep 10 17:52:36 1998 Dave Brolley <brolley@cygnus.com> - - * actions.c (chill_convert_for_assignment): Make a copy of the result - node before modifying it. - -Sat Sep 5 16:55:37 1998 John Carr <jfc@mit.edu> - - * Make-lang.in: Comment ^L characters. Sun make doesn't like them. - -Sat Sep 5 23:49:50 1998 Jeffrey A Law (law@cygnus.com) - - * Makefile.in (INCLUDES): Update after recent reorganization at the - toplevel gcc directory. - -Sat Sep 5 22:25:51 1998 Richard Henderson <rth@cygnus.com> - - * Makefile.in: Update dependancies for top-level gcc files that moved. - -Sat Sep 5 02:21:08 1998 Jeffrey A Law (law@cygnus.com) - - * Makefile.in: Tweak to avoid building runtime. It's built - elsewhere now. - -Thu Sep 3 15:32:03 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (layout_chill_range_type): set TYPE_SIZE_UNIT. - -Wed Sep 02 09:25:29 1998 Nick Clifton <nickc@cygnus.com> - - * lex.c (check_newline): Change how HANDLE_PRAGMA is called. - Generate warning messages if unknown pragmas are encountered. - (pragma_getc): New function: retrieves characters from the - input stream. Defined when HANDLE_PRAGMA is defined. - (pragma_ungetc): New function: replaces characters back into the - input stream. Defined when HANDLE_PRAGMA is defined. - -Mon Aug 31 15:35:16 1998 Dave Brolley <brolley@cygnus.com> - - * decl.c (layout_chill_variants): Calculate nlables properly. - -Mon Jul 27 17:21:01 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (apply_chill_array_layout): Don't set TYPE_SIZE of the - element type. - -Mon Jul 13 14:20:12 1998 Nick Clifton <nickc@cygnus.com> - - * lang-options.h: Format changed to match changes in gcc/toplev.c - to implement a --help option. - -Wed Jul 8 02:58:35 1998 Jeffrey A Law (law@cygnus.com) - - * lang.c (lang_init_options): New function. - -Wed Jun 10 12:08:09 1998 Dave Brolley <brolley@cygnus.com> - - * lang-options.h: Remove -I. - * ch-tree.h (c_decode_option): New argc/argv interface. - * decl.c (c_decode_option): New argc/argv interface. - * lang.c (lang_decode_option): New argc/argv interface. - -Wed May 27 10:33:41 1998 Dave Brolley <brolley@cygnus.com> - - * actions.c (chill_handle_multi_case_label): Arguments 1 and 2 to - chill_handle_multi_case_label_range were reversed. - - * Make-lang.in (chill): Use the correct gcc in the driver script. - -Thu May 21 14:40:44 1998 Dave Brolley <brolley@cygnus.com> - - * convert.c (digest_array_tuple): Move conversion to - chill_convert_for_assignment. - - * actions.c (chill_convert_for_assignment): Allow conversion of array - constructor to bitstring constructor for assignment to array of packed bits. - -Thu May 14 13:57:51 1998 Dave Brolley <brolley@cygnus.com> - - * Make-lang.in (chill-runtime): Depend on stmp-headers to build float.h. - -Wed May 13 14:07:51 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (build_chill_slice): Adjust slice index to account for the - lower bound of the array. - - * actions.c (chill_expand_assignment): Convert function arguments to the - correct types. - (chill_expand_assignment): Ditto. - -Mon May 11 16:20:57 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (build_chill_slice): Propogate the TYPE_PACKED setting - of the array_type to the slice_type. - (build_chill_slice): Use SLICE_EXPR to represent a slice of an array - of bits. - - * loop.c (build_loop_iterator): Disallow location enumeration for - bit-packed arrays. - - * convert.c (digest_array_tuple): Allow conversion of an array tuple - to a bitstring for assignment to a packed array of bits. - -Mon May 4 16:28:58 1998 Dave Brolley <brolley@cygnus.com> - - * ch-tree.def (PACKED_ARRAY_REF): New tree code. - * typeck.c (build_chill_array_ref_1): Build PACKED_ARRAY_REF if array is packed. - (chill_location): Handle PACKED_ARRAY_REF. - (apply_chill_array_layout): Allow PACK for arrays of single bits. - * expr.c (chill_expand_expr): Expand PACKED_ARRAY_REF. - (invalid_operand): Check PACKED_ARRAY_REF operands. - * actions.c (chill_expand_assignment): Expand PACKED_ARRAY_REF. - -Thu Apr 23 15:33:20 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (apply_chill_field_layout): Only integral fields can be packed - to the bit level. - -Tue Apr 21 14:30:10 1998 Jeffrey A Law (law@cygnus.com) - - * decl.c (intTI_type_node, unsigned_intTI_type_node): Define. - (init_decl_processing): Handle TI types. - * typeck.c (intTI_type_node, unsigned_intTI_type_node): Declare. - (type_for_size): Handle TI types. - (type_for_mode): Handle TI types. - -Mon Apr 20 13:12:26 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (layout_chill_struct_type): Don't promote bitfield types to - int. - - * actions.c (chill_convert_for_assignment): Check that the rhs is not - a type declaration. - -Tue Apr 14 13:17:44 1998 Dave Brolley <brolley@cygnus.com> - - * lex.c (init_parse): Now returns char* containing the filename. - - * typeck.c (get_type_precision): Declare. - (apply_chill_field_layout): Use the minimum number of bits necessary to - represent discrete types as the natural length of the field. - -Thu Apr 9 12:46:55 1998 Dave Brolley <brolley@cygnus.com> - - * lex.c (finput): Move definition here from toplev.c - (init_parse): New function replaces init_lex. - (init_parse): Add code to open source file. - (finish_parse): New function. - (close_input_file): File was being closed more than once. - - * lang.c (finput): Declare. - * ch-tree.h (init_lex): Remove. - - -Wed Apr 8 14:47:33 1998 Dave Brolley <brolley@cygnus.com> - - * actions.c (compute_else_range): Fix loop index error. - (chill_handle_multi_case_label_range): Move error checking to - chill_handle_multi_case_label. - (chill_handle_multi_case_else_label): Convert ELSE range values to - the type of the corrersponding CASE selector. - -Wed Apr 8 13:02:50 1998 Jeffrey A Law (law@cygnus.com) - - * actions.c (sizetype_tab): Do not declare. - * lang.c (lang_print_xnode): New function. - -Mon Mar 23 14:43:06 1998 Dave Brolley <brolley@cygnus.com> - - * grant.c (decode_layout): New function. - (grant_array_type): Call decode_layout to export layout information to - the grant file. - (decode_decl): Ditto - -Fri Mar 20 16:06:41 1998 Dave Brolley <brolley@cygnus.com> - - * parse.c (parse_tuple_element): Call had arguments in wrong order. - -Thu Mar 19 13:42:33 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (apply_chill_array_layout): Use - TYPE_PRECISION (chill_integer_type_node) in stead of BITS_PER_WORD for - the word size. - -Wed Mar 18 16:25:48 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (apply_chill_field_layout): Only set DECL_BIT_FIELD for discrete - fields. - - * parse.c (parse_multi_dimension_case_action): Call emit_line_note at the - proper places. - -Tue Mar 17 14:16:08 1998 Dave Brolley <brolley@cygnus.com> - - * parse.c (gen_label_rtx): Declare before use. - (emit_jump): Declare before use. - (emit_label): Declare before use. - (parse_case_label_list): Pass in CASE selector so we can mark it as having - an (ELSE) label if necessary. - (parse_case_label_specification): Pass in the CASE selector list so that - the CASE selectors can be passed to parse_case_label_list. - (parse_multi_dimension_case_action): Modify to generate branching code in - one pass. - (parse_case_expression): Compute (ELSE) range before generating CASE expression. - (parse_variant_alternative): Remove error for (ELSE) specified. - - * expr.c (check_case_selector_list): Preserve TREE_PURPOSE of selector list. - - * decl.c (layout_chill_variants): Add code to check compatibility of ranges - and discrete mode names. - - * ch-tree.h (ELSE_LABEL_SPECIFIED): New Chill specific flag. - - * actions.h (build_multi_case_selector_expression): Make it extern. - (chill_handle_multi_dimension_case_label): Remove. - (compute_else_ranges): New function. - - * actions.c (update_else_range_for_int_const): New function. - (update_else_range_for_range): New function. - (update_else_range_for_range_expr): New function. - (update_else_range_for_type): New function. - (compute_else_range): New function. - (compute_else_ranges): New function. - (chill_handle_multi_case_else_label): New function - (chill_handle_multi_case_label_range): Don't generate tests for conditions - which are always true or false. - (chill_handle_multi_case_label): Ditto. - (chill_handle_multi_case_label): Implement (ELSE) label support. - (chill_handle_multi_case_label): First argument is now the selector tree not - its VALUE. - (chill_handle_multi_dimension_case_label): Removed. - (build_chill_multi_dimension_case_expr): List of CASE alternatives is no longer - reversed on entry, so reverse it here. - -Tue Mar 10 15:02:26 1998 Dave Brolley <brolley@cygnus.com> - - * actions.c (chill_handle_multi_case_label_range): Add more error checking. - (chill_handle_multi_case_label): Implement (*) for multi dimensional CASE. - (chill_handle_multi_case_label): Improve Error handling. - -Mon Mar 9 12:39:00 1998 Dave Brolley <brolley@cygnus.com> - - * actions.c (chill_handle_multi_case_label_range): Added. - (chill_handle_multi_case_label): Add support for discrete ranges and - discrete modes. - - * typeck.c (apply_chill_array_layout): Added more error checking. - (apply_chill_field_layout): Added more error checking. - -Wed Mar 4 16:08:26 1998 Dave Brolley <brolley@cygnus.com> - - * convert.c (convert): Call build_simple_array_type with new argument. - - * ch-tree.h(build_simple_array_type): Add argument for array layout. - - * typeck.c (build_chill_slice): Call build_simple_array_type with new argument. - (build_simple_array_type): Attach array layout to TYPE_ATTRIBUTES. - (apply_chill_array_layout): New function to implement array layout. - (layout_chill_array_type): Call apply_chill_array_layout and reset - TYPE_ATTRIBUTES to NULL_TREE. - (build_chill_array_type): Extend to handle one array layout per index mode. - (smash_dummy_type): Call build_simple_array_type with new argument. - - * satisfy.c (satisfy): Call SATISFY on array layout tree. - -Wed Feb 25 14:36:41 1998 Dave Brolley <brolley@cygnus.com> - - * typeck.c (next_struct_offset): Added. - (apply_chill_field_layout): New function to check and apply PACK, NOPACK, - or POS layout to a structure field. - (layout_chill_struct_type): Add call to apply_chill_field_layout. - - * satisfy.c (satisfy): Call satisfy recursively to handle the expressions - in the field layout tree. - - * parse.c (pack_warn_printed): Remove. - (nopack_warn_printed): Remove. - (step_warn_printed): Remove. - (pos_warn_printed): Remove. - (parse_opt_layout): Remove warnings about POS, STEP, PACK and NOPACK usage. - - * decl.c (grok_chill_fixedfields): Check for POS specified for a list of - field declarations. - -Thu Feb 19 17:33:06 1998 Dave Brolley <brolley@cygnus.com> - - * parse.c (parse_opt_layout): Generate syntax errors in pass 1 only. - (parse_opt_mode): Removed incorrect comment about association of array - layouts with nested array elements. - (parse_opt_mode): Allow for one layout per index mode specified. - -Wed Feb 18 23:48:57 1998 Richard Henderson <rth@cygnus.com> - - * Make-lang.in (cc1chill): Kill lingering bc-opcode.h dependancy. - -Wed Feb 18 17:35:05 1998 Dave Brolley <brolley@cygnus.com> - - * parse.c (parse_field): Get rid of warning for multiple case selectors. - - * decl.c (layout_chill_variants): Fix loop indexing error. - -Mon Feb 16 15:54:47 1998 Dave Brolley <brolley@cygnus.com> - - * parse.c (parse_case_expression): Remove code which checked for - unimplemented (ELSE) label. - (parse_case_expression): Add code to handle multi dimensional case - expression. - - * expr.c (check_case_selector_list): Fixed to return a list of the - selectors which were checked. - (chill_expand_case_expr): Remove "sorry" message for multi dimension - case. - (chill_expand_case_expr): Reverse order of case alternatives. - (chill_expand_case_expr): Add "error" message for multiple case - selectors. - - * actions.h (build_chill_multi_dimension_case_expr): Added. - - * actions.c (build_multi_case_selector_expression): Renamed from - build_multi_case_expression. - (chill_handle_multi_dimension_case_label): Call above function by its - new name. - (build_chill_case_expr): Don't reverse the list elements here. It may - not be necessary. - (build_chill_multi_dimension_case_expr): New function implements multi - dimensional case expression. - -Thu Feb 12 15:44:50 1998 Dave Brolley <brolley@cygnus.com> - - * parse.c (parse_case_action): Implement multi-dimension CASE action. - (parse_multi_dimension_case_action): Added. - (parse_single_dimension_case_action): Added based on code moved from - parse_case_action. - - * expr.c (check_case_selector_list): Added. - - * ch-tree.h (check_case_selector_list): Added. - - * actions.h (chill_handle_single_dimension_case_label): Added. - (chill_handle_multi_dimension_case_label): Added. - - * actions.c (chill_handle_single_dimension_case_label): Added. - (chill_handle_multi_case_label): Added. - (chill_handle_multi_case_label_list): Added. - (build_multi_case_expression): Added. - (chill_handle_multi_dimension_case_label): Added - -Fri Feb 6 16:43:41 1998 Dave Brolley <brolley@cygnus.com> - - * actions.c (sizetype_tab): Fix declaration to match gcc changes. - -Thu Feb 5 14:03:00 1998 Dave Brolley <brolley@cygnus.com> - - * decl.c (chill_tree_code_type): Change this to be an array of char like - the tree_code_type in the rest of gcc. - - * ch-tree.def (chill_tree_code_type): See decl.c. - -Thu Jan 29 15:34:18 1998 Dave Brolley <brolley@cygnus.com> - - * tasking.c (error_with_decl): Correct prototype. - (build_gen_ptype): Reverse arguments. - - * lang.c (chill_real_input_filename): Add definition. - (chill_print_error_function): Correct second argument. - (lang_init): Set chill_real_input_filename. - - * expr.c (NULL): Protect definition with #ifndef. - - * decl.c (init_decl_processing): Don't allocate chill_tree_code_... - (init_decl_processing): Change last argument to 'sizeof(char)'. - - -Tue Nov 25 10:44:19 1997 Nick Clifton <nickc@cygnus.com> - - * Make-lang.in (mostlyclean): Use && to separate commands, so that - if the directory change fails, the rule will not loop. - -Mon Mar 3 12:08:19 1997 Fred Fish <fnf@cygnus.com> - - * Make-lang.in (CHILL_FLAGS_TO_PASS): Remove extraneous leading - spaces and use single tab character on some lines. - (cc1chill): Ditto. - -Tue Nov 26 05:12:40 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * tasking.c (build_receive_buffer_case_label): Rework in a manner, - that the buffer location gets evaluated only once, in - build_receive_buffer_case_end. - - * typeck.c (build_chill_bin_type): Rework. - (layout_chill_range_type): Process BIN mode. - (build_chill_array_type): Remove checking of layout. This is done - at the parse. - - * parse.c (parse_on_exception_list): Don't allow ON name:. - (parse_opt_layout): Parse POS and STEP and return a tree instead - of int. - - * lex.c (init_lex), lex.h: Define and initialise RID_BIN. - - * grant.c (print_integer_type): Take care of BIN. - - * expr.c (build_chill_descr): Make descr static if requested - location is static. - (build_chill_length): Process text mode name and text location as - described in Z.200/1992. - (build_compare_expr): Don't allow < <= > >= for composite modes. - - * decl.c (grok_chill_fixedfields): Remove checking of - layout. This is done at the parser. - - * convert.c (digest_structure_tuple): Take care of wrong (probably - array) tuple. Printing error may cause sigsegv. - - * ch-tree.h: Change prototypes of grok_chill_fixedfields and - build_chill_array_type (layout is passed now as a tree instead of - int). - -Fri Nov 15 15:17:44 1996 Per Bothner <bothner@deneb.cygnus.com> - - * convert.c (display_int_cst): Check that val is INTEGER_CST. - (digest_array_tuple): Some extra error checks (i.e. that indexes - are constant). If dynamic mode, result is not constant. - -Mon Oct 28 12:48:06 1996 Jeffrey A Law (law@cygnus.com) - - * typeck.c (signed_or_unsigned_type): If the given type already - as the correct signedness, then just return it. - - * typeck.c ({un,}signed_type): If can't do anything, call - signed_or_unsigned_type. - -Fri Sep 6 02:50:08 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * typeck.c (build_chill_cast): In case of rangecheck, take care of - constant expression (when defining a SYN). - -Thu Sep 5 04:30:32 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (define__PROCNAME__): New function to define a SYNONYM - __PROCNAME__ (__procname__) which is a character string containing - the name of the current procedure. This is quit the same as - __FUNCTION__ in C. - (parse_proc_body): Add call to define__PROCNAME__. - - * typeck.c (chill_equivalent): Take care of NEWMODE'd procedure - modes on one side and procedures on the other side.. - -Wed Jul 24 01:13:51 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * typeck.c: Replace all local variables and arguments named `index' - with `idx', `index' gets replaced by `strchr' which makes debugging - somehow difficult. - (valid_array_index_p): New argument to indicate that we are processing - LENGTH (varying string) on the lefthand side of an assignment. The - index check is different in this case. - (build_chill_cast): In case of expression conversion do an OVERFLOW - check with the limits of the target mode. - - * ch-tree.h: New prototype for valid_array_index_p. - - * actions.c (expand_varying_length_assignment): Add new argument to - call to valid_array_index_p to indicate we are processing - LENGTH on the lefthand side of an assignment. - - * loop.c: Rename loop_stack to loopstack to avoid clashes with - global variable ../stmt.c:loop_stack. - -Tue Jun 18 23:04:06 1996 Per Bothner <bothner@deneb.cygnus.com> - - * expr.c (resolve_component_ref): Set TREE_SIDE_EFFECTS properly. - -Mon Jun 10 15:01:51 1996 Per Bothner <bothner@deneb.cygnus.com> - - * typeck.c (build_chill_reference_type): Copy novelty for reference. - * satisfy.c (satisfy): If REFERENCE_TYPE, copy novelty. - -Thu May 30 04:55:27 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * typeck.c (valid_array_index_p): For varying character strings - we must check if the index is less then the actual length instead - of less equal. - -Wed May 15 06:07:10 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * ch-tree.h: Add prototype for test_range. - - * inout.c (process_io_list): Fix duplicate function call if - writetext argument is a function returning a varying string. - -Tue May 14 21:08:47 1996 Per Bothner <bothner@deneb.cygnus.com> - - Re-do string comparisons. Old way could re-use temporary - (SAVE_EXPR created for an argumnet is variable) prematurely. - * ch-tree.def (STRING_EQ_EXPR, STRING_LT_EXPR): New codes. - * decl.c (init_decl_processing): Remove __eqstring, __gestring, - __gtstring, __lestring, __ltstring, __nestring declarations. - * expr.c (build_char_array_expr): Rename to build_compare_string_expr. - Create STRING_EQ_EXPR, STRING_LT_EXPR nodes, instead of CALL_EXPRs. - (chill_expand_expr): Implement STRING_EQ_EXPR, STRING_LT_EXPR. - (build_compare_expr): Use new build_char_array_expr name. - -Mon Apr 8 14:08:30 1996 Per Bothner <bothner@kalessin.cygnus.com> - - Cleanup of April 5 fix: - * actions.c (test_range): New function. - (check_range): Simplify to use test_range. - * convert.c (digest_powerset_tuple): Move error message from here ... - (check_ps_range): ... to here. Also, simplify to use test_range. - -Fri Apr 5 03:41:05 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * convert.c (check_ps_range): New function to perform range check - of powerset tuple elements. This is quite the same as check_range, - however, the actions on rangefail are different. - (digest_powerset_tuple): Call check_ps_range. - - * loop.c (build_loop_iterator): Chaeck if location enumeration - is requested for BOOLS(n) and print an error message. - -Wed Mar 6 17:46:48 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_primval): Emit error if !ignore (before: pass==2). - - Implement parameterised array and string modes (using LANG_TYPE). - * parse.c (parse_opt_mode): Handle parameterized arrays and strings. - * grant.c (decode_mode): Support extended use of LANG_TYPE. - * satisfy.c (cycle_error_print): Ignore non-decls in chain. - (safe_satisfy_decl): No error if non-decl (pointer type) in cycle. - (satisfy): Return immediately if laid out non-pointer type. - (satisfy case LANG_TYPE): Handle paramertised mode. - (satisfy case POINTER_TYPE/REFERENCE_TYPE): Push type on chain; - return immediately if already in chain. - * typeck.c (smash_dummy_type): Handle parameterized modes and CHAR(N). - Change return type (can now return error_mark_node). - (build_readonly_type): Return return value from smash_dummy_type. - * ch-tree.h: Change smash_dummy_type return type. - -Tue Mar 5 22:31:20 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (build_chill_slice): Re-do index_type calculation. - * typeck.c (layout_chill_range_type): Use compare_int_csts rather - than tree_int_cst_lt to avoid signed/unsigned problems. - - * typeck.c (copy_novelty): Use copy_node rather than build_type_node. - * typeck.c (smash_dummy_type): Use copy_novelty for NEWMODE of range. - - * decl.c (init_decl_processing): More portable sizetype initialization. - - * tree.c (build_string_type): Generalize to also create bitstrings. - Return error_mark_node if an argument is an ERROR_MARK. - (build_bitstring_type): Simplify - just call build_string_type. - -Tue Mar 5 03:48:32 1996 Wilfried Moser <moser@blues.cygnus.com> - - * actions.c (warn_unhandled): Add missing assignment. - - * loop.c (build_loop_iterator): In case of IN, check if - expression has a mode, otherwise make an error. - -Mon Mar 4 23:12:03 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * convert.c (digest_powerset_tuple): Check tuple elements - for compatibility; if compatible, call convert. - -Thu Feb 29 23:39:54 1996 Per Bothner <bothner@kalessin.cygnus.com> - - Simplify NOVELTY representation. - * ch-tree.h (CH_NOVELTY): Re-implement as plain TYPE_CONTEXT. - (CH_NOVELTY_FLAG): Removed. (Just use CH_NOVELTY.) - * decl.c (push_modedef): Make copy even for SYNMODE. - but not for internal typedefs (indicated by make_newmode==-1). - * tasking.c: Call push_modedef with make_newmode==-1. - * typeck.c (chill_novelty): Remove. - (smash_dummy_type): Removed unused event/buffer stuff. Update. - * grant.c (decode_decl), inout.c (build_io_types), - expr.c (build_concat_expr), typeck.c (build_chill_slice, copy_novelty), - tasking.c (build_instance_type): Simplify using new CH_NOVELTY. - - Solidify READ mode handling. - * decl.c (do_decl, push_syndecl, start_chill_function): - Possibly set TREE_READONLY for a VAR_DECL, CONST_DECL, or PARM_DECL. - * typeck.c (build_chill_slice): Set TREE_READONLY appropriately. - (build_chill_array_ref_1, build_chill_bitref): Likewise. - (build_chill_cast): Set TREE_READONLY depending on result type (only). - * convert (convert_from_reference, convert): Likewise. - * expr.c (resolve_component_ref): Set TREE_READONLY appropriately. - (build_chill_function_call): Error if OUT/INOUT arg is TREE_READONLY. - * actions.c (chill_expand_assignment): Also error if TREE_READONLY. - Use convert_from_reference. - -Thu Feb 29 11:14:09 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_do_action): DO WITH expressions are evaluated in - outer scope. Also call save_if_needed. - * decl.c (shadow_record_fields); Fix and simplify. - -Tue Feb 27 22:19:40 1996 Per Bothner <bothner@cygnus.com> - - * convert.c (display_int_cst): Gereralize to wider range of ints. - -Thu Feb 22 06:12:59 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * convert.c (digest_array_tuple): Take care of type == error_mark_node. - - * decl.c (do_decl): In case of chill_varying_type_p, check if - type of fixed part is error mark and do nothing in this case. - - * lex.c (convert_bitstring): Don't complain when length of - bitstring is 0 (BOOLS(0) is a valid mode). - - * tree.c (layout_powerset_type): Add check for TYPE_MAX/MIN_VALUE - (domain) is error mark. - - * typeck.c (layout_chill_range_type): If lowvalue or highvalue == - error_mark_node, just return. - -Tue Feb 20 00:01:10 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_variant_alternative): When checking for ELSE take - care of tagless variants. - -Mon Feb 19 05:54:45 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_case_action): Check if ELSE was specified - in a case label list (this is only valid for array tuples). - (parse_case_expression): Deto. - (parse_variant_alternative): Deto. - -Tue Feb 13 17:08:16 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (chill_location): Cleanup. Neither SLICE_EXPR nor - BIT_FIELD_REF are referable, even if their base strings are. - -Fri Feb 9 02:25:33 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (chill_expand_result): Do CH_FUNCTION_SETS_RESULT after - checking the expression. - - * convert.c (convert): Set TREE_CONSTANT when taking the - address of a function. - - * decl.c (start_chill_function): Check if the mode is really - a mode to avoid subsequent segfaults. - - * typeck.c (string_assignment_condition): Add checking of - bitstring length. - -Thu Feb 8 01:37:59 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (build_cause_exception): Print warning of unhandled - exception only once for each exception. - -Mon Feb 5 22:17:13 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * tree.c (discrete_count), ch-tree.h: New function. - * expr.c (build_concate_expr, build_chill_repetition_op, - chill_expand_expr): Use discrete_count; make sure arguments - to size_binop are sizetype. - (powersetlen): Trvialize using discrete_count. - - * inout.c (process_io_list): Use new assign_temp function. - * inout.c (build_enum_tables): Avoid taking address of array_ref, - which sometimes gets optimized to a constant. - - * expr.c (finish_chill_unary_op): Call convert_to_class on argument. - Remove some obsolete TREE_UNSIGNED stuff. - * lex.c (convert_integer): Removed more TREE_UNSIGNED stuff. - -Thu Feb 1 15:11:20 1996 Doug Evans <dje@charmed.cygnus.com> - - * lex.c (check_newline): Return result of HANDLE_PRAGMA. - -Wed Jan 31 17:13:25 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (char_array_type_node, wchar_array_type_node): Removed. - (init_decl_processing): Remove array_domain_type; don't set - char_array_type_node or wchar_array_type_node. - * decl.c (init_decl_processing): Use fixup_unsigned_type to - simplify code to create boolean_type_node and char_type_node. - -Mon Jan 29 14:20:10 1996 Doug Evans <dje@charmed.cygnus.com> - - * lex.c (check_newline): Pass character after `#pragma' to - HANDLE_PRAGMA. Don't call get_directive_line if at end of line. - -Fri Jan 26 05:56:27 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (build_chill_function_call): Add check and error for - actual argument is a TYPE_DECL. - - * parse.c (parse_set_mode): Print a warning if the set mode contains - numbered and unnumbered set elements. - -Wed Jan 24 05:10:08 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * Make-lang.in: Change GNUCHILL_VERSION to 1.5.2. - - * decl.c (layout_enum): Add check for negative values if - enum is numbered and duplicate values in an enum. - -Mon Jan 15 06:21:52 1996 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (chill_expand_assignment): Add check for lefthand side - of an assignment is a location. - - * ch-tree.def: Name of SET_IN_EXPR is really "set_in_expr" and - not "concat_expr". - - * expr.c (is_really_instance): New function to check if a datum - is really an instance. CH_IS_INSTANCE_MODE seems to be to weak - for this case. - (build_chill_component_ref): call is_really_instance. - -Wed Jan 10 13:47:14 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * ch-tree.h (TYPE_ARRAY_MAX_SIZE): Removed; now in ../tree.h. - -Mon Jan 8 15:29:20 1996 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_char_array_expr): Add save_if_needed's if varying. - Also, remove unused len0 and len1. - -Mon Dec 11 17:36:44 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * inout.c (build_chill_associate, assoc_call, build_chill_readrecord, - build_chill_getassociation, build_chill_getusage, - build_chill_gettextrecord, build_chill_gettextaccess: Simplify - - modify TREE_TYPE of CALL_EXPR, instead of building a CONVERT_EXPR. - - * parse.c (parse_action): Minor simplification. - -Thu Dec 7 00:02:47 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_action): In case of CALL, do a check if there - is really a function call. - -Tue Dec 5 05:06:02 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * convert.c (display_int_cst): Fix printing of control sequence. - -Thu Nov 30 21:07:57 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * grant.c (decode_constant, decode_constant_selective): Make work - for REAL_IS_NOT_DOUBLE case. - - * decl.c (CHILL_INT_IS_SHORT): New macro. - (init_decl_processing): Use CHILL_INT_IS_SHORT. - Change name of integer_type_node from _cint to long. - -Mon Nov 27 17:07:05 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (top_loop_end_check): Check while condition *after* - getting next powerset element. - -Mon Nov 27 05:29:52 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_receive_case_action): Fix typo in error message. - - * convert.c (display_int_cst): Format characters like strings in - grant.c(decode_constant). - - * grant.c: Remove the old forbid stuff. - - * lex.c (readstring): Fix reading of '^^'. - - * parse.c (parse_procedure_mode): nreverse param_types. - -Thu Nov 23 05:39:57 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (chill_expand_assignment): Check for assigning to - location with non-value mode. - - * ch-tree.h: New macro CH_TYPE_NONVALUE_P. - Add new and change some prototypes. - - * decl.c (init_nonvalue_struct): New function to generate - initialisation code for non-value structs. - (init_nonvalue_array): New function to generate initialisation - code for non-value array's. - (do_decl): Call one of the above mentioned functions in case - we have a mode with the non-value property. - (start_chill_function): Print error message if a non-value mode - gets returned without LOC and check for arguments of non-value - modes only gets passed by LOC. - - * grant.c (print_proc_tail): Fix for procedure returning LOC. - - * inout.c (build_io_types): Set CH_TYPE__NONVALUE_P on - association_type_node. - (invalidate_access_recordmode): New function to set the - record mode of an ACCESS to error_mark_node in case of - record mode has the non-value property. - (build_text_mode): Set CH_TYPE_NONNVALUE_P. - (build_access_mode, build_chill_gettextaccess): Deto. - (check_exprlist): Correct processing of repetition factor. - - * lex.c (readstring): Correct processing of control - sequences of the form '^([H | D | O | B]'xx)'. - - * loop.c: Cleanup iterator handling (done by Per). - (nonvalue_begin_loop_scope, nonvalue_end_loop_scope): New - functions for starting and ending a loop scope in case - of initialising an array with non-value property. - - * parse.c (check_end_label): Remove '\n' from error message. - (parse_loc_declaration): Print error in case of loc-identity - declaration without initialisation or with keyword INIT. - (parse_do_action): Clean up iterator handling (done by Per). - - * satisfy.c (safe_satisfy_decl (case TYPE_DECL)): Print an error - message in case of TYPE_DECL is a signal and the mode has the - non-value property. - (satisfy (case ARRAY_TYPE)): Set CH_TYPE_NONVALUE_P of the - the array type if the array element mode has the non-value - property. - (satisfy case RECORD_TYPE)): Set CH_NONVALUE_P on the record - type if one of the fields have the non-value property. If the - record is a buffer mode and the element mode of the buffer has - the non-value-p., invalidate it (see - tasking.c (invalidate_buffer_element_mode). Same for access modes. - - * tasking.c (build_signal_descriptor): If the signal type have - the non-value property, do nothing. - (build_receive_signal_case_label): Don't do an assignment if the - signal type have the non-value property. - (build_receive_buffer_case_label): Add check for buffer element - mode is ERROR_MARK. - (expand_send_buffer): Deto. - (build_buffer_type): Set CH_TYPE_NONVALUE_P on buffer mode. - (invalidate_buffer_element_mode): New function to set type of - buffer element mode to error_mark_node. - (build_event_type): Set CH_TYPE_NONVALUE_P on event mode. - -Wed Nov 15 13:26:20 1995 Jeffrey A Law (law@cygnus.com) - - * inout.c (intsize_of_charsexpr): Move declaration to top - of file to avoid error from solaris2.5 cc. - -Thu Nov 9 02:50:40 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * satisfy.c (satisfy): For a RECORD_TYPE, which is an ACCESS or TEXT - mode, temporarily reset maximum_field_alignment to 0 before - layouting it to be compatible with the runtime library. - - * inout.c (build_chill_gettextaccess): Deto. - -Mon Nov 6 04:12:06 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * decl.c (do_decl): If type is READonly, add check if an - ASSOCIATION, ACCESS, TEXT, BUFFER, or EVENT will be declared - and print an error if this is true. Variables of this modes - may not be declared READonly. - Add check for mode is one of the above and an init value was - given. This is also not allowed. - Add initialisation of variables of the above modes during - runtime. This influence the mechanism for detecting to - build a constructor. - (push_modedef): NEW- or SYNMODES of ASSOCIATION, ACCESS, TEXT, - BUFFER, and EVENT mode must not be READonly. - (start_chill_function): Arguments of modes ASSOCIATION, ACCESS, - TEXT, BUFFER, or EVENT may be passed only by LOC. Add this check. - (declare_predefined_file): Move to inout.c. - (init_decl_processing): Add definitions for new built-in's. - (finish_outer_function): Build a constructor only if - build_constructor is set. - - * except.c: On Linux native, setjmp is __setjmp. - - * expr.c (build_chill_component_ref): New function. It gets called - from parse.c instead of build_component_ref. Functions checks if the - user tries to access a field of an ACCESS, ASSOCIATION, BUFFER, - EVENT, INSTANCE, or TEXT mode, which actually is not allowed. - (build_chill_floatcall): New function to resolve CHILL's floating - point builtin calls (SIN, COS, TAN, etc.). - (build_allocate_getstack, build_chill_allocate, build_chill_getstack, - build_chill_terminate): New functions to resolve CHILL's ALLOCATE, - GETSTACK, and TERMINATE built-in's. - (build_generalized_call): Process new built-in's. - - * grant.c (decode_mode): Add processing of ACCESS and TEXT modes. - (decode_mode_selective): deto. - - * inout.c: Completely rewritten for implementing Chapter 7 of - Z.200 (input and output). - - * lex.c (yylex): An '_' after a '.' doesn't mean, that we are - parsing numbers. - - * lex.h (enum rid): Add RID_ASSOCIATION. - - * parse.c: New flag build_constructor to indicate if a constructor - should be generated at the end of compilation or not. See - decl.c(do_decl). - (parse_begin_end_block): Don't emit a line note. - (parse_primval): Call build_chill_component_ref instead of - build_component_ref. - (parse_opt_mode): Process ACCESS modes, ASSOCIATION modes, TEXT - modes, USAGE modes, WHERE modes. - - * satisfy.c (safe_satisfy_decl): Check if a SYN is of mode ASSOCIATION, - ACCESS, TEXT, BUFFER, or EVENT and print an error in this case. - (satisfy (case RECORD_TYPE)): If exp is TEXT mode, check the text length. - - * typeck.c (extract_constant_from_buffer): Fix thinko in case - of ! BYTES_BIG_ENDIAN. - (build_chill_cast): Implement representation conversion between - INT's and REAL's. - (chill_similar): Add check of ACCESSes. - (layout_chill_range_type): Check for real ranges and print - sorry message. - - * Make-lang.in: Change compiler version. - chill also depends on Makefile. - - * chill.in: Process command line option -Xlinker like -Tdata. - - * ch-tree.h: New macros CH_IS_ASSOCIATION_MODE, CH_IS_ACCESS_MODE, - CH_IS_USAGE_MODE, CH_IS_WHERE_MODE, and CH_IS_TEXT_MODE. - Add some prototypes. - (enum chill_built_in_function): Add BUILT_IN_ARCCOS, BUILT_IN_ARCSIN, - BUILT_IN_CH_DELETE, BUILT_IN_LOG, BUILT_IN_SQRT. - Remove BUILT_IN_READLEN, BUILT_IN_ROUND, BUILT_IN_SKIPRECORD. - - * gperf, hash.h: Remove definition of WHERE. - -Thu Oct 5 06:22:19 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * grant.c (decode_constant_selective): Add some newlines - to generated SPEC MODULE. - -Wed Oct 4 18:16:44 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (pop_chill_function_context): Remove some bogosity. - -Wed Oct 4 05:14:00 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * grant.c (print_integer_selective): In case of a RANGE of - a SET mode, try to find and grant the parent mode. - (grant_seized_identifier): Dont write it out, if the identifier - doesn't have a seize file (it may come from a SPEC MODULE - defined in the compilation unit). - -Fri Sep 22 14:04:40 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (check_non_null): Wrap expr in SAVE_EXPR if needed. - -Wed Sep 20 13:51:54 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (force_addr_of): Optimize an INDIRECT_REF using - convert_to_pointer rather than convert (which in case of - a REFERENCE_TYPE would losingly call convert_from_reference). - -Wed Sep 20 04:03:58 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * inout.c (build_chill_writetext): In case of character string: - Add processing of a concatenation including varying character - strings. - (intsize_of_charsexpr, get_max_size): New functions to determine - the maximum size of varying character strings. - - * grant.c (decode_constant, decode_constant_selective): Add - processing of COMPONENT_REF. - - * satisfy.c (satisfy (case COMPONENT_REF)): Correct handling - for SYNONYM's with STRUCT mode. - -Mon Sep 18 17:25:11 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (force_addr_of): Optimize of value is INDIRECT_REF. - * typeck.c (build_chill_slice): Call mark_addressable. - -Mon Sep 18 14:38:15 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (chill_expand_expr): Make a copy before calling __psslice - if the array is neither referable nor BLKmode. - (build_set_expr): Renamed to ... - (build_compare_set_expr): Allow one opperand to be boolean. - (build_compare_expr): Check both operands for SET_EXPR, - before checking for discrete types (for -fold-strings). - -Fri Sep 15 11:35:43 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * satisfy.c (safe_satisfy_decl): For a CONST_DECL, set TREE_TYPE - to error_mark_node or error. - -Fri Sep 15 00:26:02 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * grant.c (decode_constant_selective): Add processing of - TREE_OPERAND (val, 0). - -Wed Sep 13 14:24:12 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * ch-tree.h (CH_IS_INSTANCE_MODE): Redefine to use CH_SIMILAR. - * convert.c (convert): Use CH_IS_INSTANCE_MODE. - * inout.c (build_chill_writetext): Likewise. - * tasking.c (build_receive_case_start, build_delay_case_start): Ditto. - * parse.c (parse_start_action): Remove redundant tests. - * tasking.c (build_start_process): Also test that optset is instance. - (build_copy_number, build_proc_type, expand_send_signal): Use - CH_IS_INSTANCE_MODE, not CH_COMPATIBLE. - * actions.c, convert.c (instance_type_node): Remove redundant - extern declaration. - -Wed Sep 13 14:19:37 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * regression.awk2: Use \ line-continuation-markers - to remove gratuitous gawk dependency. - -Mon Sep 11 17:26:53 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (build_chill_modify_expr): Use force_addr_of. - (mark_addressable): Handle INDIRECT_REF of ADDR_EXPR. - - * typeck.c (check_case_value), ch-tree.h: Moved to ... - * actions.c (check_case_value): ... here. Also check for - compatibility with selector (which is passed as extra argument). - (chill_handle_case_label_range): Take selector argument, - and use it to call check_case_value. - (chill_handle_case_label): Take extra selector argument. - * ch-tree.h (chill_handle_case_labe): Add prototype. - * except.c expr.c, parse.c: Remove chill_handle_case_label prototypes. - * actions.c, except.c, expr.c, parse.c: Pass extra selector - argument to function calls as needed. - -Mon Aug 28 02:47:54 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * grant.c (decode_constant_selective): Fix a bug in writing items - to grant file. - -Thu Aug 24 04:52:28 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_case_expression): Print warning only in - pass 1. - - * actions.c (print_missing_cases): Correct printing of - character ranges. - -Wed Aug 23 15:26:12 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_case_label_list): Take extra parameter to - indicate if we're parsing a tuple or a case-label-spec. - If former, don't allow '(' EXPR ')' ',' but backup instead. - (parse_case_label_specification, parse_tuple_element): - Pass appropriate new argument to parse_case_label_list. - -Wed Aug 23 06:08:28 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * inout.c (build_chill_readtext): Add processing of BOOL's and - CHARS(n). - - * grant.c (decode_constant): Process nonprintable characters - in a STRING_CST. - -Fri Aug 11 15:26:13 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * except.c (initialize_exceptions): Name setjmp "setjmp" and not - "__builtin_setjmp" (which is not recognized by expand_call). - -Wed Aug 9 23:35:36 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (end_loop_scope): Need to call kept_level_p, - in argument to poplevel. - -Wed Aug 9 05:48:30 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * Make-lang.in (CHILL.install-common): Don't install chill-cross (this - file might be empty). Install chill.install instead. - -Tue Aug 8 21:46:30 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (end_loop_scope): Do poplevel *after* expand_end_bindings. - -Tue Aug 8 00:51:09 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * tasking.c (build_process_header): Also set DECL_ASSEMBLER_NAME - of PARAM_DECL, since otherwise dbxout_symbol_name may barf. - - * decl.c (start_chill_function): Likewise ... - -Mon Aug 7 18:35:35 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * tasking.c (build_process_wrapper): Also set DECL_ASSEMBLER_NAME - of PARM_DECL, since otherwise dbxout_symbol_name may barf. - -Mon Jul 31 14:32:33 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c: Re-written implementation of powerset iteration. - (declare_temps): iter_var is now integer index into bitstring, - and powerset_temp just uses save_expr (normally needs no temp). - (top_loop_end_check): Pass index to start searching (from iter_var) - to library function, instead of dependning on latter to clear old bits. - (increment_temps): UNless DOWN, increment iter_var. - * decl.c (init_decl_processing): Declare new types for - __ffsetclrpowerset and __flsetclrpowerset (now misnamed...). - -Mon Jul 31 12:47:28 1995 Per Bothner <bothner@cygnus.com> - - * convert.c (digest_array_tuple): Set TREE_STATIC if possible. - -Fri Jul 28 05:11:56 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * lex.c (readstring): Process integer literals starting with - H', D', or B' within a control sequence. - -Thu Jul 27 23:08:51 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_do_action): Don't call push_action, but defer - push_handler until begin_loop_scope. - Call parse_opt_handler here, to move handler scope inside loop block. - (parse_action): After do_action, nothing to do now. - * loop.c (begin_loop_scope): Also call push_handler here. - (declare_temps): Copy derived flag to user_var. - (declare_temps): For POWERSET, always copy to temporary (even if - constant), since the runtime clears bits from it. - - * expr.c (build_chill_sizeof): Use convert_to_class. - * satisfy.c (safe_satisfy_decl): Cleanup handling of CONST_DECL - - set proper value of CH_DECL_FLAG on both the decl and its value. - - * convert.c (digest_array_tuple); Slightly better errors. - -Wed Jul 26 22:13:39 1995 Per Bothner <bothner@cygnus.com> - - * expr.c (expand_packed_set): Also allocate the CONSTRUCTOR itself. - (fold_set_expr): Simplify accordingly. - (build_concat_expr): Constant fold bitstring CONCAT_EXPRs. - -Thu Jul 13 12:21:22 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (build_chill_slice): Use build1 instead of build. - * typeck.c (xtract_constant_from_buffer): Pass correct precision - to lshift_double. - - * typeck.c (expand_constant_to_buffer): Handle RANGE_EXPR index. - * convert.c (digest_array_tuple): Generate RANGE_EXPR as index - for tuples with ranges. - -Thu Jun 29 23:41:15 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (build_chill_slice): Re-implement to use casts - instead of build_chill_array_ref_1 (which doesn't always work). - * convert.c (convert): Remove old bugs code. - -Tue Jun 27 05:00:04 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_if_action): Do PUSH_ACTION before parsing the - expression so that a possible handler at the if action will - be found. - (parse_proc_body): New argument to indicate if the function - raises exceptions or not. In case the function will raise - exception: start a handler, parse the function and generate - code for reraising the exceptions (call chill_reraise_exceptions). - - * except.c (chill_reraise_exceptions): New function to generate - code for reraising exceptions are specified at the function - definition. - - * ch-tree.h: Add prototype for chill_reraise_exceptions. - - * decl.c (build_chill_function_type): When the function (type) - raise an exception, generate two new arguments (additional to the - formal parameters), the filename and linenumber of the caller. - (start_chill_function): likewise... - - * expr.c (build_chill_function_call): If the called function raises - exceptions, give current filename and linnumber as aditional - arguments. - - * actions.c (build_cause_exception): Handle case when function - propagates the exception. - - * grant.c (print_proc_tail, print_proc_tail_selective): If the - function(type) raises exceptions, don't process the last to - parmeters of the formal argument list, they are compiler - generated. - - * typeck.c (chill_similar): In case of FUNCTION_TYPE: check if - the exception lists are equal. - -Thu Jun 22 19:27:47 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (flag_local_loop_counter): Change default to 1. - (end_loop_scope): Set 'keep' parameter in poplevel call. - (declare)_temps): Don't set IDENTIFIER_LOCAL_VALUE, since that - is handled (correctly!) by pushdecl. - (begin_loop_scope): Call pushlevel here, - * parse.c (parse_do_action): Move pushlevel so only called for WITH. - * decl.c (struct scope): Remove n_incomplete field and its uses. - (pushdecl): Re-write to use proclaim_decl. Remove old C-isms. - (init_decl_processing): Re-name integer_type_node as "_cint" to - remove complaint from pushdecl about chill_integer_type_node as "int". - -Tue Jun 20 18:15:58 1995 Doug Evans <dje@canuck.cygnus.com> - - * Make-lang.in (chill-runtime): Restore patch to disable building of - runtime libraries for cross compilers. This patch should remain - until a build of a freshly checked out devo "just works". - -Mon Jun 19 06:01:42 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * Make-lang.in: Update GNUCHILL_VERSION to 1.4.4. - - * decl.c (init_decl_processing): Remove builtin function - __cause_exception. New builtin functions __cause_ex1 and - __unhandled_ex. - - * except.c (is_handled): Return 0 when no handler found, - 1, if the handler is in local scope and 2, if function - may propagate the exception. - - * actions.c (build_cause_exception): New argument to - indicate if a warning should be printed when - causing an unhandled exception. Call is_handled here. - - * ch-tree.h: Change prototype for build_cause_exception. - New marco CH_ALREADY_GRANTED. Used in grant.c to determine if an - identifier already has been written to grant file. - - * grant.c (write_spec_module): If not GRANT ALL specified, - write only this identifiers to grant file which are - neccessary to form a prober grant file. This will shorten - grant files and speed up compilation. - (decode_constant_selective, decode_mode_selective, - get_type_selective, decode_decl_selective, - grant_array_type_selective, get_tag_value_selective, - print_enumeral_selective, print_integer_selective, - print_struct_selective, print_proc_tail_selective, - grant_one_decl_selective): New functions. - - * lex.c (yywrap): Remove writing of not yet written USE_SEIZE_FILE - directives to grant file. - - * parse.c (parse_on_exception_list): Fis constructing of - exceptions list. - -Wed Jun 14 15:21:54 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (valid_array_index_p): Check for syntax error, where - index is a mode, rather than a value. - - * expr.c (build_chill_binary_op_1): Remove unused function. - -Sat Jun 10 11:36:52 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * except.c (is_handled): New function. - Various fixes here and there to make it work. - - * parse.c (parse_param_name_list): Set DECL_ASSEMBLER_NAME. - (Otherwise dbxout may crash.) - - * satisfy.c (satisfy case FUNCTION_TYPE): Check for non-type result. - * decl.c (start_chill_function): If result type was error_mark, - kludge type chill_os result_decl to avoid extra errors. - * actions.c (chill_expand_result, chill_expand_return): If type of - chill_result_decl is error_mark, do nothing. - - * typeck.c (chill_similar): Fix thinko in recent change. - - * config-lang.in (diff_exclude): Remove ch/lex.c - now it's a - true source file, and is never longer generated with [f]lex. - - * regression.sh: Pass -s to make clean (to make it silent). - Explicitly call gawk, instead of depending of '#!' to work. - Add --objdir flags. Never send mail to bill. - -Thu Jun 8 15:08:35 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (chill_similar): Add extra parameter. Use to to prevent - infinite recursion. - (chill_equivalent, chill_l_equivalent): Also add new parameter. - * ch-tree.h (CH_SIMILAR, CH_EQUIVALENT): Modify to match. - -Tue Jun 6 17:14:49 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (declare_temps): If -flocal-loop-counter, make sure to - pushdecl the new variable (created with decl_temp1). - And fix the type of the local variable for powerset iteration. - -Tue Jun 6 15:07:19 1995 Per Bothner <bothner@cygnus.com> - - * typeck.c (mark_addressable): Handle ADDR_EXPR inside - NOP_EXPR inside INDIRECT_EXPR. For TRUTH_ANDIF_EXPR, - TRUTH_ORIF_EXPR, and COMPOUND_EXPR mark operand 1, not operand 0 - (which is used for range-checks and suchlike). - -Thu Jun 1 02:45:54 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (build_set_expr): Do some optimizations for LE_EXPR and - GE_EXPR (don't do invert_truthvalue, just switch operands). - -Wed May 31 14:00:38 1995 Doug Evans <dje@canuck.cygnus.com> - - * lang-options.h: New file. - * lang-specs.h: New file. - -Wed May 24 01:45:18 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (assign_stack_temp): Remove unneeded declaration. - -Tue May 23 00:17:38 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_on_exception_list): Return list of exception - names in pass 1, not in pass 2. (Return non-NULL dummy if pass 2.) - (parse_on_alternatives): Call chill_handle_on_labels even if ignoring. - (parse_opt_handler): Likewise for chill_start_default_handler. - * except.c (push_handler): Clear on_alt_list only if pass 1. - (chill_handle_on_labels): Build on_alt_list in pass 1, - retrieve it in pass 2. - - Fix so that decl_temp1 does not expand_decl_init, which calls - free_temp_slots, which loses in the middle on an expression. - * decl.c (finish_decl): Don't call expand_decl_init. - (do-decl): Do initialization assignment even if stack variable. - * parse.c (parse_loc_declaration): Call free_temp_slots. - - * decl.c (finish_decl), ch-tree.h: Remove last two always-NULL - parameters. Cleanup never-used code. - * decl.c, except.c: Update calls to finish_decl. - - * decl.c (case_else_node): Define new variable. - (init_decl_processing): Initialize it. - (make_chill_variants): If variant label is case_else_node (i.e. it - is (ELSE):), treat that as an ELSE variant. - * ch-tree.h (case_else_node): Declare case_else_node. - * parse.c (parse_case_label): Use case_else_node. - -Mon May 22 10:18:11 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * grant.c (print_proc_tail): Also call print_proc_exceptions. - (decode_decl): Don't explicitly call print_proc_exceptions for - FUNCTION_DECL. - (Net effect is that now exceptions are printed for FUNCTION_TYPE too.) - - * actions.c (chill_convert_for_assignment): Use save_if_needed, - instead of save_expr, in case value is a reference. - - * typeck.c (build_chill_slice): Fix old thinko (missing call to - build_pointer_type). - - * actions.c (size_int): Remove unused and conflicting prototype. - -Wed May 17 16:23:20 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (chill_convert_for_assignment): Call save_expr if - range_checking (twice). - -Tue May 16 11:33:41 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (layout_chill_range_type): Re-organize error checking. - Add extra parameter to indicate if non-constant bounds are allowed. - If bounds are bad, set them to the min_value of the parent. - * ch-tree.h (layout_chill_range_type): Update declaration. - * satisfy.c (satisfy): Update call of layout_chill_range_type. - * typeck.c (build_chill_range_type): Likewise. - * tree.c (build_string_type): Likewise. - -Tue May 16 00:37:51 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (build_chill_sizeof): Fix bug in case of SIGNAL. - -Mon May 15 12:54:32 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * satisfy.c (satisfy): Supress error message for REF <error_mark>. - * decl.c (push_modedef): Check for TREE_CODE != ERROR_MARK, instead - of against error_mark_node. (smash_dummy_type can copy error marks.) - (finish_decl): Simplify C-derived check for incomplete type, - and suppress if it is an ERROR_MARK. - Don't call rest_of_decl_compilation if type is an ERROR_MARK. - -Sun May 14 22:52:40 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * convert.c (convert): Handle array types with different modes. - -Thu May 11 15:52:12 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (build_loop_iterator): Handle the case of a non-local - loop counter having reference type. - -Thu May 11 07:04:29 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * tasking.c (build_copy_number, build_gen_code, build_gen_inst, - build_gen_ptype, build_proc_type): Set CH_DERIVED_FLAG on result - to avoid erros when assigning to (comparing with) NEWMODEd INT's. - -Mon May 8 15:27:16 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_chill_card): Do constant folding, if possible. - (build_max_min): Do constant folding for MIN/MAX of powersets. - -Mon May 8 06:57:21 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (build_chill_sizeof): Add corect processing of a - SIGNAL definition without data. - -Sat May 6 16:27:10 1995 Doug Evans <dje@canuck.cygnus.com> - - * Make-lang.in (maintainer-clean): Renamed from realclean. - -Tue May 2 06:16:23 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_asm_action): Do PUSH_ACTION unconditionally, - otherwise "handler stack" will get out of sync. - -Mon Apr 24 09:51:07 1995 Per Bothner <bothner@rtl.cygnus.com> - - Fixes to support module-level non-static temporary variables. - * parse.c (parse_loc_declaration): If all_static_flag and not - resursive, tell do_decls to make new decl static. - * decl.c (do_decl): Don't use maybe_static function to force static. - (do_decl): Don't let initialization count as "using" the variable. - (maybe_static): Removed. - (finish_decl): Call expand_decl and expand_decl_init if needed - (as it will be for non-static temporaries). - -Fri Apr 21 21:02:30 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * convert.c, expr,c typeck.c (expand_decl): Remove usused declaration. - -Fri Apr 21 02:27:12 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (build_set_expr): Fix thinko: GE(x,y) is not eqivalent to - LT(y,x) its rather equivalent to NOT (LT(x,y)). Same is true for - GT(x,y), its not equiv. to LE(y,x), its equiv. to NOT (LE(x,y)). - -Thu Apr 20 15:29:05 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (yytext, finput): Remove unused declarations. - - * parse.c (proc_action_level): New variable. - (parse_proc_body): New function. Common code from - parse_procedure_definition and parse_process_definition moved here. - Save, set, and restore proc_action_level from action_nesting_level. - (parse_action case RETURN): Pass proc_action_level to - expand_goto_except_cleanup. - -Thu Apr 20 06:02:20 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * grant.c (really_grant_this): Add processing of LABEL_DECL's - (don't grant them). - -Tue Apr 18 18:16:28 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * lex.c ( convert_bitstring): Use BYTES_BIG_ENDIAN rather - than BITS_BIG_ENDIAN to layout bits within bitstring. - * typeck.c (expand_constant_to_buffer, extract_constant_from_buffer): - Likewise. - -Sun Apr 16 19:55:51 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (finish_chill_function): If currently global_function_decl, - don't set outer_function to global_function_decl. - -Wed Apr 12 22:45:06 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (start_chill_function): Normal functions are nested. - (finish_chill_function): No longer takes a 'nested' parameter. - Normal functions are nested. - Never call permanent_allocation, since it does little good (all normal - functions are nested), and trashes some things we need. - (finish_outer_function): Update call to finish_chill_function. - * grant.c (chill_finish_compile): Likewise. - * tasking.c (build_process_wrapper): Likewise. - * parse.c (end_function): Likewise. - * ch-tree.h (finish_chill_function): Update declaration. - - * parse.c (parse_asm_clobbers): Re-enable. - (expand_asm_operands): function. - (parse_asm_action): Re-enable. Don't do anything in pass 1. - - * typeck.c (build_chill_slice): Do constant folding. - Also, work around problem where expand_expr constant folds ARRAY_REF. - (sort_constructor): Remove unused function. - - * expr.c (chill_expand_expr case CONCAT_EXPR): Make sure we - emit_block_move if needed with correct size. - - * inout.c (build_chill_io_list_type): Simplify. - - * lex.c (check_newline): Uncomment some dwarf stuff, - which needs get_directive_line, which we no longer have. - -Wed Apr 5 16:05:15 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * Makefile.in (C_OBJS, xcc1chill): Removed. We no longer - link cc1chill with ../c-typeck.o ../c-aux-info.o ../c-common.o. - - * expr.c (build_chill_component_ref): Renamed to build_component_ref. - (chill_truthvalue_conversion): Renamed to truthvalue_conversion. - * decl.c, expr.c, inout.c, loop.c, parse.c, tasking.c, timing.c, - typeck.c: Update accordingly. - * typeck.c (valid_array_index_p): We only need to save_expr (index) - if we're range-checking. - * typeck.c (unsigned_type, signed_type, signed_or_unsigned_type, - mark_addressable, initializer_constant_valid_p, check_case_value, - type_for_size, type_for_mode): New functions, copied from - ../c-common.c and ../c-typeck.c. - - * lang.c (incomplete_type_error): New. (Was in c-common.o.) - * decl.c (constant_expression_warning): New. (Was in c-common.o.) - - * lang.c (string_index_type_dummy): Remove definition from here. - * tree.c (string_index_type_dummy): Define here instead. - * lang.c (lang_init): Move init of string_index_type_dummy - (which is too late) from here ... - * decl.c (init_decl_processing): ... to here. - - * decl.c (signed_boolean_type_node): New variable. - (init_decl_processing): Initialize it. - - * parse.c: Comment out ASM action support, for now. - - * loop.c (maybe_skip_loop): Make return void, not int. - Use build_compare_discrete_expr. - (increment_temps): Use chill_expand_assignment. - -Thu Mar 30 23:28:28 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (do_decl): If default-initializing variable-length - string to "" (or []), make it lifetime_bound. - -Thu Mar 30 02:51:59 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.h, hash.h, gperf: New compiler directives - EMPTY_ON and EMPTY_OFF. - - * lex.c: New variables empty_checking and runtime_checking_flag. - (ch_lex_init): Initialize empty_checking and range_checking - when switching from pass 1 to 2. - (read_directive): Add processing of EMPTY_OFF/ON. - - * expr.c (build_chill_indirect_ref): New argument do_empty_check - to indicate if null pointer checking should be done or not. - It's not always necessary to do a null pointer check. - - * decl.c (lookup_name): Add argument to call to - build_chill_indirect_ref. - (shadow_record_fields): ... - * parse.c (parse_primval): ... - * tasking.c (build_process_wrapper): ... - (build_receive_buffer_case_label): ... - - * ch-tree.h: Change prototype of build_chill_indirect_ref. - Add declaration of runtime_checking_flag and empty_checking. - - * actions.c (check_non_null): Do null pointer checking only - when enabled (empty_checking != 0). - -Wed Mar 29 15:18:23 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (chill_expand_assignment): Add 'else' so we don't do - regular assignment in addition to spacial assignment (e.g. for slices). - - * ch-tree.h (convert_to_discrete): Add declaration. - * typeck.c (convert_to_discrete): New function. - (valid_array_index_p): Use convert_to_discrete. Also simplify. - (build_chill_slice): Say sorry if variable-length bitstring. - (build_chill_slice_with_length): Re-do bounds check. - * expr.c (check_case_selector): Re-write to use convert_to_discrete. - (build_chill_num, build_chill_pred_or_succ): Use convert_to_discrete. - - * decl.c (do_decl): Don't do redundant chill_convert_for_assignment. - -Wed Mar 29 00:00:29 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (build_chill_num): need_unsigned have to be set for - characyer strings of length 1 too. Happens when compiling - with -fold-strings and do NUM(a(i)). - - * parse.c (parse_loc_declaration): Print error message only - in pass 1. - (parse_mode): Likewise ... - - * tasking.c (build_tasking_message_type): Temporarily reset - maximum_field_alignment to get proper aligned temp. variables - gets passed to runtime system. - -Tue Mar 28 00:08:06 1995 Per Bothner <bothner@cygnus.com> - - * typeck.c (my_build_array-ref): Merged into build_chill_array_ref_1. - But don't convert index to integer_type_node. And we don't need to - check the we're given an array. - * typeck.c (valid_array_index_p): If flag_old_strings, convert - chars(1) to char and bools(1) to bool before index checking. - -Sun Mar 26 22:42:39 1995 Per Bothner <bothner@cygnus.com> - - * ch-tree.h (struct module): Added next module field. - * decl.c (first_mdoule, next_module): New global variables. - (switch_to_pass_2): Re-initialize next_module. - (push_module): In pass 2, reuse the same module objects from pass 1. - - * decl.c (declare_predefined_file): Set DECL_IN_SYSTEM_HEADER. - - * typeck.c (valid_array_index_p): Do range check on original index, - before we convert to domain type. - -Fri Mar 24 11:43:39 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_fixed_field): New function. - (parse_variant_field_list): New function replaces parse_simple_fields. - (parse_variant_alternative, parse_field): Update to use new functions. - (parse_field): Error message if neither CASE nor NAME. - - * actions.c (check_non_null): New function - checks for NULL pointers. - * ch-tree.h (check_non_null): New declaration. - * tasking.c (expand_send_signal): Call check_non_null. - * expr.c (build_chill_indirect_ref, build_chill_function_call): Same. - * lex.h (enum rid): Add RID_EMPTY. - * lex.c (init_lex): Initialize ridpointers[RID_EMPTY]. - - * lex.c (read_directive): Remove 2 calls of to_global_binding_level - -Wed Mar 22 16:36:46 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * tasking.c (tasking_list): Change to chain of TREE_VEcs, rather than - chain of (nested) TREE_LIST nodes. - (TASK_INFO_PDECL, TASK_INFO_ENTRY, TASK_INFO_CODE_DECL, - TASK_INFO_STUFF_NUM, TASK_INFO_STUFF_TYPE): New macros. - (tasking_setup, tasking_registry, add_taskstuff_to_list): Use them. - - * ch-tree.h (C_TYPE_FIELDS_READONLY): Rename to TYPE_FIELDS_READONLY. - (TYPE_READONLY_PROPERTY): New macro, to match Z.200 concept. - * typeck.c (build_chill_modify_expr): Don't check for read-only-ness, - since it is redundant for chill_expand_assignment and breaks - reach-bound initialization in do_decl. - (my_build_array_ref): Simplify by using TYPE_READONLY_PROPERTY. - (layout_chill_array_type): Set TYPE_FIELDS_READONLY if appropriate. - * actions.c (chill_expand_assignment): Check TYPE_READONLY_PROPERTY - instead of TREE_READONLY of the target's type. - * expr.c (build_chill_function_call): Likewise. - * inout.c (build_chill_readtext): Likewise. - * decl.c (do_decl): Likewise, to check if init is required. - - * typeck.c (build_chill_bitref): Removed unused RANGE_EXPR hack. - -Wed Mar 22 07:52:52 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * tasking.c (build_start_process): Get a unique identifier for - the start arguments. - -Tue Mar 21 07:36:40 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * expr.c (fold_set_expr): At label build_result: Add setting unused - bits to 0. This is the same as the runtime library does. - - * parse.c (expect): Function returns now int, 0, if the expected - token was not got, 1 when it was found. - (parse_synonym_definition): In case of syntax error (missing =), - set expr to NULL_TREE and mode to error_mark to avoid subsequent - segfaults. - - * chill.texi: Add chapter about differences to Z.200/1988. - -Mon Mar 20 18:01:11 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * lang.c (chill_print_error_function): New function, to report - module name if not inside a function. - (lang_init): Set print_error_function to chill_print_error_function. - - * tasking.c (max_queue_size, buffer_element_mode): Cleanup - to remove unreachable code. - - * grant.c (chill_finish_compile): Avoid doing a lookup_name - to find init function (which got broken by recent nesting re-org). - - * decl.c (poplevel): Push and pop function context around - call to output_inline_function (as done for C and C++). - -Thu Mar 16 17:56:07 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_pass_1_2): If unknown top-level token, skip pass 2. - -Wed Mar 8 13:54:33 1995 Doug Evans <dje@canuck.cygnus.com> - - * Make-lang.in (chill-runtime): Temporarily disable building of - runtime libraries for cross compilers. - -Mon Mar 6 23:36:19 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c, decl.c: Remove use of FUNCTION_NEEDS_STATIC_CHAIN. - - * configure: Merge in tolerance for new flags (e.g. --x-libraries). - -Sat Mar 4 15:47:35 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_chill_arrow_expr): Error if pass == 1. - -Thu Mar 2 19:28:07 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (do_decl): Setting seen_action must be done in pass 1. - (save_decl): Don't set DECL_CONTEXT to global_function_decl. - (start_chill_function): Simplify due to above change. - - * parse.c (parse_case_label): Hack to distinguish (ELSE) from (*). - * grant.c (decode_constant): Emit ELSE in case label. - - * parse.c (serious_errors): New global variable. - * parse.c (to_global_binding_level): Set serious_errors. - (parse_pass_1_2): Exit after pass 1 if serious_errors > 0. - * lex.c (readstring): Recover from unterminstaed control sequence. - -Tue Feb 28 17:08:08 1995 Per Bothner <bothner@kalessin.cygnus.com> - - Re-write of module-level actions. No longer generate a module - function for module-level actions. Instead, put them inside - a new global dummy function. Nest everything logically inside it. - - * lex.h, grant.c (chill_module_name): Removed declaration. - * grant.c (write_spec_module): Instead use current_module->name. - * grant.c (chill_start_module_code, chill_finish_module_code): - Removed. - * grant.c (chill_finish_compile): Make rtl for global function. - - * actions,c (push_action): Don't call chill_start_module_code. - * expr.c (build_chill_function_call, build_generalized_call): - Likewise. - * parse.c (INIT_ACTION): Likewise. - - * parse.c (seen_action): New variable. - * parse.c (end_function): Always call pop_chill_function_context. - (parse_procedure_definition): Always call push_chill_function_context. - (parse_modulion): Parse optional handler. - (parse_modulion, parse_spec_module): Do find_granted_decls. - (parse_action): Set seen_action if global and a real action. - ([arse_program): Call start_outer_function and finish_outer_function. - - * ch-tree.h: Appropriate updates. - - * tasking.c (generate_tasking_code_variable): Make it lifetime-bound. - (build_process_header): Always push_chill_function_context; - we are now always nested. - (build_process_wrapper): Always pop_chill_function_context. - - * tasking.c (build_start_process): Only expand_start_bindings and - expand_end_bindings if pass 2. - - * decl.c (global_function_decl): New variable. - (do_decl): Implement reach-bound initialization of static variables. - (start_chill_function): Set DECL_CONTEXT to NULL if - it would be global_function_decl (so as to not confuse gcc backend). - (start_chill_function, finish_chill_function): If compiling - global_function_decl in pass 2 and !seen_action, suppress it. - (set_module_name): New function. - (global_bindings_p): Re-defined to check against global_function_decl. - (start_outer_function, finish_outer_function): New functions. - -Tue Feb 28 16:00:03 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (build_chill_modify_expr): Inline logic from - chill_expand_array_assignment, - * actions.c (chill_expand_array_assignment): Removed. - (chill_expand_assignment): Remove call to removed function. - - * lex.c (reinit_parse_for_function): Removed empty unused function. - * decl.c (start_chill_function): Don't call removed function. - -Tue Feb 28 00:29:51 1995 Per Bothner <bothner@cygnus.com> - - * configure: Merge in code for calculating host, build, and - target and canon_{host,build,target} from ../configure. - Fix calculation of mainsrcdir. Host canon_* variables - to merge in build-make (as in ../configure). - -Sun Feb 26 18:59:02 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (expand_constant_to_buffer): Use new function - get_set_constructor_bytes. - -Tue Feb 21 01:41:56 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * inout.c (build_chill_writetext): Add processing of - conditional expressions in argument list. - - * parse.c (parse_opt_name_string): Print error message only - in pass 1. - - * chill.texi: Add chapter about compiler directives. - -Tue Feb 14 16:45:19 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * decl.c (start_chill_function): Set FUNCTION_NEEDS_STATIC_CHAIN - unless nested. - - * decl.c (decl_temp1): Make lifetime_bound iff static. - -Fri Feb 3 04:30:28 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * grant.c (really_grant_this, search_in_list): New static - functions to determine if a decl should be written to - grant file. - (write_spec_module): Add call to really_grant_this. - -Fri Jan 27 00:06:12 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (check_expression): Apply Per's patch. - (chill_expand_result): New argument to indicate if we come - from a RETURN or RESULT action. Change various error messages. - - * ch-tree.h: New macro CH_USE_SEIZEFILE_RESTRICTED. - New argument for chill_expand_result. - - * chill.in: In case of -fgrant-only, clear library, libpath and - startfile to avoid warnings from gcc. - - * gperf, hash.h: New compiler directive USE_SEIZE_FILE_RESTRICTED. - - * parse.h (enum terminal): Add USE_SEIZE_FILE_RESTRICTED. - - * grant.c (decode_decl): Don't write USE_SEIZE_FILE directive - and subsequent SEIZEs to grant file, if the seize file is - used restricted. - - * lex.c (read_directive): Process new compiler directive - USE_SEIZE_FILE_RESTRICTED. - (handle_use_seizefile_directive): Same as above. - (yywrap): Don't write USE_SEIZE_FILE directive to grant file - if this seize file is used restricted. - - * parse.c (parse_action, case RETURN): Change RETURN expr action - to RESULT expr; RETURN. This enables range checking and - exception delivery in case of rangefail. - -Tue Jan 17 07:38:27 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * decl.c (init_decl_processing): Add definition of - library function __inbitstring (see expr.c). - - * expr.c (chill_expand_expr case SET_IN_EXPR): Call function - __inpowerset fir POWERSET's and function __inbitstring for - BITSTRING's. In case of POWERSET's we must not do a rangecheck, - in case of BITSTRING's we have to do one. - (build_compare_expr): Fix typo CH_DERIVED_FLAG (tmp); (warning - statement with no effect). - -Fri Jan 13 13:35:30 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (check_expression): Simplify result. - - * ch-tree.h (SET_CH_NOVELTY_NONNIL): New macro. - * expr.c, timing.c, typeck.c: Use SET_CH_NOVELTY_NONNIL. - - * typeck.c (valid_array_index_p), ch-tree.h: Change interface - to return modified index expression. Call error if out-of-range. - * actions.c, typeck.c: Modify - for new valid_array_index_p interface. - - * actions.c (build_chill_slice): Copy novelty of index type. - -Fri Jan 13 13:04:41 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * convert.c (digest_array_tuple): Allow mode name in array - tuple label. Print error message instead of aborting. - - * parse.c (parse_body): Error message only if pass 1. - - * decl.c (check_identifier), ch-tree.h: Remove. Unused. - -Wed Jan 11 14:03:47 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_modulion): Undo yesterday's change (to allow - an ON-handler to follow) until we re-implement module. - -Tue Jan 10 17:23:55 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c (declare_temps): Remove bogus prohibition against - iterating over BOOL arrays. - - * parse.c (parse_semi_colon): Make it a pedwarn (instead of an - error) if a semi-colon is missing before an END. - (parse_action): Likewise. - * parse.c (parse_modulion): Allow an ON-handler to follow. - - * parse.c (parse_set_mode): Use parse_expression to get - values for number set elements. - - * expr.c (build_compare_expr): Make sure result has - CH_DERIVED_FLAG set, since it is supposed to be BOOL-derived. - (finish_chill_binary_op): Likewise for IN_EXPR. - -Tue Jan 10 04:46:42 1995 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (lookup_and_expand_goto, lookup_and_handle_exit): Add - checking the argument. - (chill_expand_assignment): Take care of a newmoded dst_offset - when calling __pscpy and a newmoded from_pos when calling - __setpowersetbits. - - * expr.c (chill_expand_expr): When calling __psslice take care - of a newmoded min_value. - - * parse.c (parse_name_string): Print error message only in - pass 1. - -Tue Jan 3 19:56:36 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c (build_chill_array_ref_1): Use varying_to_slice - instead of building a VRAY_ARRAY_REF node. - * ch-tree.def (VARY_ARRAY_REF): Removed. - * actions.c (chill_expand_assignment): Will never call - expand_assignment_to_varying_array for a VARY_ARRAY_REF, so don't. - (expand_assignment_to_varying_array): Removed. - * convert.c (convert): Remove unneeded VARY_ARRAY_REF support. - * expr.c (chill_expand_expr): Likewise. - -Tue Jan 3 19:50:18 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_iteration): Set step_value to NULL if missing. - * loop.c (ITER_TYPE): Remove DO_RANGE. - (build_loop_iterator): Implement old DO_RANGE in terms of DO_STEP. - (begin_loop_scope): Don't return on error. - (build_loop_iterator): Calculate loop variable type using - resulting classes (as in Z200), rather than precision. - - * loop.c (initialzie_iter_var, bottom_loop_end_check): For DO_STEP, - make iter_var one less to avoid overflow. - * loop.c (build_loop_iterator): If !flag_local_loop_counter, - declare a new variable if needed, as allowed by Z200 (1984). - - * ch-tree.h (ch_class): Add typedef. - - * typeck.c (chill_resulting_class): New function. - (chill_root_resulting_class): Remove. - * ch-tree.h (CH_RESULTING_CLASS): New macro. - (CH_ROOT_RESULTING_CLASS): Re-implement using CH_RESULTING_CLASS. - -Tue Jan 3 19:36:27 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (build_cause_exception, expand_cause_exception), ch-tree.h: - Change interface to take IDENTIFIER tree node, rather char char*. - (check_expression): Change (simplify) callers appropriately. - * parse.c (parse_action), typeck.c (valid_array_index_p): Likewise. - * lex.h (enum rid): Add RID_ASSERTFAIL. - * lex.c (init_lex): Enter RID_ASSERTFAIL. - * parse.c (parse_action case ASSERT): Fix thinko TRUTH_ANDIF_EXPR - to TRUTH_ORIF_EXPR. Use RID_ASSERTFAIL. - - * typeck.c (discrete_type_p): Re-implement using INTEGRAL_TYPE_P. - -Tue Jan 3 19:20:35 1995 Per Bothner <bothner@kalessin.cygnus.com> - - Move checking for modeless tuples in invalid contexts from parser - to semantic function check_have_mode (for better error recovery): - * expr.c (check_have_mode), ch-tree.h: New function. - * satisfy.c (safe_satisfy_decl): Use check_have_mode. - * expr.c (build_compare_expr, finish_chill_binary_op, - finish_chill_unary_op): Likewise. - * parse.c (parse_primval): Don't complain about mode-less tuple here. - -Tue Jan 3 17:36:48 1995 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (varying_to_slice): Support varying arrays whose - lower bound is non-zero. - - * parse.c (parse_body): Allow (with warning) definition to - follow action. - - * expr.c (check_case_selector), ch-tree.h: New function. - (chill_expand_case_expr): Use it. - * parse.c (parse_case_action): Likewise. - -Fri Dec 23 00:47:54 1994 Wilfried Moser <moser@rtl.cygnus.com> - - * actions.c (chill_expand_return): Change error message. - - * ch-tree.h: Change prototypes of do_decl and do_decls. - - * convert.c (convert): Add missing initialisation of - variable orig_e_constant. - - * decl.c: Change all calls to do_decl. - (maybe_static): New function to process the ALL_STATIC_ON/OFF - compiler directives. - (do_decls): New argument. - (do_decl): New argument and process reachbound and lifetime - bound initialisation. - - * gperf, hash.h: Add compiler directives ALL_STATIC_ON and - ALL_STATIC_OFF. - - * grant.c: Change all calls to do_decl. - - * lex.c (read_directive): Process ALL_STATIC_ON/OFF compiler - directive. - - * parse.c (parse_loc_declaration): Pass lifetime_bound flag to - do_decls. - - * parse.h (enum terminal): Add ALL_STATIC_ON and ALL_STATIC_OFF. - - * tasking.c: Change all calls to do_decl. - -Mon Dec 19 23:13:58 1994 Wilfried Moser <moser@rtl.cygnus.com> - - * parse.c (parse_procedure_definition): Save chill_at_module_level - flag, set ot to 0 and restore it at the end of function. - A sequence BEGIN x: PROC () RETURN; END x; END; at module level - have produced an error. - - * expr.c (build_chill_repetition_op): Fix typo in error message. - -Tue Dec 13 12:26:38 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * actions.c (expand_assignment_to_varying_array): Fix thinko: - build_chill_array_ref -> build_chill_array_ref_1. - -Sun Dec 11 23:04:27 1994 Per Bothner <bothner@rtl.cygnus.com> - - * actions.c (chill_expand_assignment): Simplify the lhs if it is - a COMPOUND_EXPR, so we can better handle SLICE_EXPR in lhs. - -Thu Dec 8 13:45:38 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * loop.c, ch-tree.h (build_loop_iterator): Fix to return void. - If start_exp is ERROR_MARK, return. - * expr.c (build_generalized_call): More robust on syntax errors. - -Tue Dec 6 02:33:23 1994 Wilfried Moser <moser@rtl.cygnus.com> - - * inout.c (build_chill_readtext): In case of reading a SET mode - pass ignore_case flag to runtime library. - -Tue Nov 29 14:41:38 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_receive_case_action): Print error only if pass==1. - * decl.c (push_scope_decls): Use error_with_file_and_line - to get correct line number of SEIZE. - -Mon Nov 28 16:59:18 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (resolve_component_ref): Call fold on result. - - * expr.c (resolve_component_ref): Use check_expression. - * actions.c (chill_convert_for_assignment): Likewise. - * actions.c (cond_exception), ch-tree.h: Removed. - * actions.c (check_expression): First part of COMPOUND_EXPR - should be boolean_type_node; void_type_node loses in SAVE_EXPRs. - - * actions.c (chill_convert_for_assignment): - Check string_assignment_condition for varying strings too. - - * typeck.c (build_chill_cast): If the types have different sizes, - don't allow nondiscrete->discrete conversion, and only allow - discrete->nondiscrete if input expression is constant. - - * typeck.c (chill_similar): Don't use losing array_type_nelts. - - * ch-tree.h (ELSE_VARIANT_NAME): New. - * convert.c, decl.c, grant.c: Use ELSE_VARIANT_NAME. - * decl.c (handle_one_level): Recurse on ELSE_VARIANT_NAME too. - - Reduce dependencies on ../c-typeck.c: - * expr.c: Fix c_expand_start_case -> expand_start_case. - Fix c_expand_expr_stmt -> expand_expr_stmt. - (build_chill_indirect_ref): Call convert instead of build_c_cast. - * loop.c (bottom_loop_end_check): Don't use build_modify_statement. - * expr.c, except.c, typeck.c: Don't call default_conversion. - * typeck.c (string_assignment_condition): Fix build_component_ref -> - build_chill_component_ref. - * decl.c: Fix build_indirect_ref -> build_chill_indirect_ref (twice). - * decl.c: Don't set unused constructor_no_implicit (from c-typeck.c). - * decl.c: Don't call declare_function_name. - - * parse.c: Don't always keep a valid token in terminal_buffer[0]. - The extra look-ahead may have made the parser faster, but caused - some problems synchronizing with the lexer. Specifically: - (PEEK_TOKEN): Now calls an optimized variant of peek_token_(0). - (next_token_): Don't call peek_token_. Renamed to forward_token_. - (NEXT_TOKEN): Renamed to FORWARD_TOKEN. - (parse_program): Don't call yylex yet. - - * parse.c (parse_action): Re-do case ASSERT. - Fix c_expand_expr_stmt -> expand_expr_stmt. - - * lex.l: Re-written to not use [f]lex, and renamed to ... - * lex.c: ... new lexer. - * Makefile.in, Make-lang.in: Remove [f]lex crud. - - * lex.h (enum rid), lex.c (init_lex): Added RID_ELSE. - -Tue Nov 22 15:19:03 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * Make-lang.in: Let chill-runtime depend on $(GCC_PASSES). - -Fri Nov 18 14:27:32 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * parse.c (parse_structure_node): Simpler, and more robust. - -Wed Nov 16 14:40:52 1994 Ian Lance Taylor (ian@cygnus.com) - - * lex.l (convert_bitstring): Check BITS_BIG_ENDIAN at run time, - not at compile time. - * typeck.c (expand_constant_to_buffer): Likewise. - extract_constant_from_buffer): Likewise. - -Tue Nov 15 14:41:53 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * convert.c (convert): Call build_chill_range_type rather than - build_index_2_type (which has obstack and canonicalization problems). - * expr.c (build_chill_pred_or_succ): Convert expr to root class - before arithmetic. - * loop.c (declare_temps): If location iterated over is not - a location, make a temporary variable for it. - -Mon Nov 14 16:33:47 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * typeck.c, ch-tree.h (chill_equivalent): Change to return - a tree (a Boolean expression). Also, add some missing tests. - * ch-tree.h (CH_EQUIVALENT): Modify accordingly. - - * expr.c (chill_expand_expr case CONCAT_EXPR): When the 2nd operand - is an UNDEFINED_EXPR, handle mode-mismatch with whole expr. - Also, replace MEM (which is not a mode) by Pmode. - - * ch-tree.h, typeck.c (chill_comptypes): Removed. - * convert.c (convert): Remove calls to chill_comptypes. - -Fri Nov 11 13:06:29 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * grant.c (write_grant_file): Call pfatal_with_name instead - of abort when something goes wrong when opening or writing - the grant file. - unlink grant file if something goes wrong during writing - (i.e. device full). - - * Make-lang.in (CHILL_SRCS): Add timing.c - - * ch-tree.h: Add prototype for chill_tasking_type_node. - * lex.l (equal_number): Use chill_tasking_type_node instead of - integer_type_node for converting the result. - Print error messages in pass 2, in pass 1 no error will be - detected. - * tasking.c: New variable chill_tasking_type_node for all - generated tasking related variables. - Use chill_tasking_type_node instead of chill_unsigned_type_node. - - * expr.c (chill_expand_expr): Apply Per's change. - - * expr.c (build_chill_sizeof): In case of error just - return error_makr_node. - Set CH_DERIVED_FLAG at the result. - - * timing.c (build_after_timeout_start): Clear the the timeout - level to know if we are in the action part of AFTER statement - or in the TIMEOUT part. - - * typeck.c (build_chill_slice_with_length): Convert the class - of the result to class of first value in expression. - - * inout.c (build_chill_writetext, build_chill_readtext): Use stack - temporary variables for the iolist so that they can get reused in - subsequent calls. Emit code immediately instead of building a - compound expr. - -Fri Nov 4 12:00:54 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_chill_function_call): Don't set TREE_TYPE - of assignment to void_type_node - it confuses save_expr. - * decl.c (init_decl_processing): Removed unused code. - * parse.c: Changes to avoid warnings. - - * grant.c (chill_finish_module_code): Minor simplification. - * lex.l (readstring): Set *len to 1 on error. - -Thu Nov 3 01:05:17 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * grant.c (decode_decl): Add granting of BASED declarations. - -Wed Nov 2 12:14:31 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_chill_lower_or_upper): Take more care to - ensure result has the right class. - (build_chill_pred_or_succ): Be more careful to get the right - resulting class, and check bounds using *root* mode. - - * typeck.c (build_chill_slice_with_range): Check that array - really is an array or string. - (build_chill_slice_with_length): Likewise. - - * typeck.c (extract_constant_from_buffer): Fix calculation of - SET_TYPE size. (Cannot depend on 1-byte TYPE_PRECISION field.) - -Wed Nov 2 05:33:03 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * Make-lang.in: Change version of compiler. - - * ch-tree.h: Add new prototypes. - - * decl.c (init_decl_processing): Remove timing related - initialisations. Add call to timing_init. - - * parse.c (parse_action): Process AFTER action. - - * tasking.c (build_receive_case_start, - build_receive_signal_case_label, build_receive_buffer_case_label, - build_delay_case_start, build_delay_action, expand_send_buffer): - Add processing of timesupervision. - (tasking_init): Change definitions of runtime functions. - - * timing.c (timing_init): New function for initialisation of - timing related stuff. - (build_cycle_start, build_cycle_end): Changed due to - implementation of timesupervision. - (build_after_start, build_after_timeout_start, build_after_end): - Implement the AFTER action. - (build_timeout_preface, build_timesupervised_call): New functions - to handle timesupervision in case of blocking system calls (i.e. - SEND buffer action, RECEIVE CASE action etc.). - -Thu Oct 27 12:50:24 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_chill_repetition_op): Fix repeating all-zero - bitstring with orig_len!=1. Also, call build_boring_bitstring - if original string was all ones, using one range. Also: - Cannot use one-bit TYPE_PRECISION to get bitstring length. - -Tue Oct 25 14:11:07 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * convert.c (convert): When converting BOOL constant to - bit-string, bit_one_node and bit_zero_node were switched. - * actions.c (chill_expand_assignment): Use force_addr_of, - not build_chill_addr_expr - latter yields bogus error. - -Fri Oct 21 14:26:52 1994 Per Bothner <bothner@kalessin.cygnus.com> - - * expr.c (build_chill_indirect_ref): Check for POINTER_TYPE (only) - after converting from REFERENCE_TYPE. - * expr.c (build_compare_expr): Convert to common mode *after* - we've checked compatibility. - -Fri Oct 21 02:29:15 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * lex.l (check_newline): Use getc instead of getlc to read - the filename in a # line name directive to avoid possibly - downcaseing of a filename. - -Thu Oct 20 05:37:17 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * expr.c (build_chill_indirect_ref): Add check for really - dereferencing a pointer. - - * convert.c (convert): Take care of TREE_CONSTANT of a - SYNONYM having mode ARRAY () VARYING something. - -Mon Oct 17 02:30:38 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * decl.c (init_decl_processing): Set CH_DERIVED_FLAG for - boolean_true_node and boolean_false_node. TRUE and FALSE have - the BOOL derived class. - - * expr.c (build_chill_num): Set CH_DERIVED_FLAG at the result - of NUM. NUM delivers the INT derived class. - - * grant.c (write_spec_module): Add writing of - <> USE_SEIZE_FILE "x.grt" <> - SEIZE ALL; - to generated grant file. - -Thu Oct 13 14:45:12 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * convert.c (convert_from_reference): Make non-static. - * ch-tree.h (convert_from_reference): Add prototype. - * parse.c (parse_name): If the decl is a REFERENCE_TYPE, just - call convert_from_reference - and not a full-scale convert. - - * convert.c (convert): Only call digest_array_tuple if ARRAY_TYPE. - * typeck.c (chill_expand_tuple): Print error if type is - neither array, struct, or powerset. - - * expr.c (chill_expand_expr cases CONCAT_EXPR, SET_*_EXPR, - UNDEFINED_EXPR): Call preserve_temp_slots for temp targets. - If target is not MEM, make temp (even if not REG) to simplify - - and don't copy original target to temp target first. (Not needed.) - - * lang.c (maybe_objc_comptypes): Just return -1. - -Wed Oct 12 12:24:20 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * tasking.c (tasking_setup): Fix breakage from previous check-in. - -Tue Oct 11 16:00:37 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * actions.c, convert.c, except.c, expr.c, inout.c, loop.c, tasking.c, - timing.c, typeck.c: Change build1 (ADDR_EXPR, ptr_type_node, XX) - to force_addr_of (XX). Add call to mark_addressable where needed - for other calls to build 1 (ADDR_EXPR, TYPE, XX). - -Thu Oct 6 06:36:28 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * inout.c (build_chill_writetext): Remove processing - of POWERSET's. - -Tue Oct 4 14:08:26 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * convert.c (convert): If flag_old_strings, support converting - CHARS(1) and BOOLS(1) to INT. - -Fri Sep 30 01:44:51 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * inout.c (build_chill_readtext): Add check for item is - referable and not READonly. Add processing of BITSTRINGs. - -Mon Sep 26 16:19:36 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c (build_chill_descr): Add missing call to mark_addressable. - * loop.c (toop_loop_end_check): Replace build1 (ADDR_EXPR ...) - with call to force_addr_of (which calls mark_addressable). - * expr.c (build_chill_descr, build_chill_inttime): Likewise. - * inout.c (build_chill_writetext): Likewise. - -Mon Sep 26 05:19:21 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * grant.c (print_struct): Move printing of VARYING from - here ... - * grant.c (grant_array_type): ... to here. - -Mon Sep 26 00:09:08 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (force_addr_of): New prototype. - * expr.c (force_addr_of): Call mark_addressable. Make non-static. - * inout.c (build_chill_writetext): Use force_addr_of. - -Sun Sep 25 23:41:59 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * except.c (push_handler), actions.h: Removed unused parameter. - * actions.c (push_action): Remove unused paramater. - * parse.c, actions.c: Remove no-longer-used parameter to - calls to push_handler and push_action. - - * decl.c (push_extern_process): Only build types in pass 1. - * tasking.c (build_process_header): Only build types in pass 1. - * tasking.c (build_start_process): Do pushdecl/popdecl etc - even after an error (to maintain consistency between passes). - - * convert.c (convert_to_boolean): Allow any integral input type. - -Sat Sep 24 22:47:54 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (extract_constant_from_buffer): Add (somewhat kludgey) - support for UNION_TYPE. (Patch from Wilfried.) - Also, reverse RECORD_TYPE constructor list. - -Fri Sep 23 19:06:39 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c (build_concat_expr): Fix calculation of result_size. - -Wed Sep 21 00:54:21 1994 Per Bothner (bothner@kalessin.cygnus.com) - - Give up on trying to use the cleanup mechanism in stmt.c to - make sure the exception handler get unlinked on goto/exit/return. - Instead, do it ourselves. (Much simpler.) - * except.c, ch-tree.h (action_nesting_level): New global. - * ch-tree.h (DECL_ACTION_NESTING_LEVEL): New macro. - * decl.c (define_label): Set DECL_ACTION_NESTING_LEVEL. - * except.c (expand_goto_except_cleanup): New function. - (cleanup_chain): New variable. - (push_handler, pop_handler): Adjust action_nesting_level. - (emit_setup_handler): Push cleanup. - (chill_finish_on): Pop cleanup. - * actions.c (lookup_and_expand_goto, lookup_and_handle_exit): - Call expand_goto_except_cleanup. - * parse.c (parse_action): Before RETURN, call - expand_goto_except_cleanup. - -Mon Sep 19 00:59:54 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lex.l (equal_number): Make sure converted synonym - is on permanent obstack. - * typeck.c (extract_constant_from_buffer): Fix INTEGER_TYPE - loop to traverse in big-endian order. - -Sat Sep 17 20:48:37 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (build_chill_cast): Call mark_addressable. - * expr.c (build_chill_function_call): Call mark_addressable. - -Thu Sep 15 23:47:01 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (expand_constant_to_buffer): Fix an endian-ness - problem for INTEGER_CST. - (extract_constant_from_buffer): Likewise. - -Thu Sep 15 22:59:04 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (pushlevel): Do different things depending on - actual parameter. - * decl.c, parse.c, tasking.c: Change argument to to pushlevel to 1. - * actions.c (push_action): Take new parameter. - * except.c (push_handler): Likewise. - * parse.c: Change calls to push_action and push_handler. - * loop.c (begin_loop_scope): Always call expand_start_bindings. - * loop.c (end_loop_scope): Always call expand_end_bindings. - * except.c (emit_setup_handler): Add a cleanup to - unlink from exception stack if we return/exit/goto from here. - * loop.c (begin_loop_scope): Move pushlevel from here ... - * parse.c (parse_do_action): ... to here. - - Clean up do-decl interface (for decl_temp1). - * parse.c (parse_loc_declaration): If global_bindings_p (), - treat as static. - * decl.c (do_decl): Don't test global_bindings_p (). - - * decl.c (keep_next_level_flag, keep_next_if_subblocks): - Not used. Removed. - (struct scope::keep, scope::keep_if_subblocks): Likewise. - (keep_next_level): Likewise. - (kept_level_p, pushlevel, poplevel): Simplify. - - * decl.c (init_decl_processing): Don't call init_iterators. - * Makefile.in (C_OBJS): Don't get ../c-iterator.o - not needed. - -Thu Sep 15 05:54:11 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * lex.l (readstring): Add processing of control sequence - in character string literals. The granting mechanism writes - this to grant files. - -Tue Sep 13 06:19:42 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * expr.c (compare_records): In case of -fpack do always - a memcmp instead of comparing each field of the - structure. If the structure is a variant structure, - issue a warning. - -Mon Sep 12 13:15:09 1994 Per Bothner (bothner@cygnus.com) - - * grant.c (write_spec_module): Add cast, to avoid PCC warning. - * grant.c (header_template): Don't use ANSI-specific string - literal concatenation. - -Fri Sep 9 01:53:30 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * tasking.c (get_process_wrapper_name): New function. - (add_taskstuff_to_list): Add a new argument, which is - the entrypoint of a process. - (build_process_header): Change PROCESS arguments to be - like arguments of a function. There will be a wrapper - which is the real entry point for a PROCESS. This wrapper - is automatically build after a PROCESS definition and gets - as argument a pointer to a structure looking like the - arguments of the PROCESS. This wrapper will call the - PROCESS (see build_process_wrapper). - (build_process_wrapper): New function (see above). - (build_start_process): Change processing of arguments. - (tasking_setup): Add processing of a different entry point - in case of PROCESSes. - - * parse.c (parse_process_definition): Add call to - build_process_wrapper. - * parse.c (end_function): Remove the poplevel() call. - build_process_header no longer makes the corresponding - pushlevel(). - - * grant.c (print_proc_tail): Remove special processing - of PROCESSes, they look now like normal functions. - - * decl.c (init_decl_processing): Add declaration of memcmp - function. - - * ch-tree.h: Add new prototype for build_process_wrapper, - change prototypes for add_taskstuff_to_list and - build_process_header. - - * grant.c (write_spec_module): Write GNUCHILL and gcc - version into grant file. - - * Make-lang.in (CHILL_FLAGS_TO_PASS): Add passing of CC and - GNUCHILL_VERSION to ch/Makefile. - * Make-lang.in (CHILL.mostlyclean): Add ch/ch-version.c. - - * Makefile.in (CHILL_OBJS): Add ch-version.o. ch-version.c - will get generated every time a new Makefile will get - generated. - * Makefile.in (GNUCHILL_VERSION): Remove it, its defined in - Make-lang.in. - - * chill.in: In case of -fgrant-only pass "-S -o /dev/null" - to the compiler to avoid generation of an object file. - -Thu Sep 8 12:07:28 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * convert.c (display_int_cst), ch-tree.h: New function. - * convert.c (digest_array_tuple): Use digest_int_cst to - provide better error messages. Return error_mark_node on error. - * grant.c (decode_const): Simplify by using digest_int_cst. - * grant.c (format_character, find_assoc): Removed. - - * decl.c (do_decl): Add missing TREE_CHAIN. - - * decl.c (finish_incomplete_decl): Removed. - (init_decl_processing): Don't set incomplete_decl_finalize_hook. - (finish_decl): Remove old C-specific code to deduce size of - array from initialization. - (complete_array_type): Just make it abort. - - * except.c (finish_handler_array): Avoid calling C-specific kludge - complete_array_type. - - * convert.c (digest_constructor): Rename, and re-write to: - (digest_array_tuple, convert): No longer use the code in - ../c-typeck.c; use a Chill-only implementation (sigh). - - * typeck.c (chill_expand_tuple): Remove unneeded call to - complete_array_type. - - * expr.c (fold_set_expr), grant.c (decode_constant), - typeck.c (expand_constant_to_buffer): Update name of called - function unpack_set_constructor to get_set_constructor_bits. - * expr.c (powersetlen ): Remove redundant call to convert. - - * ch-tree.h (unpack_set_constructor): Removed obsolete declaration. - - * inout.c (build_chill_writetext): Handle 64-bit integer literals - by trying to convert them to a smaller type. - - * lex.l (convert_number): Always use long long type (possibly - unsigned) to avoid problems with constant folding truncation. - -Mon Sep 5 08:08:22 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * ch-tree.h (enum chill_built_in_function): Add BUILT_IN_QUEUE_LENGTH. - Add new prototype (see tasking.c). - - * expr.c (build_generalized_call): Add processing of - BUILT_IN_QUEUE_LENGTH. - - * tasking.c (build_queue_length): New function. - - * tasking.c (tasking_init): Add new external function definition. - -Thu Sep 1 15:38:00 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lex.l (default_lex): New function. Progress towards - getting rid of [f]lex. - - * lex.l (convert_number): Use mul_double and add_double. - Set result type to a reasonable type in which the literal - will fit. Give error message if literal is too big. - - * lex.l (equal_number): Switch (temporarily) to permanent obstack. - - * typeck.c (build_chill_slice_with_range): Check for empty - slice *after* we have checked for upper/lower limit in range. - - * grant.c (decode_mode): Remove unused code. (BOOL and - CHAR ranges are represented as INTEGER_TYPEs.) - - * tasking.c (build_process_header): Add missing call to - expand_start_bindings. - * parse.c (end_function): Add missing expand_end_bindings. - -Wed Aug 31 17:25:14 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (init_decl_processing): Set set_alignment. - -Tue Aug 30 16:40:46 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * actions.c (print_missing_cases, check_missing_cases, - BITARRAY_TEST, BITARRAY_SET): New functions and macros, - to check for completeness of case actions and expressions. - * decl.c (c_decode_option, init_decl_processing): - Don't set warn_switch. - * expr.c (chill_expand_case_expr): Call check_missing_cases - instead of check_for_full_enumeration_handling. - * parse.c (parse_case_actions): Call check_missing_cases. - - * expr.c (build_chill_binary_op): Remove some dead code. - * expr.c (chill_truthvalue_conversion): Call build_chill_binary_op - instead of build_binary_op. - * ch-tree.h (binary_op_error, build_binary_op): Unused. Removed. - - * parse.c (end_function): Use kept_level_p in parameter to - poplevel. This reverts a June 13 change. - -Fri Aug 26 11:50:19 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) - - * configure: Ignore --without, as ../configure does. - -Wed Aug 24 01:17:28 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * lex.l: Change rule for decimal numbers to allow identifiers - to start with an underscore (_). - -Fri Aug 19 16:38:12 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * tasking.c (build_receive_signal_case_label): Remove backwards - chill_convert_for_assignment (which converted whatever garbage - was in the *target* to the type of the signal argument!). - -Fri Aug 19 07:10:43 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * inout.c (build_chill_io_list_type, build_enum_tables), - tasking.c (build_tasking_struct): Temporarily reset - maximum_field_alignment to 0, so that the compiler-built - data structures needed by the RTS can be independent of -fpack. - -Thu Aug 18 13:39:51 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (build_init_struct): Temporarily reset - maximum_field_alignment to 0, so that the compiler-built - data structures needed by the RTS can be independent of -fpack. - -Wed Aug 17 23:48:33 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * parse.c (parse_primval, expect, parse_on_exception_list): - Print error message only in pass 2. - -Wed Aug 17 13:47:50 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (switch_to_pass_2): Revert June 13 change, - (Don't exit after pass 1 if an error was found.) - - * ch-tree.def (SLICE_EXPR): New tree-code. - * typeck.c (build_chill_slice): For building a slice of a - bit-string, just generate a SLICE_EXPR. - * decl.c (init_decl_processing): Declare __pscpy. - * actions.c (chill_expand_assignment): Handle a SLICE_EXPR - on the LHS of assignment, by calling __pscpy. - * expr.c (chill_expand_expr): Handle SLICE_EXPR (as a RHS - value) by using __psslice to copy slice to a temp. - -Wed Aug 17 05:52:44 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * Make-lang.in: Change version of GNUCHILL compiler to 1.4.1. - * expr.c (build_chill_length): Enable LENGTH built-in to process - Buffers and Events too (Z.200/1992). - * lex.l (yywrap): Always set yyin to finput and/or grt_in. On - a linux system the previous version was not able to run. - * tasking.c: Correct processing of infinite buffer- and event-length - to avoid RANGEFAIL warning. - -Thu Aug 11 11:46:55 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.c (parse_if_expression_body): Don't call the C-specific - build_conditional_expr. Just do build_nt (COND_EXPR, ...). - * convert.c (convert): Convert a COND_EXPR by converting - each branch. - - * convert.c (convert): Don't call convert before - convert_to_reference. It's apt to do weird and unneedful things. - * convert.c (convert): If the expression is varying, just call - varying_to_slice, which simplifies quite a bit. - - * ch-tree.h (varying_to_slice): Add prototype. - * typeck.c (varying_to_slice): Remove prototype. - - * satisfy.c (satisfy): Move case PAREN_EXPR from type 'e' - to type '1'. - - * except.c (emit_setup_handler): Temporarily reset the - maximum_field_alignment to zero so the compiler's exception - data structures can be compatible with the run-time system, - even when we're compiling with -fpack. - - * expr.c (compare_records): Call saved_if_needed on operands. - - * expr.c (build_set_expr case NE_EXPR): Don't use __nepowerset - which has been reimplemented to just call __eqpowerset and - invert the result. Inline this new implementation by - handling as EQ_EXPR, and inverting the result. - * decl.c (init_decl_processing): Don't define unused __eqpowerset. - - * typeck.c (valid_array_index_p): The TRUTH_ANDIF_EXPR has - type boolean_type_node, not void_type_node. (Fixing this - avoids a crash in the back-end.) - - * grant.c (decode_constant): In a CALL_EXPR, if the argument - list is not a TREE_LIST (as in string repetiation), don't - emit parentheses. - -Wed Aug 10 13:13:55 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (proclaim_decl): Use CH_DECL_ENUM to check that a - CONST_DECL is from a SET definition. (This is safer than - checking that the type is ENUMERAL_TYPE, because synonym - definitions may have a NULL TREE_TYPE.) - Also, if we have duplicate enums whose types are identical, - this is an error. - * decl.c (proclaim_decl, pushdecllist, push_scope_decls): Add - an extra 'quiet' parameter, which is true if we're called from - bind_sub_modules. (In that case an error message about duplicated - decls would be repeated later, so suppress it.) - - * parse.c (stmt_count): Removed, not used. - (INIT_ACTION): Call emit_line_note only if !ignoring. - (parse_begin_end_block): Do INIT_ACTION even if ignoring. - -Fri Aug 5 12:39:11 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.c (parse_untyped_expr): Add missing semi-colon. - -Thu Aug 4 17:40:38 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.c (parse_untyped_expr): Fix various problem for the - case that we see a '(': Add missing 'case' keyword. - Only recurse if '(' is followed by 'if', 'case' or '[', - and in that case emit a pedwarn (and do a missing NEXT_TOKEN). - - * parse.c (parse_send_action): Remove extra nreverse. - -Thu Jul 28 04:00:11 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * expr.c (build_allocate_global_memory_call, build_allocate_memory_call): - Add new checks. - -Tue Jul 26 22:48:15 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * parse.c (parse_untyped_expr): Added missing "case" before LPRN. - Added a missing call to `require' as well. - -Tue Jul 19 10:30:12 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) - - * lex.l (yywrap): Define as yywrap_chill to avoid conflicts with - the extern declaration in the flex skeleton. - -Mon Jul 18 23:06:04 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * tasking.c (build_copy_number, build_proc_type, expand_send_signal): - Check the type of the instance expr using CH_COMPATIBLE, - and not just == instance_type_node. (This allows - the expression to have mode READ INSTANCE). - * tasking.c (build_instance_type): Give instance_type_node - a non-null novelty (i.e. different from a struct). - * tasking.c (build_receive_case_start, build_delay_case_start): - Check that for a location using CH_LOCATION_P. - -Mon Jul 18 13:22:23 1994 Jim Wilson (wilson@sphagnum.cygnus.com) - - * expr.c (finish_chill_unary_op): Use TREE_SET_CODE not TREE_CODE - to modify a tree code. - -Mon Jul 18 11:24:57 1994 Bill Cox (bill@rtl.cygnus.com) - - * convert.c (digest_structure_tuple): Fix thinko in TREE_CODE - comparison. - -Mon Jul 18 05:40:15 1994 Doug Evans (dje@canuck.cygnus.com) - - * decl.c (warn_bad_function_cast): Define so cc1chill will link. - -Thu Jul 14 18:37:18 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.c (parse_send_action): Do tree_cons *before* checking - for end of loop. - -Mon Jul 11 15:33:52 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * convert.c (digest_structure_tuple): Don't use convert to - coerce initial value, use chill_convert_for_assignment instead. - (Thus we also get range_checking.) - - * expr.c (build_chill_card): Use force_addr_of instead of - build_chill_addr_expr. - - * loop.c (build_temporary_variable): Stylistic tweak. - * loop.c (maybe_make_for_temp): Initialize temp using - explicitly, not using assignment. Avoids a problem if - the expression is read-only. - * typeck.c (smash_dummy_type): Always used the saved TYPE_NAME - and CH_NOVELTY_FLAG. - -Wed Jul 6 20:12:13 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c, ch-tree.h (finish_chill_unary_op): New function, - based on code ripped out of build_chill_unary_op. - (build_chill_unary_op): Call finish_chill_unary_op unless pass==1. - * satisfy.c (satisfy): Call finish_chill_unary_op when needed. - -Mon Jun 27 11:29:18 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * tree.c (save_if_needed), ch-tree.h: New function. - * typeck.c (build_chill_slice_with_range, - build_chill_slice_with_length): Call save_if_neeed on array arg. - * expr.c (varying_to_slice): Re-write to use save_if_needed. - - * typeck.c (extract_constant_from_buffer): Handle BOOLEAN_TYPE. - -Mon Jun 27 01:11:10 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * inout.c (build_chill_io_list_type): Change layout of __tmp_WIO_list - that it is always the same, regardless if compiled with -fpack - or not. - -Tue Jun 14 16:44:14 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lex.l (yywrap): Kludge to work around mis-synchronization - between lexer (which read ahead) and parser: Don't emit - (left-over) uze_seizefile directives at the end of file. - - * typeck.c (build_chill_array_ref): Allow the derived - array indexing syntax for arrays of bit strings. - Add a comment explaining why. - - * typeck.c, ch-tree.h (string_assignment_condition): Change - the interface. Return a boolean expression (which can be - used in a conditional at run-time); never expand anything. - - * actions.c (chill_convert_for_assignment): Check - string_assignment_condition here, rather than in callers. - * actions.c (chill_expand_assignment): Don't need to check - string_assignment_condition here. - * expr.c (build_chill_function_call): Likewise. - * satisfy.c (safe_satisfy_decl): Update accordingly. - * decl.c (do_decl): Simplify testing and conversion by - deferring everything to chill_convert_for_assignment. - - * parse.c: Combine the two variables 'ignore_exprs' and - 'ignore_actions' into one variable called 'ignoring'. - * ch-tree.h: Add 'extern int ignoring'. - * actions.c, except.c, parse.c, tasking.c, timing.c, typeck.c: - Rename ignore_actions and ignore_exprs to ignoring. - Remove unneeded extern declarations. - * expr.c (build_chill_indirect_ref, build_chill_component_ref, - build_chill_arrow_expr, build_generalized_call, build_delay_action, - build_buffer_type, build_event_type): I changed my mind. It is - cleaner to check for 'ignoring' in the parser, rather than here. - * parse.c (parse_action, parse_primval, parse_opt_mode): - Therefore we must check for ignoring here. - * parse.c (parse_loc_declaration): Set ignoring in pass 2 - when parsing the mode. - - * tasking.c (generate_tasking_code_variable): Do arithmetic - on signal_code etc using unsigned rather than signed shorts. - - * grant.c (static char* current_grant_modename): Removed. - * grant.c (decode_decl case CONST_DECL): Remove error message. - - * Make-lang.in (CHILL_SRCS): Add $(srcdir)/ch/parse.c. - * Makefile.in: Fix dependencies for parse.o. - Remove some duplicate dependencies for $(TREE_H). - -Mon Jun 13 14:25:50 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (build_chill_cast): Allow a value cast between - non-discrete object of the same size, but with a pedwarn. - * typeck.c (bit_string_assignment_condition, - char_string_assignment_condition): Merge near-duplicate functions - and place the code in string_assignment_condition. - - * decl.c (parm_flag, declare_parm_level, in_param_level_p): - Removed. Not used. - * decl.c (start_chill_function, finish_chill_function): Make - parameter level have same nesting level as body, as required by Z200. - * decl.c (switch_to_pass_2): Always exit if an error has been found. - * decl.c (pop_module): Copy DECL_SEIZEFILE to a new ALIAS_DECL - generated from GRANT ALL. - * decl.c (lookup_name_for_seizing): Don't seize from - the nesting level of builtins (predefined objects). - * decl.c (lookup_name_for_seizing): Make more robust on error. - - * decl.c (start_chill_function): MAKE DECL_NAME (chill_result_decl) - be 'RESULT' (or 'result'). This makes it more accessible from gdb. - Also, use do_decl to declare it, so that debugging symbols are - generated. And, re-arrange so that actions that need to - be done both passes (such as push_levels) use the same code. - - * parse.c (get_type_of): If ignore_exprs, don't lookup name. - * parse.c (end_function): Fix poplevel params. - * parse.c (expect): Don't read forwards on an error. - * parse.c (parse_field): Don't define two tag_list locals! - * parse.c (parse_pass_1_2): Better error message. - - * parse.c (parse_mode, parse_opt_mode): Have parse_mode call - parse_opt_mode, rather than vice versa. If parse_opt_mode - returns NULL_EXPR, then parse_mode gives an error. - Change parse_opt_mode (and any functions it calls) to only - return NULL_TREE if there is no mode (even on ignore_exprs). - (parse_set_mode, parse_structure_mode, parse_procedure_mode): - Never return NULL_EXPR. - * tasking.c (build_buffer_type, build_event_type): Return - void_type_node instead of NULL_EXPR if ignore_exprs is true. - - * parse.c (parse_synonym_definition): Call parse_untyped_expr - only if we have a mode. - * parse.c (parse_send_action): Parse list of untyped_expr's, - rather than a list of (typed) expressions. - * parse.c (parse_primval): Emit error if '[' seen without - preceding mode name. (If this is to be allowed, call - parse_untyped_expr instead.) - - * parse.c (parse_array_index): Renamed to ... - (parse_index_mode): ... to match Z200 terminology. - Re-write to resolve some of the nastier ambiguities, - and allow things like ' CHAR(10) : CHAR(20) '. - - * parse.c (parse_tuple_element): Change interface to return - reversed list, so don't call nreverse. - * parse.c (parse_tuple): No longer nreverse element list here. - * parse.c (parse_opt_element_list): Do nreverse here instead. - * parse.c (parse_case_label_list): Call nreverse at end. - -Fri Jun 10 15:36:22 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (chill_similar): Remove bogus "else". - -Wed Jun 8 00:01:40 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (TYPE_ARRAY_MAX_SIZE): New macro (and comment) - to make it clearer that we are using TYPE_MAX_VALUE in a special way. - * typeck.c (build_chill_slice): Use TYPE_ARRAY_MAX_SIZE. - * expr.c (chill_expand_expr case CONCAT_EXPR): Likewise. - * convert.c (convert): When converting a fixed string/array - to varying, and we need padding, set the TYPE_ARRAY_MAX_SIZE - of (the type of) the padding. - * convert.c (convert): If the concatenation is non-constant, use - the low-level 'build' to set the type of the result (which is usually - a fixed-size array) rather than depend on build_chill_binary_op - to figure it out (it's unable to simplify the size to a constant). - -Mon Jun 6 18:16:57 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lang.c (lang_decode_option): Let -fspecial_UC imply - -fno-ignore-case without requiring it explicitly. - * lang.c (lang_decode_option): Support (experimentally) - the -fpack and -fno-pack flags. - -Thu Jun 2 20:49:51 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) - - * configure: Add support for --program-prefix and --program-suffix. - -Tue May 31 18:12:00 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * convert.c (digest_constructor): Check that initial value - is compatible with element mode before calling convert. - * typeck.c (chill_compatible): A string mode is not compatible - with an untyped constructor. - * decl.c (do_decl): Clean up error messages. Use error_with_decl. - - * ch-tree.h: Fix inconsistencies: bool_true_node -> - boolean_true_node, and bool_false_node -> boolean_false_node. - * typeck.c (valid_array_index_): Minor simplification. - -Tue May 31 04:33:28 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * inout.c (build_chill_writetext): Add correct processing - of POWERSET RANGE (setmode). - - * lex.l (same_file): Add searching for file(s) in - seize_path_list. - -Fri May 27 14:22:42 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * Make-lang.c (CHILL.mostlyclean, CHILL.distdir): Don't list - yacc/bison output files, since the grammer is no longer in yacc. - * config-lang.in (diff_excludes): Likewise. - -Thu May 26 16:38:13 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * gperf, hash.h, lex.l, parse.h: Rename PROCESS_TYPE token - (in some files spelled PROCESS_TYPE_ to avoid clashes - with the PROCESS_TYPE tree_code) to PROCESS_TYPE_TOKEN. - -Thu May 26 02:18:28 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * timing.c (build_cycle_start): Change call to __define_timeout. - * decl.c (init_decl_processing): Change definitions of - __define_timeout and __wait_timeout. - -Wed May 25 11:53:09 1994 Per Bothner (bothner@kalessin.cygnus.com) - - Replace yacc-based parser with a recursive-decent parser. - (This may seem backwards, but Chill [like C++] is not a - language that is remotely LALR(1). Using a R-D parser - allows us to use look-ahead and to back-up to resolve the - difficult ambiguities.) - * parse.y: Removed. - * parse.c, parse.h: New files, containing new r-d parser. - * Makefile.in: Update accordingly. - * actions.c (chill_convert_for_assignment): Don't return - NULL_EXPR if ignore_exprs is true. It simplifies the parser - if we consistently reserve NULL_EXPR for a missing expression. - * expr.c (build_chill_function_call): Likewise. - - * lex.l: Tweaks for new parser. - * lex.l (prepare_paren_colon, paren_paren_colon_level, - paren_level): Ugly hack no longer needed. - - * expr.c (build_chill_function_call): Cleanup. - Call chill_convert_for_assignment to convert IN/INOUT - paramaters on both input and output. For LOC parameters, - give error if actual is a non-referable location. - * actions.c (convert_for_assignment): Add new parameter (a - "place" string used in error messages). - * actions.c (adjust_parm_or_field): Removed. - * actions.c (chill_expand_assignment): Take just a single LHS, - and move support for multiple assignments to ... - (expand_assignment_action): ... here. Some cleaning up. - * timing.c (build_cycle_start): Adjust accordingly. - * actions.c (expand_assignment_to_varying_array): Likewise. - * tasking.c (many places): Ditto. - * ch-tree.h: Fix declarations appropriately. - - * parse.c (parse_defining_occurrence_list): Return a single - IDENTIFIER_NODE (instead of a singleton list) in the common - case. Minor complication to save a minor amount of space. - * decl.c (do_based_decls): Move guts of code into ... - (do_based_decl): ... this new function. - * decl.c (do_decls): Handle either IDENTIFIER_NODE or a TREE_LIST. - * decl.c (push_syndecl): Replace by ... - (push_syndecl): ... (which only supports a single name). - (push_modedef): Only handle a single name. - * tasking.c (build_process_header, build_signal_struct_type): - Adjust accordingly. - - * expr.c (build_generalized_call): Handle string repetition. - * expr.c (build_chill_repetition_op): Change interface. - * grant.c (decode_constant): Allow parameter list to be - a non-TREE_LIST. (Used for string repetition.) - -Wed May 25 11:28:48 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lex.l (make_identifier): Replaced by ... - (read_identifier, handle_name): ... new functions. - * lex.l: Parse an identifiers using read_identifier using - read_identifier and handle_name, rather than having [f]lex - do it. (One reason is that lex uses a fixed-size buffer.) - - * lex.l (read_directive, skip_directive): New functions. - Use them to parse compiler-directives, instead of rather - ugly and useless use of lexer start conditions. - -Tue May 24 22:36:51 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (unnamed_module_number): Renamed to ... - (module_number): .. and make non-static. - (push_module): Always increment module_number. - * lex.l (yywrap): Print warning if no modules seen. - - * decl.c (pop_module): Don't set DECL_SEIZEFILE of granted - decl to current_seizefile_name (which is unreliable). - * grant.c (chill_grant): Set it here instead. - - * expr.c (fold_set_expr): Use int_size_in_bytes instead of - TYPE_PRECISION (which is not defined for a SET_TYPE). - -Fri May 20 15:21:26 1994 Per Bothner (bothner@kalessin.cygnus.com) - - Cleanup to remove need for variables in common storage. - * decl.c: Remove unused use of current_obstack. - * actions.c (maybe_chill_check_decl): Remove unused function. - * actions.h, lang.c: Remove uses of doing_chill_thang. - * ch-tree.h (void_list_node): Make extern (rather than common). - * decl.c (void_list_node): Add definition. - -Thu May 19 06:54:56 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * configure (build): Build canon_host and canon_target - to pass it to all subsequently generated Makefiles (needed - for testsuite/execute in case of cross build). - -Wed May 18 13:27:12 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * grant.c (decode_mode): Remove. It checks the TYPE_NAME of - the input type, which loses with the no-longer-new 2-pass - implementation, since the input "type" could be an IDENTIFIER_NODE. - * grant.c (raw_decode_mode): Rename to decode_mode. - -Tue May 17 13:19:52 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (chill_location): Neither a STRING_CST nor a - CONSTRUCTOR is a location. - * typeck.c (chill_root_mode): Convert a function to a - pointer-to-function. - * expr.c (build_chill_indirect_ref, build_chill_component_ref, - build_chill_arrow_expr): If ignore_exprs, return operand - rather than NULL_EXPR. This makes it easier for the parser to - distinguish missing expressions. - * expr.c (build_max_min): Convert the lower bound of a - set to a long before calling run-time routine. - * expr.c (build_chill_pred_or_succ): Use discrete_type_p - to check the argument type. - * expr.c (build_chill_arrow_expr): If argument is not a location, - do a predwarn if it is a STRING_CST or has function type. - -Tue May 17 06:05:13 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * configure (build): Remove building of canon_host and canon_target. - It doesn't work in any case. - -Mon May 16 02:10:35 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * configure (build): Build canon_host and canon_target - to pass it to all subsequently generated Makefiles (needed - for testsuite/execute in case of cross build). - * Make-lang.in (chill-runtime): Change chill to CHILL in the case - statement to build chill-runtime automatically. - -Mon May 9 15:30:08 1994 Doug Evans (dje@canuck.cygnus.com) - - * Makefile.in (FLAGS_TO_PASS): Define. - (OBJDEPS): Define. - (../cc1chill): Depend on $(OBJDEPS) $(C_OBJS). - * Make-lang.in (cc1chill): Delete dependency on $(OBJS) $(BC_OBJS). - (CHILL.mostlyclean): Use `mostlyclean' as recursive target. - -Sun May 8 13:05:00 1994 Per Bothner (bothner@cygnus.com) - - * Make-lang.in (cc1chill): Should not depend on libgcc.a. - -Thu May 5 18:58:22 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (copy_lang_decl): New (dummy) function. - -Mon May 2 14:33:44 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.y (sendaction): Fix thinko (in sense of condition). - * tasking.c (build_receive_case_label): Another thinko. - - * parse.y (optsigdest): Force ignore_exprs to 0 while parsing - the (signal-)name. - - * decl.c (build_chill_function_type): Don't call layout_type - (since that may prevent parameter or result types being - properly satisfied). - * satisfy.c (satisfy): Layout FUNCTION_TYPEs. - * parse.y (procmode): Call build_chill_pointer_type, rather - than build_pointer_type (which incorrectly sets TYPE_SIZE). - - * parse.y (get_type_of): Handle TYPE_DECL (again). - * parse.y (optresultspec): Call build_chill_reference_type, rather - than build_reference_type (which incorrectly sets TYPE_SIZE). - * parse.y (range_or_mode): Rename to plain range, since it - no longer matches modename. - * actions.c (chill_handle_case_label_range): New function, with - functionality moved out of chill_handle_case_label. - * actions.c (chill_handle_case_label): Handle here the case that - the label_value is a TYPE_DECL (modename). Also clean up some. - * typeck.c (build_chill_slice_with_length): Convert max_index - to the type of min_value. (Old code broke on varying strings.) - -Sun May 1 13:53:36 1994 Doug Evans (dje@canuck.cygnus.com) - - * Makefile.in (BC_OBJS): Delete all references - (OBJS): Cat ../stamp-objlist to get language independent files. - (../cc1chill): Delete dependency on $(OBJS). - * Make-lang.in (cc1chill): Depend on stamp-objlist. - -Sat Apr 30 14:50:15 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lex.h, lex.c: Remove lastiddecl. - * lex.l (name_type_signal): Simplify. We no longer check for - TYPENAME or SIGNALNAME (which was unreliable with two passes). - Also rename to make_identifier. - * parse.y: Cleaned up grammar to not need SIGNALNAME or TYPENAME. - * Makefile.in (stamp-parse); One conflict fewer! - * parse.y (rccase_label_flag): Moved to tasking.c. - * parse.y (rccase_label): Move most of the logic to - build_receive_case_label in tasking.c. - * parse.y (sendaction): Re-write to not depend on SIGNALNAME. - - * parse.y (name): Do name lookup here (and not in location). - * parse.y: Replace most uses of NAME by higher-level non-terminals: - simple_name_string, name_string, defining_occurrence, or name. - - * tasking.c (build_receive_signal_case_label, - build_receive_buffer_case_label): New functions, split out from - build_receive_case_label. - * tasking.c (build_receive_case_label): Change parameters - and return type. Moved stuff here (from the parser). - * tasking.c (struct rc_state_type): Removed had_errors. - Return error_mark_node instead. - * tasking.c (build_rccase_set_error), ch-tree.h: Removed. - - * expr.c (build_generalized_call): If func is a signal type, - call build_signal_descriptor. - - * parse.y (arrayindex): Renamed to index_mode, to match Z.200. - * parse.y (ioindexmode): Removed; use index_mode instead. - * expr.c (build_generalized_call): If args is a RANGE_EXPR, - we have either a slice or a range mode, depending on func. - * parse.y (index_mode): If we got an 'expr', only allow a name, - or a range mode. - * parse.y (call): A slice with both end points can be a range - mode, so defer handling to build_generalized_call (or index_mode). - - * typeck.c (build_chill_slice_with_length): Fix type-checking. - * typeck.c (chill_novelty): Undo (part of) change of April 28: - The novelty of a range mode is the novlety of the parent. - * typeck.c (chill_root_mode): Don't return integer_type_node - if argument has non-nil novelty. - - * decl.c (global_bindings_p): Return -1 as true, for the sake - of variable_size (in ../stor-layout.c). - -Fri Apr 29 13:42:43 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.y: Remove TYPENAME and modename. These are now plain - NAMEs. Modify parsing actions appropriately. - * expr.c (build_generalized_call): Handle the case that - TREE_CODE (func) == TYPE_DECL (as in a cast). - * lex.l (name_type_signal): Never return TYPENAME. - * parse.y (get_type_of): If pass 1, just return the argument. - - * decl.c (do_decl): If an initializer has the wrong type, - replace it by NULL_TREE, to avoid subsequent errors. - -Thu Apr 28 15:21:56 1994 Wilfried Moser (moser@rtl.cygnus.com) - - * Makefile.in: Add new file timing.c to rules. - * timing.c: New file. Implements the timing actions AT, - CYCLE and AFTER. - * decl.c (init_decl_processing): Add new builtin function - descriptions. - * expr.c (build_chill_indirect_ref): Change error message and - add check agains an IDENTIFIER_NODE. - * gperf, hash.h: Change EVENT_CODE, BUFFER_CODE to IGNORED_DIRECTIVE. - They are no longer needed. - * grant.c (print_integer_type): Add processing of builtin types - DURATION and TIME. - * lex.l: Remove processing of directive EVENT_CODE & BUFFER_CODE. - * parse.y (timingactions): split up to afteraction, ataction - and cycleaction. - * parse.y (afteraction): New rule. - * parse.y (ataction): New rule and put actions in. - * parse.y (cycleaction): New rule and put actions in. - * parse.y (sendaction): Add code for SEND buffer. - * parse.y (rccase_label): Change error processing. - * tasking.c (build_gen_inst): More checks. - * tasking.c (build_gen_code): Add checking for argument is a - PROCESS or a SIGNAL. - * tasking.c (struct rc_state_type): Add new fields for easier - error processing. - * tasking.c (build_receive_case_if_generated), ch-tree.h: New function. - * tasking.c (build_rccase_set_error), ch-tree.h: New function. - * tasking.c (build_receive_case_label): Add processing of BUFFER's. - * tasking.c (build_receive_buffer_case_end, build_receive_signal_case_end): - New functions to process the end of a RECEIVE CASE action in case - of BUFFER's and SIGNAL's. - * tasking.c (build_receive_case_end): Do only general processing and - call one of the above mentioned functions. - * tasking.c (build_delay_case_start, build_delay_case_label, - build_delay_case_end): Rewritten due to new implementation of events. - * tasking.c (build_delay_action): Rewritten due to new implementation - of EVENT's. - * tasking.c (expand_send_buffer), ch-tree.h: New function. - * timing.c (build_at_action, build_cycle_start, build_cycle_end), - ch-tree: New functions. - -Thu Apr 28 14:11:29 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (smash_dummy_type): Handle the special case of a - NEWMODE of a range mode, as required by Z200, by creating a - new parent mode with the new novelty (and casting the min - and max of the range to teh new parent mode). - * typeck.c (chill_novelty, chill_root_mode): Remove special - kludges for of NEWMODE ranges. - * expr.c (build_chill_lower_or_upper): New function, combining - the "guts" of build_chill_lower and build_chill_upper. - * expr.c (build_chill_lower_or_upper): Simplify; no longer - need to kludge the novelties. - - * typeck.c (valid_array_index_p): A string index expression - need not be Compatible with the index type; only similar. - - * decl.c (layout_chill_variants): If error seen, skip stuff - (rather than aborting or crashing). - * decl (push_modedef): If newdecl's type is an error mark, - continue rather than aborting. - -Thu Apr 28 02:07:42 1994 Doug Evans (dje@cygnus.com) - - * Make-lang.in: Update of directory reorg from fsf. - * config-lang.in: Ditto. - -Mon Apr 25 13:09:46 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (chill_similar): Check RECORD_TYPEs properly, - * convert.c (convert): If all else fails, just call convert1. - Thus we can now convert RECORD_TYPEs (assuming they are similar). - - * parse.y, lex.l: Remove BUFFERNAME (use location/expr instead). - * parse.y: Re-do BUFFER handling (similar to previous EVENT change). - * grant.c (raw_decode_mode): Re-do BUFFER mode handling. - * ch-tree (lang_type_record): Removed max_queue_size field. - * tasking.c (build_buffer_type): Re-write. - * tasking.c (max_queue_size): Fix to support buffer modes. - * tasking.c (buffer_element_mode), ch-tree.h: New function. - * tasking.c ch-tree.h (expand_send_buffer): Now has 3 parameters. - * parse.y (modename): No longer match SIGNALNAME. Instead, add it - to name and simple_name_string. This removes a reduce/reduce conflict. - * Makefile.in (stamp-parse): Expect fewer conlicts. - - * lex.l (yywrap): Move check for circularly seizeing current - grant-file from here ... - * lex.l (handle_use_seizefile_directive): ... to here. - This is to avoid calling stat on a not-yet written grantfile, - now that we're using same_file (which calls stat). - * grant.c (set_use_this_gf): Removed. - * grant.c (set_default_grant_file): Set grant_file_name here, - because we need it earlier (due to above lexer change). - - * typeck.c (layout_chill_struct_type): Remove useless code to - remove zero-width bitfield (which messes up CONST_DECLs). - -Sat Apr 23 13:16:39 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (check): Assure that 'ld' is available before checking. - -Thu Apr 21 13:23:54 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * grant.c (print_an_int): Removed. - (raw_decode_mode): Generalized to use decode_constant - instead of print_an_int. - (decode_constant): Print directly, instead of calling print_an_int. - * parse.y (event_list): Fix syntax. - * parse.y (optqueuesize): Default is NULL_TREE, not zero. - * tasking.c (check_queue_size): New function, for error checking. - * ch-tree.h: Add declaration for check_queue_size. - * satisfy.c (satisfy case RECORD_TYPE): Satisfy constant fields - (used for queue size of EVENT and BUFFER), and call check_queue_size. - -Tue Apr 19 13:42:41 1994 Per Bothner (bothner@kalessin.cygnus.com) - - Re-implement EVENT modes to support general EVENT objects - (and not just EVENT names), according to Z200. (Not finished!) - * tasking.c, ch-tree.h (max_queue_size): New function. - * parse.y (dcalternative, event_list, event_list_head): New - implementation of DELAY CASE, avoiding parsing ambiguities. - (call, locdec, delayaction): Remove old EVENTNAME kludges. - * lex.l (name_type_signal): Remove EVENTNAME recognition. - * tasking.c (build_event_type): Re-written. - * typeck.c (chill_similar), decl.c (print_lang_type): - Use new max_queue_size function. - * typeck.c (layout_chill_struct_size): Ignore CONST_DECL. - * tasking.c (build_delay_action): Preliminary changes - just to - make it compile. FIXME! - * grant.c (raw_decode_mode): Use new max_queue_size function. - Move EVENT support from LANG_TYPE to RECORD_TYPE. - * ch-tree.h (process_event_decls): Removed. - -Tue Apr 19 11:44:01 1994 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: Complete previous change - eliminate all - references to objdir as a user parameter. - -Mon Apr 18 10:17:55 1994 Bill Cox (bill@cygnus.com) - - * Makefile.in (check): Simplified regression.sh call. - * regression.sh: Change command-line parsing. Default - srcdir to the script's path. Calculate objdir - internally - don't pass it in. - -Thu Apr 14 13:30:19 1994 Wilfried Moser (moser@phishhead.cygnus.com) - - * expr.c (build_chill_duration): Add range checking. - - * lex.l (init_lex): Add predefined names DURATION and TIME. - * lex.h (enum rid): Add RID_DURATION and RID_TIME. - * ch-tree.h: Add prototypes and externals. - * decl.c (init_decl_processing): Add builtin function - descriptions. - * expr.c (build_generalized_call): Add processing of some - builtin's. - * expr.c (build_chill_abstime): New function to process builtin - ABSTIME. - * expr.c (build_chill_inttime_type): New function to built type - for the INTTIME builtin. - * expr.c (build_chill_inttime): New function to process builtin - INTTIME. - * expr.c (build_chill_duration): New function to process builtin's - MILLISECS, SECS, MINUTES, HOURS and DAYS. - -Tue Apr 12 11:55:45 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * lex.l (chill_same_grant_file): Rename to same_file. Change to - take two files names rather than two DECLs. Also check that the - filesystems (st_dev) are equal. Finally, make static. - * lex.l (handle_use_seizefile_directive): Check for duplicate - USE_SEIZE_FILE directives using same_file. - * decl.c (pop_module): Remove dubious call to chill_same_grant_file. - -Sun Apr 10 17:19:56 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c, ch-tree.h (chill_result_decl): New variable. Used to - store RESULT value. (Cannot use DECL_RESULT; see comment in decl.c.) - * actions.c (chill_expand_result, chill_expand_return): - Use chill_result_decl appropriately. - * ch-tree.h, decl.c, actions.c (saved_result_rtx): Removed. - Subsumed by chill_result_decl. - - * expr.c (chill_expand-expr case CONCAT_EXPR): Generate temporary - using the mode of the result type, and don't assume it is BLKmode. - -Fri Apr 8 17:46:13 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * actions.c (chill_expand_assignment): Check for compatibility - _after_ "expanding out" a binary operation. This fixes - the case "STRING //:= CHAR". - - * lex.l (equal_number): Convert symbol to integer_type_node, to - force the value to be INT-derived (and avoid novelty conflicts). - -Mon Apr 4 22:06:31 1994 Per Bothner (bothner@cygnus.com) - - * ch-tree.h (CH_FUNCTION_SETS_RESULT): New flag. - * ch-actions.c (chill_expand_return), ch-tree.h: Extra - parameter, indicates if implicit return at end of function. - * ch-parse.y: Modify accordingly. - * ch-actions.c (chill_expand_return): Various improvements. - - * decl.c, ch-tree.h (result_never_set): New variable. - * actions.c (chill_expand_result, chill_expand_return): Clear it. - * ch-parse.y (end_function): Warn if no RETURN or RESULT action. - - * decl.c, ch-tree.h (saved_result_rtx): New variable. - * decl.c (start_chill_function): Use saved_result_rtx as return - value if there is a RESULT in a REG that might get clobbered. - * actions.c (chill_expand_result): Save result in saved_result_rtx - or assign to DECL_RESULT as appropriate. - * decl.c, ch-tree.h (current_function_returns_value, - current_function_returns_null, current_extern_inline): - Don't use. Only define first two to allow linking with ch-typeck.c. - - * typeck.c (chill_l_equivalent): Add forward declaration. - -Fri Apr 1 11:02:27 1994 Wilfried Moser (fs_moser at rcsw47) - - * lex.l (readstring): Handle control sequence in all cases (Z.200 - 5.2.4.4 page 54). - -Fri Apr 1 13:11:27 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * configure: Simplify and fix the logic for looping through - sub-directories. - -Thu Mar 31 18:59:57 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (CH_L_EQUIVALENT): Moved from typeck.c. - * typeck.c (chill_similar): Add support for checking - FUNCTION_TYPEs for similarity. Also, treat - pointer-to-function-type the same as function-type. - -Thu Mar 31 11:22:56 1994 Wilfried Moser (fs_moser at rcsw47) - - * ch-tree.h: Change prototype of function expand_send_signal. - * parse.y: Change calls to expand_send_signal. - * tasking.c (expand_send_signal): Change handling of optsetto - argument. New argument signame to get a possible destination - process for the signal. - -Wed Mar 30 14:54:48 1994 Wilfried Moser (fs_moser at rcsw1j) - - * tasking.c (make_process_struct): Change error message in case of - a process argument has other attribute then IN or LOC. - * tasking.c (build_start_process): Add check that the optset is - referable in case it is specified (this makes - noncompile/start_.ch working). - -Tue Mar 29 13:24:27 1994 Wilfried Moser (fs_moser at rcsw1h) - - * Makefile.in: Change version string to 1.2.1 - * ch-tree.h (enum chill_built_in_function): Delete no longer valid - entries. - * ch-tree.h: Change prototype for build_chill_readtext. - * decl.c (init_decl_processing): Add builtin_function _readstring, - _readunixstd and READTEXT. - * expr.c (build_generalized_call): Add processing of READTEXT. - Delete handling of no longer valid builtin_functions. - * gperf: Remove keyword READTEXT. - * parse.y: Remove token READTEXT. - * inout.c (build_chill_io_list_type): Add building type for - READTEXT. - * inout.c (build_chill_readtext): Implement the function - (partial). - * inout.c (build_chill_writetext): Do some cleanups. - -Tue Mar 29 12:30:59 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (build_chill_cast): Re-arrange, to support casts - of const integer to type of different size, if there is - an integral type of the desired size: Go through the - const conversion code. - - * actions.c (adjust_parm_or_field): Move support for LOC to ... - * expr.c (build_chill_function_call): ... here. - Fix a number of bugs in OUT/INOUT handling. - - * ch-tree.h, actions.c (adjust_parm_or_field), grant.c (print_struct), - parse.y (location), typeck.c (chill_comptypes): Remove unused - support for ENCAPSULATED_ARRAY_P. - * typeck.c (build_chill_array_parm_type), ch-tree.h: Remove; unused. - - * ch-tree.h, decl.c (shadow_record_fields), decl.c - (shadow_record_fields), expr.c (chill_expand_case_expr, - build_chill_function_call), grant.c (chill_finish_compile), - typeck.c (build_empty_string, build_init_struct): Rename magic - identifiers of the form "<...>" to "__..." for better portability. - - * actions.c (adjust_parm_or_field): Remove extraneous - call to build_chill_repetition_op. - * expr.c (build_chill_function_call): Some simplifictions - (since neither valtail nor typetail can be NULL). - Clean up error message for OUT//INOUT not location to use only 1 line. - Add error message for OUT/INOUT if type is READonly. - * typeck.c (build_chill_modify_expr): Simplify. - -Sun Mar 27 19:30:25 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Clean up generally. Assure that - runtime is built before running regressions. - Build correct parameters to regression.sh. - Remove a lot of 'clean' cruft. - * Make-lang.in, config-lang.in: New files for - subdirectory architecture. - -Sat Mar 26 10:39:12 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (check): Build correct parameters for regression.sh. - -Fri Mar 25 10:13:06 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Also mark regression.awk3 as executable. - * regression.sh: Add comments about command-line options. - Calculate srcdir correctly, defaulting to the script's path. - Add OPT flag to pass to the Makefiles, to specify the - compiler's optimization level, and -O and -O2 options. - Delete GLOBAL flag and tests. Use a different make.log - file for optimized and unoptimized test results. Add the - compiler's host and target triples to the report header. - -Wed Mar 23 21:41:26 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_chill_function_call): Handle INOUT and OUT - parameters better (for the rangefail test, at least). - -Wed Mar 23 14:13:45 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * regression.sh (srcdir, objdir): Fixed hard-wired paths. - (grep args): Changed [XYZ-] to [-XYZ] for SCO. - -Wed Mar 23 13:34:18 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_generalized_call): Revert previous change. - To do this correctly, we need a new parsing mechanism, and - C++ initializer technology. - -Wed Mar 23 09:34:50 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_generalized_call): Be sure we're inside the - module-level function before calling build_gen_inst, for - example. - -Wed Mar 23 09:34:50 1994 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh (dodirectory): Count the gcov and abort tests - among the .dat files. - -Tue Mar 22 15:39:38 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * satisfy.c (safe_satisfy_decl): When checking that a SYN - value fits in a specified discrete type, don't convert first, - and use compare_int_csts instead of tree_int_cst_lt. - -Tue Mar 22 15:25:38 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Generate better .gdbinit files. - -Tue Mar 22 11:59:38 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * actions.c (check_range): Don't emit dynamic checks - if not current_function_decl. - - * parse.y (arrayindex): Allow expr (error is emitted - at semantic level if not the NAME of a type). - * typeck.c (build_chill_cast): Re-enable some casts. - * satisfy.c (safe_satisfy_decl): Remove redundant CONST check. - -Tue Mar 22 11:46:28 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Access the utils directory correctly. - * expr.c (build_compare_expr): Reenable compatibility test. - -Tue Mar 22 11:24:45 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (valid_array_index_p): Call - build_compare_discrete_expr instead of build_compare_expr. - * typeck.c (build_chill_cast): Improve logic. - * satisfy.c (safe_satisfy_decl): Simplify test. - -Tue Mar 22 10:17:58 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c (chill_expand_assignment): Correct detection of - string assignment case. - * expr.c (chill_expand_expr): Now that we're using build_chill_function_call, - the actual parameters need to be converted to the unsigned long - type explicitly. Do that. - * satisfy.c (safe_satisfy_decl): Correct range-checking code. - -Mon Mar 21 16:25:07 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Correct prediction of grammar conflicts. - * actions.c(check_range): Fix reference to NULL_TREE pointer. - And allow compile-time errors even if range_checking is off. - * parse.y: Clean up some comments. - * satisfy.c (safe_satisfy_decl): Add range-check for a SYN's value. - -Mon Mar 21 13:29:23 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (layout_chill_range_type): Instead of tree_int_cst_lt - use compare_int_csts (which is more robust when signedness differs). - Also, convert the bounds *after* doing range checking. - - * ch-tree.def (SET_IN_EXPR): New. - * expr.c (chill_expand_expr): Code to expand SET_IN_EXPR, - moved from expand_expr in ../expr.c. Also add some extra - conversions (because we're now using build_chill_function-call). - * actions.c, decl.c, expr.c, grant.c, parse.y, typeck.c: - Use SET_IN_EXPR in place of IN_EXPR. - - * expr.c (build_compare_discrete_expr), ch-tree.h: New function, - with code moved from build_compare_expr. - * expr.c (build_compare_expr): Re-enable compatibility test. - -Mon Mar 21 11:02:33 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Rewrite byacc related rules. - * actions.c (chill_convert_for_assignment): Use the - referenced type only for generating range checks. - * configure: Add 'utils' directory to SUBDIRS variable. - -Sun Mar 20 21:49:59 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c (check_range): Call build_compare_expr rather than - build_binary_op. - (adjust_parm_or_field): Call convert_for_assignment rathern than - convert, to get the range-checking. - * expr.c (build_chill_pred_or_succ): Fix up rangefail code. - Generate a compile-time message if possible. - (build_compare_expr): Comment out compatibility test - should - not be needed in here. Fix a couple of typos. Add some types - to some build calls. - -Sun Mar 20 11:48:10 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * decl.c (init_decl_processing): Clean up parameter type - list for __setbitpowerset, - - * typeck.c (chill_compatible_classes): Allow the M-reference - to be compatible with the N-value class, with suitable M and N. - * typeck.c (build_chill_slice): Don't smash a void TREE_TYPE. - (We don't need to, and it causes confusion.) - - * expr.c (build_compare_expr): Fix thinko. Add save_exprs. - - * expr.c (build_compare_expr): Fix a transcription bug - (for converting NULL INSTANCEs). Also #include convert.h. - - * expr.c (compare_int_csts): New. Compare INTEGER_CSTs. - Works even if their types have different TREE_UNSIGNED. - * expr.c (finish_chill_binary_op): Moved code dealing with - the comparison operators from here ... - * expr.c (build_compare_expr): ... to new function here. - Also, for discrete types, tries to Do The Right Thing, even for - differing values of TYPE_PRECISION and TREE_UNSIGNED. - the code from lay - * ch-tree.h: Declare new functions. - * typeck.c (valid_array_index_p): Various cleanups, - including using new build_parse_expr. - * parse.y: Use new build_compare_expr. - - * inout.c (build_chill_writetext): Handle REFERENCE_TYPE args. - -Sun Mar 20 08:54:27 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c (expand_assignment_to_varying_array): - Call build_chill_array_ref to get index checking. - (chill_convert_for_assignment): Delete unused errstr - variable. - (chill_expand_assignment): Call build_chill_array_ref - to get runtime index checking. - (expand_varying_length_assignment): Use new interface - to varying_array_index_p. - * ch-tree.h (varying_array_index_p): New proto. - * convert.c (convert): Call build_chill_array_ref - to get runtime index checking. - * expr.c (build_chill_pred_or_succ): Fix cond tree - to have consistent operand types. - * typeck.c (valid_array_index_p): Change interface to pass - validity conditions back on caller's TREE_LIST. We - cannot link the conditions to anything which a - layout_type routine will expand, since that will occur - before the exception handler is set up. - Change calls to valid_array_index_p also. - -Fri Mar 18 14:40:50 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * actions.c, except.c, loop.c, tasking.c: Call - build_chill_function_call instead of the C-specific - build_function_call. - * except.c (initialize_exceptions): Fix parmtype of __builtin_setjmp. - * loop.c (top_loop_end_check): Coerce library function arg. - * convert.c, expr.c: Re-write to avoid calls to C-specific - function build_unary_op (e.g. by calling build1 directly). - - * typeck.c (chill_equivalent): Change to force failure - for non-matching integral types (even if not ranges). - - * typeck.c, ch-tree.h (build_chill_slice): Make non-static. - * expr.c (varying_to_slice): Call build_chill_slice (and not - build_chill_slice_with_length, which does bunches of range - checking and does not allow the length to be zero). - * convert.c (convert): Fix off-by-one error. - * actions.c (chill_expand_array_assignment): Minor cleaning up. - -Fri Mar 18 00:12:48 1994 Per Bothner (bothner@deneb.cygnus.com) - - * decl.c (init_decl_processing): __lepowerset and __ltpowerset - take *two* pointer parameters, not one. - * satisfy.c (satisfy): Only call the appropriate layout routine - if TYPE_SIZE is 0 (i.e. type hasn't already been laid out). - * typeck.c (build_chill_slice_with_length): Fix Bill's previous fix. - -Thu Mar 17 17:29:43 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_chill_function_call): Give function call the correct - type tree. - * typeck.c (build_chill_slice_with_length): Restore dynamic range - checking, so it doesn't obscure the CONSTANTness of the length. - -Wed Mar 16 17:23:31 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (build_chill_slice), expr.c (chill_expand_expr - [case CONCAT_EXPR]): Remove kludge setting slice size upper bound - in TYPE_LANG_SPECIFIC, and restore kludge setting it in MAX_VALUE. - * typeck.c (build_chill_slice): Use TYPE_MAX_VALUE of - array_type if needed for size upper bound of slice_type. - * expr.c (build_concat_expr): Improve calculation of size upper bound. - - * typeck.c (valid_array_index_p): Check compatibility using - correct types. - * typeck.c (build_chill_slice_with_length); For now revert - calling valid_array_index_p on length. (It makes it harder - to realize when the slice is constant length.) - * expr.c (build_chill_indirect_expr): Minor tweak. (This - seems to work around a weird C compiler bug. ??) - - * expr.c (build_chill_function_call): Cleanup so it doesn't - call build_function_call (in c-typeck.c). - * typeck.c, expr.c: Use build_chill_function_call instead of - build_function_call (in c-typeck.c). - - * parse.y (discrete_mode): Move some of the rules from - non_array_mode into new non-terminal. - (arrayindex): Use discrete_mode (with NAME and TYPENAME) to - avoid some misparses. - * ch-tree.h (SLICE_PTR, SLICE_LENGTH): Removed; unused. - * convert.c (digest_structure_tuple): Add missing parameter. - * decl.c (comptypes): Remove unused prototype. - * decl.c (build_chill_function_type): Handle NULL return_type - correctly (convert to void_type_node). - * decl.c (init_decl_processing): layout boolean_type_node *after* - we've set it's TYPE_MIN_VALUE and TYPE_MAX_VALUE. - -Wed Mar 16 16:08:22 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.h: Add prototype. - * convert.c (convert): Correct calculation of padding length. - * decl.c (grok_chill_fixedfields): Move ignore_exprs test to - parse.y where it belongs. This permits the removal of a kludge - in make_process_struct. - * lex.l, parse.y: Call to_global_level for several errors. Add - code to output error in only one pass. - * tasking.c (make_process_struct): Delete kludge inserted on - March 8. - (build_receive_case_end): Add Wilfried's check for errors. - -Tue Mar 15 08:42:12 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c: Fix comment. - (build_rts_call): Ifdef it out - never used. - (expand_varying_length_assignment): call valid_array_index_p. - rather than validate_varying_array_ref. - * ch-tree.h: Fix prototype for valid_array_index_p. - * expr.c (chill_expand_expr): Call build_chill_array_ref to get - index validation. - (build_hill_lower, build_chill_upper): Return value now inherits - the novelty of the input parameter. - (varying_to_slice): Use CH_NOVELTY macro rather than calling - chill_novelty directly. - * grant.c (newstring): Make len unsigned and cast xmalloc parameter - to unsigned. - (print_integer_type): Pass string value as APPEND's second parameter. - (decode_decl): Pass a boolean expression as print_proc_tail's - first parameter. - (chill_finish_module_code): Make xmalloc's parameter unsigned. - * lex.l: Pass sizes to xmalloc as unsigned ints. Pass second - parameter to in_word_set as unsigned. - * loop.c (build_loop_start): Check top_loop_end_check return value. - * parse.y: Add casts to int for third do_decls parameter, fifth - build_loop_iterator parameter, etc. - * tasking.c (build_receive_case_end): Chack cond_stack before popping. - * typeck.c (validate_varying_array_ref, chill_max_vary_array_index, - valid_array_index): Delete them. They're now unused. - (valid_array_index_p): Add function, call it everywhere that an - array index is checked. - (build_chill_slice): Restore old functionality where varying_to_slice - is called to handle slices of varying arrays, rather than handling - handling them here. - (build_chill_slice_with_range, build_chill_slice_with_length): - Check range limits for TREE_CONST before calling tree_int_cst_lt. - Delete now-obsolete checks of constant indices. - -Mon Mar 14 17:26:51 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.y (modeless_expr): New rule to allow ([...]) and (if...) - to count as untyped_exprs. (This is not really permitted by the - Blue Book, but has been requested by customers.) - -Thu Mar 10 10:11:02 1994 Bill Cox (bill@rtl.cygnus.com) - - * chill.texi: Document new command-line options. - * expr.c (build_chill_num): Set unsigned parameter for - type_for_size call correctly (unsigned for enums). - * lang.c (lang_decode_option): Add command-line options to - enable/disable runtime range-checking. - * lex.l: Eat more whitespace. - -Thu Mar 10 09:41:37 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Have rules to make parse.h, y.tab.c and other - derived files. This allows the gcc/configure list of CHILL - files machinery to work. - * ch-tree.h (permanent_allocation): Add a parameter flag. - * decl.c (finish_chill_function, finish_decl): Provide the - new permanent_allocation flag. - (poplevel): Return early, avoid a seg fault. - * lex.l (NORMAL): Replace this whole state with the predefined - INITIAL state. Force compilation state to global level after - compiler directive error - prevents endless loop on error. - (handle_use_seizefile_directive): Rewrite for readability. - (chill_same_grant_file): Reindent. - Generally handle whitespace differently. - * regression.prpt: Print ten PR numbers per line. The report's - getting too long. - -Wed Mar 9 09:58:51 1994 Bill Cox (bill@rtl.cygnus.com) - - * decl.c (do_decl): Suppress the string-assignment-condition - error - it was too often seen. - * expr.c (expand_chill_expr): In CONCAT_EXPR, when argument has a - runtime-changing length (as in a slice), get the parent array's - allocation size from its type tree. - * typeck.c (build_chill_slice): Support VARYING arrays. Pass - parent array's static allocation size along in the slice type. - -Wed Mar 9 08:54:24 1994 Bill Cox (bill@rtl.cygnus.com) - - * lex.l (name_type_signal): Avoid dereferencing a NULL TRE_TYPE. - -Tue Mar 8 11:51:10 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_chill_sizeof): Fix typo in error msg, add - some whitespace. - * lex.l (name_type_signal): Add debug output. - * parse.y (call): Allow EVENTNAME and BUFFERNAME parameters - to a call, so that SIZE () works on them. - * tasking.c (make_process_struct): Force ignore_exprs non-zero - when processing a SEIZEd PROCESS declaration. This prevents - grox-fixed_fields from returning a NULL, and indirectly protects - the chill_integer_type_node tree from corruption. - -Mon Mar 7 19:14:05 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Use the 'all' target to build the runtime - library and chillrt0.o. - * README: Explain rules for files in this directory. - * addtest, addtest.man, build-release, - chill.regress.cron: Move to utils subdirectory. - * expr.c (build_chill_function_call): Mark the INOUT - temporary so it doesn't get optimized into a - register. Fixes the execute/inout.ch bug. - * typeck.c (layout_chill_range_type): Restrict it - from complaining about an empty string type's - bounds (0:-1). - -Mon Mar 7 09:06:39 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (compiler): Restore this target. - (OBJS, BC_OBJS): Delete unused variables. - Add $(FLAGS_TO_PASS) to sub-make invocations. - * ch_decomment.l, ch_makedepend, chill.patches, printf.c, - tcov.awk, tcov.el, tcov.sh: Move to utils subdirectory. - -Sat Mar 5 18:37:50 1994 Jim Wilson (wilson@sphagnum.cygnus.com) - - * except.c (finish_handler_array): When computing address of - the array ex_decl, don't call build_array_ref. - -Sat Mar 5 17:43:36 1994 Jim Wilson (wilson@sphagnum.cygnus.com) - - * loop.c (declare_temps): Force powerset temp to memory. - -Fri Mar 4 11:20:44 1994 Bill Cox (bill@rtl.cygnus.com) - - * typeck.c (layout_chill_range_type): Convert highval and - lowval to a common type before range-checking them. - -Fri Mar 4 11:20:44 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.h: Add loop-related prototypes. - * decl.c, grant.c: Fix -Wall violations. - * parse.y: Fix format of %type directives. - -Fri Mar 4 10:04:18 1994 Wilfried Moser (fs_moser at rcsw1h) - - * Makefile.in: Update version number. - * expr.c: Fix a comment. - * inout.c (build_chill_writetext): Add handling of a REAL. - * lex.l (INITIAL): Remove all code to discard 'header lines'. - no longer needed. - * parse.y (optheader): Remove - it's obsolete, as is the - HEADEREL token definition. - -Fri Mar 4 09:41:18 1994 Bill Cox (bill@rtl.cygnus.com) - - * addtest: Fix suffix removal when suffix is .c186. - * regression.sh: Allow for underscores on PR filenames. - * typeck.c: Check in the rewrite mentioned earlier. - -Thu Mar 3 09:42:10 1994 Wilfried Moser (fs_moser at rcsw1h) - - * tasking.c (build_process_header): Build a debug structure - for easier access to PROCESS parameters. - -Thu Mar 3 09:42:10 1994 Bill Cox (bill@rtl.cygnus.com) - - * typeck.c (*string_assignment_condition): Complete rewrite - of a verbose first draft. - -Wed Mar 2 16:49:05 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c (adjust_return_value): Simplify. - Delete references to CH_RETURNS_LOC, extra parameters to - push_extern_function and start_chill_functions. - (convert_for_assignment): Check whether to generate runtime - range-checking code. Handle reference_type in convert call. - (chill_expand_assignment): Produce an INDIRECT_REF for a - reference_type on the LHS. Delete conversions subsumed by - convert_for_assignment. - * ch-tree.h: Delete parameters from prototypes. - * decl.c (print_lang_decl): Print out signal flag. - (push_extern_function, start_chill_function): Delete - extra parameters, references to CH_RETURNS_LOC. - * grant.c (chill_finish_compile): Delete extra parameter. - * parse.y: Delete references to CH_RETURNS_LOC, extra parameters to - push_extern_function and start_chill_functions. - * regression.sh (checkprms): Skip PRMS discrepancies if we - can't access PRMS for some reason. - * satisfy.c: Correct indentation. - * tasking.c (build_process_header): Delete extra parameters - passed to push_extern_function and start_chill_functions. - -Wed Mar 2 10:33:50 1994 Bill Cox (bill@rtl.cygnus.com) - - * addtest: Require a fill filename. Be more careful about - adding the same test twice. - * expr.c: Add FIXME to comment. - * regression.sh: Add configure script call. - -Tue Mar 1 16:24:20 1994 Wilfried Moser (fs_moser at rcsw1h) - - * Makefile.in: Change version of chill to 1.1.2 - * inout.c: Add processing of SET and POWERSET types to WRITETEXT. - -Tue Mar 1 07:34:56 1994 Bill Cox (bill@rtl.cygnus.com) - - RETURN of LOC value is only half-baked. Stay tuned... - * actions.c (adjust_parm_or_field): Add to comment. - (adjust_return_value): New function for issuing errors about - RETURN and RESULT expressions. Also converts them. - (chill_expand_result, chill_expand_return): Call new - adjust_return_value function. - * ch-tree.h (CH_RETURNS_LOC): Add new flag for function types. - New parameter for push_extern_function and start_chill_function. - * decl.c (push_extern_function, start_chill_function): New parameter - to say whether return value is a LOC. - * expr.c (build_chill_indirect_ref): Further qualify the issuing - of the error message. - * grant.c (raw_decode_mode): Move test for instance mode under - STRUCT handling. - (start_chill_module_code, chill_finish_compile): Add new - parameter to start_chill_function calls. - * parse.y (get_type_of): Do lookup_name more often. - (quasi_pdef, procedure, procmode, optresultspec): Set - CH_RETURNS_LOC flag. - (optresultattr): Code keywords as a bitmask. - * tasking.c (build_process_header): Add new parameter to - start_chill_function call. - -Sat Feb 26 12:49:05 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Replace undefined $(RM) with rm -f. - * configure: Make sure scripts are executable. - * regression.sh: Make variables to invoke make - and awk. Don't process a directory if it - doesn't exist. - -Fri Feb 25 14:48:48 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (check): Force the building of ../gcov and - ../xgcc before testing. Move the printf dependency here - since we don't need it until we're testing. - * addtest: Strip suffix from each input filename. - * decl.c (do_decl): Correct error checking. Call - string_assignment_condition for some of it. - * tasking.c (build_gen_inst): Add ability to pass an integer - for either the process ID or the copy number. If a number - is passed, range-check it against the CHILL unsigned type - limits. - (build_buffer_descriptor): Add draft code to check the buffer - name for correctness. - -Wed Feb 23 15:07:12 1994 Per Bothner (bothner@kalessin.cygnus.com) - - New cleaner solution to the following problem: - Chill allows an action to be followed by an ON-handler. - But we don't know if an action has a handler until we've parsed - its end, yet we want to generate extra code to set up an - exception handling contour only if needed. The old solution - would generate code for the action into an rtl sequence, and then - splice in the exception-setup code if we later found we needed it. - This has a few problems (for example it confuses the management - of stack temporaries), and is ugly. Now that the compiler is 2-pass - we have a cleaner solution: In pass 1, we remember which actions - were followed by ON-handlers. In pass 2, we use this information - to generate appropriate code before an action. - * except.c (push_handler, pop_handler): In pass 1, set up data - structures (global_handler_list) to remember if an action has an - ON-handler. In pass 2, digest this information, and setup - handler if needed. - * except.c, actions.h (pop_handler): Take an extra int arg. - * except.c (emit_setup_handler): New function, with code (moved - from chill_start_on) to emit code before an action that has a handler. - * except.c (except_init_pass_2): New function. - * parse.y (pass1_2): Call except_init_pass_2 before pass 2. - * parse.y (POP_UNUSED_ON_CONTEXT): Don't call pop_sequence. - * parse.y: Invoke POP_UNUSED_ON_CONTEXT and POP_USED_ON_CONTEXT - in pass 1 as well as pass 2. - * parse.y (BEGIN ... END): Re-arrange logic to avoid block_stack - (local to ../stmt.c) getting out of sync. - * actions.c (push_action): Don't need to emit a NOP, - now that we're no longer moving sequences around. - * actions.c (push_action): Call push_handler even in pass one. - -Wed Feb 23 11:06:14 1994 Bill Cox (bill@rtl.cygnus.com) - - * decl.c (do_decl): Check for possible overflow in initializing - a declared variable. - * expr.c (build-chill_indirect_ref): Add error message for - a syntax error that C programmers converting to CHILL are - quite likely to make. - * satisfy.c (safe_satisfy_decl): Keep yesterday's change from - seg-faulting. - -Tue Feb 22 17:54:43 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Use $(CC) rather than FLAGS_TO_PASS, which isn't - defined. Build chill script differently, and build an install script. - Add an action to run the regression test. - * actions.c (chill_expand_assignment): Change - string_assignment_condition call. - * ch-tree.h: Add prototype. - * expr.c (build_chill_function_call): Change - string_assignment_condition call. - * satisfy.c (safe_satisfy_decl): Add check that string INIT value - will fit in the declared mode. - * typeck.c (string_assignment_condition): Add flag to disable - runtime code generation. Add code to generate runtime test. - -Mon Feb 21 14:04:20 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (check): Add target to trigger a regression test. - -Mon Feb 21 13:54:20 1994 Bill Cox (bill@rtl.cygnus.com) - - * decl.c (do _based_decls): Add error check for - decls BASED on a PROC or PROCESS name. - -Mon Feb 21 13:24:02 1994 Bill Cox (bill@rtl.cygnus.com) - - * grant.c (chill_finish_compile): Bypass handling - module-level code if an earlier error has made - is useless. - * tasking.c (build_start_process): Generate error, - return if process name unknown. - -Mon Feb 21 14:29:41 1994 Wilfried Moser (fs_moser at rcsw47) - - * expr.c (build_generalized_call): Use - build_arrow_expr semantics for ADDR () builtin. - -Mon Feb 21 12:49:14 1994 Bill Cox (bill@rtl.cygnus.com) - - * tasking.c (build_gen_inst): Output correct - constructor for GEN_INST. - -Mon Feb 21 08:14:59 1994 Wilfried Moser (fs_moser at rcsw47) - - * lex.l (yywrap): Fix punctuation error. - -Sun Feb 20 19:58:14 1994 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: Fix cvs update-related commands. - Have cron job always perform the update, so it's - always reporting on the current state of the - sources. - * typeck.c (string_assignment_condition): Allow a - mis-match if the LHS is varying. - -Fri Feb 18 18:10:04 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c (expand_chill_assignment): Add call to test the - string assignment condition. - * expr.c (build_chill_function_call): Add call to test the - string assignment condition. - * regression.awk2: Report WITHDRAWN PRs as well. - * regression.sh: Delete extra commentary about FEEDBACK PRs. - * typeck.c (string_assignment_condition): Add function to - perform the check. - -Fri Feb 18 16:30:40 1994 Bill Cox (bill@rtl.cygnus.com) - - * regression.awk1, regression.awk3: Recognize 'withdrawn' PRs - and exclude them from the regression test report. Mark them - in the list of PRs as 'W' status. - -Thu Feb 17 09:13:42 1994 Wilfried Moser (fs_moser at rcsw47) - - * Makefile.in: Define a version number. Build chill script - differently. Makefile depends upon ../configure, not configure. - * chill.in: Define some new flags. - -Wed Feb 16 19:44:33 1994 Bill Cox (bill@rtl.cygnus.com) - - * grant.c (decode_constant): Restore a 'return result' statement - that seems to have gotten lost. - -Wed Feb 16 12:37:44 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (various STRING-type macros): Use new TYPE_STRING_FLAG. - - * typeck.c (make_chill_array_type): Remove unused args. - Simplify to build only one-dimensionsal arrays, so change - index list to single index. Call layout_chill_array_type - if pass!=1. And rename to: build_simple_array_type. - * typeck.c (layout_chill_array_type): Only recurse - if TREE_TYPE has not been laid out. - * typeck.c (build_chill_array_type): Update accordingly. - * typeck.c (build_chill_slice): Replace calls to build_array_type - (which does hash-canonicalization, which breaks if we later set - the TYPE_STRING_FLAG) by calls to build_simple_array_type. - * convert.c (convert): The same. - - * grant.c (decode_constant): Clean up. Remove remnants of switch - on TREE_TYPE of the value, and fold those cases into first switch. - -Wed Feb 16 09:12:21 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Add printf as a dependency of ../cc1chill. - * regression.sh: Make srcdir and objdir really work. - -Wed Feb 16 09:12:21 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_char_array_expr): Fix spelling - error in error msg. - * tree.c (build_string_type): Make check for overlarge - string more robust. - -Wed Feb 16 02:37:43 1994 Mike Stump (mrs@cygnus.com) - - * grant.c (decode_constant): Remove useless tests - for STRING_TYPE (which isn't used by anyone, including CHILL). - -Tue Feb 15 15:35:07 1994 Bill Cox (bill@cygnus.com) - - * build-release: Add refinements to checkout commands. - * decl.c (init_decl_processing): Move initialization of - chill_unsigned_type_node before 1st call to build_string_type. - * tree.c (build_string_type): Add compile-time test of string - allocated length. - * typeck.c (layout_chill_range_type): Add compile-time range limit - checking. - -Tue Feb 15 08:55:37 1994 Bill Cox (bill@cygnus.com) - - * Makefile.in: Add stamp-chill-objs as a dependency of ../cc1chill. - * regression.sh: Rename test directory names. - -Mon Feb 14 09:24:16 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Change interface with parent directory's - Makefile, decoupling the lists of each others' files. - -Mon Feb 14 09:24:16 1994 Bill Cox (bill@rtl.cygnus.com) - - * lex.l: Delete obsolete comment. - * tasking.c (expand_send_signal): Add a type to the OPTSENDTO - instance constructor. - -Mon Feb 14 04:04:16 1994 Bill Cox (bill@rtl.cygnus.com) - - * lex.l (maybe_number): Add octal to numbers - handled by Feb 1 change. - -Sat Feb 12 16:24:22 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c, convert.c, decl.c, expr.c, lex.l, - tasking.c, typeck.c: gcc -Wall cleanups. - * ch-tree.h: Change loop-related prototypes. - * loop.c, parse.y: Rewrite to set up correct loop scope. - Fix error path where loop variable not declared. - -Fri Feb 11 11:12:29 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Add rule to build printf. Make it a dependency - of ../cc1chill. - * printf.c: New tool for regression testing script. - * regression.sh: Look for print in ${objdir}. - -Thu Feb 24 17:31:12 1994 Wilfried Moser (fs_moser at rcsw1j) - - * tasking.c (build_gen_inst): Allow integer expression as argument - 1 to this function. This was a change request to get rid of - unsupported value conversion from INSTANCE to ARRAY (0:1) UINT - or STRUCT (t UINT, c UINT). - -Thu Feb 10 09:49:31 1994 Bill Cox (bill@rtl.cygnus.com) - - * regression.awk3: Recognize upper-case PRMS state names. - -Wed Feb 9 15:26:19 1994 Bill Cox (bill@cygnus.com) - - * parse.y (dowithaction): Allow EXIT from DO WITH. - -Tue Feb 8 13:13:54 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Change to require grant.c for evidence that we've - found the source directory. - * decl.c (init_decl_processing): delete unused builtin_slice - function declaration. - * expr.c (chill_expand_expr): Calculate powerset's length - correctly, calling powersetlen to do it. - * regression.sh: Replace BASE references with objdir references. - * typeck.c (build_chill_slice): Build the compound expression - in the right order. - -Mon Feb 7 15:56:07 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_chill_lower, build_chill_upper): Handle - LOC parameter types. - * regression.sh: Correct path to executable sub-shell-scripts. - -Mon Feb 7 11:33:47 1994 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: Pervasive changes to allow for separate - source and object directories. - -Wed Feb 2 17:5620 1994 Bill Cox (bill@rtl.cygnus.com) - - * decl.c (find_implied_typed): Delete obsolete reference to - PROCESS_TYPE. - * ch-tree.def (PROCESS_DECL, PROCESS_TYPE): Delete - they're - obsolete. - -Wed Feb 2 13:37:56 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Delete bogus runtime/Makefile lines. - * configure: Build testsuite directory. - -Wed Feb 2 13:37:56 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Correct srcdir for chill.examples directory. - -Wed Feb 2 11:24:57 1994 Wilfried Moser (fs_moser at rcsw47) - - * ch-parse.y (rule call): Add - BUFFERNAME LPRN untyped_expr RPRN - to enable generating a descriptor same as for SIGNALS. - * ch-tasking.c (generate_tasking_code variable, - decl_tasking_code_variable): Implement overflow check of - taskingcode in case a tasking code is specified with the - compiler directives SIGNAL_CODE, BUFFER_CODE, EVENT_CODE or - PROCESS_TYPE. - -Wed Feb 2 09:31:37 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Add ${srcdir} to Makefile.in's path. - * loop.c: Delete unused whitespace. - -Tue Feb 1 17:09:41 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (string_char_rep): Process STRING_CST correctly. - -Tue Feb 1 15:29:28 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c (build_boring_bitstring): New function. - * expr.c (build_chill_repetition_op): Fix a number of bugs in - implementation of bitstring repetition. - Also, implement repetition of Booleans. - -Tue Feb 1 15:28:21 1994 Bill Cox (bill@rtl.cygnus.com) - - * configure: Delete code to check for gas or ld. Add code to - store a config.status file in each configured subdirectory. - * expr.c (): Spell concatbitstring as concatps, which is the - runtime routine name. - * regression.sh: Force use of GNU make. - -Tue Feb 1 15:22:12 1994 Bill Cox (bill@rtl.cygnus.com) - - * tasking.c: Mark compiler-generated temps to prevent - GRANTing them. - -Tue Feb 1 17:38:51 1994 Wilfried Moser (fs_moser at rcsw1j) - - * lex.l (equal_number): Improve check for number after = in a - compiler directive. - * tasking.c (build_tasking_struct): Make field TaskValue - pointer to chill_unsigned_type_node. - * tasking.c (generate_tasking_code_variable): Declare tasking - code variable as chill_unsigned_type_node. - * tasking.c (decl_tasking_code_variable): Declare tasking - code variable as chill_unsigned_type_node. - -Mon Jan 31 14:01:58 1994 Bill Cox (bill@rtl.cygnus.com) - - * addtest (update_Makefile): No longer build actions - they're - now in pattern rules. - * ch_makedepend: Do the grep first, to avoid processing non - USE_SEIZE_FILE lines. - * configure: Pervasive rewrite to support configuring regression - test directories. - -Mon Jan 31 04:35:53 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * typeck.c (build_chill_slice): Compute EXTENT correctly. - -Sun Jan 30 14:33:12 1994 Bill Cox (bill@rtl.cygnus.com) - - * tasking.c (build_gen_inst): Return a typed tuple with - INSTANCE type. - -Sun Jan 30 12:01:07 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c (chill_expand_assignment): Recognize LENGTH builtin - in the left hand side, pass it to - expand_varying_length_assignment. - (expand_varying_length_assignment): Clean up bitrot. - * convert.c (convert): Revert most recent change. - * loop.c (maybe_skip_loop): New function, split out of - begin_chill_loop. Add conditional to skip processing an empty - VARYING array. - * parse.y (assignaction): Delete code to recognize LENGTH - on left-hand-side. - * typeck.c (validate_varying_array_ref): Correct misleading comment. - -Sat Jan 29 10:54:06 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * typeck.c (build_chill_slice): Pass a valid identifier to - `get_unique_identifier'. - - * convert.c (convert): Rename LENGTH variable to MAXIDX, and - use correct value for VAR_LENGTH when initializing a varying array. - - * decl.c (do_decl): Set DECL_COMMON. - - * actions.c (check_range): Temporarily inhibit warnings so the - compiler doesn't warn the user about useless range checks that it - might create. It's far easier for the compiler to figure out that - a range check need not be done than it is for us to try to figure - it out for ourselves. - - * expr.c (build_concat_expr): Generalize to handle bitstrings. - (scalar_to_string): New function. - (chill_expand_expr): Handle SET_TYPEs in CONCAT_EXPR by using new - library call (__concatbitstring). - -Sat Jan 29 08:43:54 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch_makedepend: Fix the 'sed' command so that seize file - name can be delimited by double quotes as well as apostrophes. - -Thu Jan 27 17:26:19 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * typeck.c (my_build_array_ref): Do constant folding. - -Thu Jan 27 16:24:24 1994 Bill Cox (bill@rtl.cygnus.com) - - * actions.c, actions.h, ch-tree.h, chill.texi, convert.c, - decl.c, except.c, expr.c, grant.c, inout.c, lang.c, - lex.h, lex.l, loop.c, parse.y, tasking.c, tasking.h, - tree.c, typeck.c: New 'Copyright' line for 1994. - -Thu Jan 27 14:12:07 1994 Mike Stump (mrs@cygnus.com) - - * configure: Don't configure this directory with this configure, - just subdirectories and cleanup. - * Makefile.in (Makefile): Run config.status in parent directory, - if we need rebuilding. - -Thu Jan 27 10:37:33 1994 Bill Cox (bill@rtl.cygnus.com) - - * decl.c (bind_sub_modules): Need a parameter on the recursive call. - Thanks, Zoo! - -Thu Jan 27 10:37:33 1994 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (build_concat_expr): Fix SunOS portability problem. - -Wed Jan 26 14:57:39 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * convert.c (digest_powerset_tuple): New function, used to set - TREE_CONSTANT and TREE_STATIC properly. - (digest_structure_tuple, convert (NULL to instance, non-varying - to varying)): Set TREE_CONSTANT and TREE_STATIC when appropriate. - * expr.c (varying_to_slice): Preserve novelty of slice type. - * expr.c (build_concat_expr): Make sure class of result is - correct (including correct novelty). - * satisfy.c (safe_satisfy_decl): If value of CONST_DECL is - not TREE_CONSTANT, emit an error. - * typeck.c (build_chill_slice): Preserve novelty of result. - * typeck.c (build_chill_slice): Simplify for varying argument - (by using varying_to_slice). - * typeck.c (expand_constant_to_buffer, extract_constant_from_buffer): - New functions. - * typeck.c (build_chill_cast): Use above new functions to convert - constant expressions. - * typeck.c (copy_novelty), ch-tree.h: New function. - * chill.texi: Update for new constant conversion semantics. - -Tue Jan 25 14:00:02 1994 Wilfried Moser (fs_moser at rcsw1j) - - * ch-decl.c (init_decl_processing): Add new builtin function - DESCR. Add call to build_chill_descr_type. - * ch-expr.c: Add function build_chill_descr_type, which actually - build the type the DESCR builtin returns. - Add function build_chill_descr, which process the DESCR builtin. - * ch-expr.c (build_chill_length): Add code to enable - LENGTH (bitstring). - * ch-expr.ch (build_generalized_call): Add processing of DESCR - builtin. - * ch-grant.c: Add code to avoid producing of unnecessary grant - files. - * ch-tree.h: Add enum for builtin function DESCR. Add prototype - for build_chill_descr. - * ch-inout.c (build_chill_io_list_type): Change generation of the - type passed to runtime library according to the new definition. - * ch-inout.c (build_chill_writetext): Change processing of format - string that a character constant is allowed as format string if - compiler gets called with -fold-strings option. - * ch-inout.c (build_chill_writetext): Change processing of - integers in case NEWMODE x = INT. - * ch-inout.c (build_chill_writetext): Remove processing of ranges. - * ch-inout.c (build_chill_writetext): Add processing of - bitstrings. - -Tue Jan 25 09:07:10 1994 Mike Stump (mrs@cygnus.com) - - * Makefile.in (all, OBSTACK): Build interesting things be default, - and make sure we include OBSTACK. - -Sun Jan 23 12:35:38 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * grant.c (decode_constant): Handle RANGE_EXPR. - Simplify handling of CONSTRUCTOR. - - * typeck.c (build_chill_slice): Use build_chill_array_ref_1, - not build_chill_array_ref. - -Sat Jan 22 16:23:30 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * parse.y: Generate a RANGE_EXPR (instead of a confusing - TREE_LIST) to indicate a range in case and tuple lables. - * actions.c (chill_handle_case_label), convert.c (digest_constructor): - Update accordingly to handle these RANGE_EXPRs. - * satisfy.c (satisfy): Don't call finish_chill_binary_op - for a RANGE_EXPR. - -Fri Jan 21 15:39:36 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c (force_addr_of): New function, to encapsulate passing - by reference a powerset or string to a library function. - * expr.c (build_min_max, build_set_expr): Use force_addr_of. - * expr.c (chill_expand_expr case CONCAT_EXPR): Fix passing of - rtl modes. (Old code fails on 64-bit Alpha.) - * expr.c (build_chill_function_call): Remove bogues check for - READonly variable passed as parameter. - * expr.c (build_set_expr): Merge common code. - * parse.y (string repetition): Fix logic for 2-pass scheme. - * expr.c (finish_chill_binary_op), grant.c (decode_constant), - satisfy.c (satisfy): Handle REPLICATE_EXPR. - * chill.texi: Fix typo. - -Mon Jan 17 13:55:48 1994 Jim Wilson (wilson@sphagnum.cygnus.com) - - * Makefile.in (INCLUDE): Add -I$(srcdir)/ch so that toplevel - tree.c can find ch-tree.h. - -Sat Jan 15 15:34:11 1994 Mike Stump (mrs@rtl.cygnus.com) - - * configure: Fix problem so that building in a separate directory - works. - -Sat Jan 15 09:51:02 1994 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Recurse down into runtime to - create its Makefile, and to clean up. - * configure: Recurse into runtime to make its Makefile. - -Sat Jan 15 09:15:22 1994 Bill Cox (bill@rtl.cygnus.com) - - << This set of CHILL frontend sources is now the - maintainable and master set. Accept no substitutes! >> - * Makefile.in, configure: Completely rewritten - to be invoked by gcc/Makefile.in and - gcc/configure. - * addtest (update_ChangeLog): Fix insertion - of the '*'. - * regression.sh: Add global option to suppress results of - proprietary tests. - * cpy.sh: Add necessary edits to files as they - are copied down. - * actions.c, ch-tree.def, ch-tree.h, convert.c, - decl.c, except.c, expr.c, grant.c, inout.c, - lang.c, lex.h, lex.l, loop.c, parse.y, - satisfy.c, tasking.c, typeck.c: Latest - versions from the repository. - -Fri Jan 14 12:28:39 1994 Bill Cox (bill@rtl.cygnus.com) - - * addtest: Fix insertion of line into ChangeLog. - * configure: Add a script. - * Makefile.in: Hack from ../Makefile.in - * actions.c, convert.c, decl.c, expr.c, grant.c, inout.c, - * lex.l, loop.c, parse.y, satisfy.c, typeck.c: Latest sources. - -Mon Jan 10 11:38:07 1994 Bill Cox (bill@rtl.cygnus.com) - - * build-release: Rewrite for easier tailoring. - -Wed Jan 5 08:38:21 1994 Bill Cox (bill@cygnus.com) - - * actions.c, convert.c, decl.c, except.c, expr.c, - inout.c, loop.c, parse.y, satisfy.c, typeck.c: - Current versions from devo/gcc. - -Wed Dec 29 14:07:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * addtest: Don't add comment headers to source or .dat files - if they're already present. - -Wed Dec 29 13:15:11 1993 Bill Cox (bill@rtl.cygnus.com) - - * mktg_leads: New file. - * regression.sh, regression.awk2: Updated status report scripts. - * addtest: New script to add a test to a directory. - * ch_makedepend: Add full path to ch_decomment. - * actions.c, convert.c, decl.c, expr.c, grant.c, inout.c, - lex.l, loop.c, parse.y, satisfy.c, tasking.c, typeck.c: - Updated copies of actual sources. - * chill.brochure, chill.texi: Update with current status. - * cpy.sh: Script for updating copies of sources. - * chill.patches: New script for creating a patch release. - Pretty rough. - -Wed Dec 8 09:35:54 1993 Bill Cox (bill@rtl.cygnus.com) - - * build-release: Delete lots of unused regression-testing cruft. - * chill.brochure: Initial draft of marketing brochure. - * chill.patches: Preliminary script for building patch sets - for CHILL. - * tcov.awk, tcov.el, tcov.sh: New files. Script, tools for - building a tcov report on the CHILL compiler. - -Sun Nov 21 08:34:33 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Adjust gperf rule for names in this directory. - * ch_decomment.l: New file. Ignores CHILL comments. - Executable is used bu ch_makedepend. - * ch_makedepend: New script. Makes CHILL dependencies for - Makefiles. - * gperf, hash.h: New files about lexer tokens. - * regression.sh: Delete notes justifying non-summing - report rows. - * regression.awk2: Report PRMS status when there are - missing test results. - * regression.awk3: Add #! line, so this can be used separately. - * Other files: latest versions copied from devo/gcc. - -Sat Oct 30 15:02:24 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * chill.texi: Add new node about conversions. - -Fri Oct 29 14:17:31 1993 Bill Cox (bill@cygnus.com) - - * chill.regress.cron: Change path to executable, enable PR report. - * regression.awk2: Add terminating periods to messages. - * regression.sh: Change path to testsuites. Add disclaimer at end - of report. Print explicit lists of resolved/unresolved PRs. - -Thu Oct 28 09:22:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: More PR-related status is printed. - -Thu Oct 21 19:24:02 1993 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: Simplify the paths, make the source - and test files accessed separately from the executables. - -Wed Oct 20 16:35:30 1993 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: Finally fix the file-delete problem. - Thanks, Jeffrey! - * build-release: Make more verbose, fix comment. - -Mon Oct 18 00:21:24 1993 Bill Cox (bill@cygnus.com) - - * regression.sh: Build linker if -U option. Put stderr - into make.log files, too. Also report on Z.200 examples. - * regression.awk3: New script to help build release note. - -Fri Oct 15 16:33:54 1993 Bill Cox (bill@cygnus.com) - - * regression.sh, regression.prpt: Output PR status only - conditionally. Add command-line flag for CVS updates. - -Thu Oct 14 07:53:59 1993 Bill Cox (bill@rtl.cygnus.com) - - * regression.sh: Count PRs accurately. - * Makefile.in: New file. - -Sat Oct 9 19:46:58 1993 Bill Cox (bill@rtl.cygnus.com) - - * regression.awk?: Add program fragments for - report of PRMS/test exceptions. - * regression.sh: Add options and PRMS reports. - -Fri Oct 8 06:44:41 1993 Bill Cox (bill@rtl.cygnus.com) - - Create chill frontend directory, populate it. - Later, the chill-specific frontend files will be moved here. - - * chill: Moved here from gcc directory. - * chill.regress.cron: Add crontab file for regression tests. - * regression.sh: Add regression test control script. - -# -# What follows is a copy of the former devo/gcc/ChangeLog.Chill file, -# -Sat Jan 15 14:54:07 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch-*.*: All of these files are now moved to the ch subdirectory. - Further update changes should be recorded in the ch/ChangeLog file. - -Fri Jan 14 21:09:44 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * c-typeck.c, ch-actions.c, ch-convert.c, ch-decl.c, ch-except.c, - ch-satisfy.c, ch-typeck.c: Undo all of initializer-related changes - that Tiemann did earlier this month. - * c-typeck.c (really_start_incremental_init): Save - constructor_elements and (old value of) constructor_stack - on constructor_stack, to allow for nested initializers. - * ch-convert.c (digest_constructor): If we need a varying - array, and have a constructor (for the array elements), - make sure to use convert so that the constructor gets - wrapped in an implicit record constructor. - * ch-decl.c (do_decl): If there is no initializer for a - varying array (or bitstring), create default constructor. - - * ch-expr.c (build_chill_lower): Fix thinko for ARRAY_TYPE. - * ch-satisfy.c (safe_satisfy_decl): Make sure that we make - original decl to check if we need to make an rtl. - - * ch-typeck.c (build_chill_array_ref_1), ch-tree.h: New function - which does the actual work for build_chill_array_ref (which - now just loops over an argument list). - * ch-actions.c, ch-expr.c, ch-inout.c: Use build_chill_array_ref_1 - instead of build_chill_array_ref where appropriate. - * ch-actions.c, ch-expr.c, ch-typeck.c: Make operand 1 of a - VARY_ARRAY_REF is a single index, not an index list. - - * ch-grant.c (__init_list): Renamed to _ch_init_list, to - avoid a conflict on the Alpha. - -Wed Jan 12 10:19:35 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (WS): Add BS, VT and CR to definition of - whitespace. - (convert_number): Allow for uppercase hex digits. - -Tue Jan 11 19:43:55 1994 Bill Cox (bill@cygnus.com) - - * ch-actions.c (lookup_and_handle_exit): Correct - conditional so error messages are output. - * ch-expr.c (build_chill_addr_expr): Add error message. - * ch-grant.c (chill_finish_module_code): Avoid abort by - giving the init_list constructor a type. - (chill_finish_compile): Delete unused code. - * ch-lex.l: Make most build_init_2 calls from the - permanent obstack, so that enumeration values endure. - * ch-loop.c (build_chill_iterator): Add several error - messages. - -Tue Jan 11 12:31:55 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c, ch-typeck.c: Rewrite some instances of - 'struct ch_class class = chill_expr_class (expr);' to - 'struct ch_class class; class = chill_expr_class (expr);' - to work around a bug in /usr/ucb/cc on SunOS4. - -Mon Jan 10 18:29:36 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_convert_for_assignment): Avoid seg fault. - * ch-expr.c (expand_packed_set): Add new parameter to pass - set's minimum ordinal value. Fix loop invariant problem. - (fold_set_expr): Change to add new parameter to - expand_packed_set call. - * ch-grant.c: Move extern declaration to ch-tree.h. - * ch-lex.l (convert_bitstring): Also output the bitstring - if yydebug is set. - * ch-tree.h: Add prototype. - -Mon Jan 10 11:29:41 1994 Bill Cox (bill@rtl.cygnus.com) - - * ch-inout.c: Fix comment. - * ch-tree.h: Add prototype. - -Sun Jan 9 18:22:22 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (chill_expr_class): New prototype. - * ch-expr.c (build_chill_pred_or_succ, build_chill_unary_op): - Convert result to correct class. - * ch-expr.c (build_chill_repetition_op): Preserve CH_DERIVED_FLAG. - Also, fix some bugs for bitstrings (with ranges). - - (Patches from Tiemann.) - * ch-convert.c (convert1): New function to force TREE_TYPE. - (convert): Use convert1 where appropriate. - * ch-typeck.c: Formatting change. - * ch-parse.y (build_chill_constructor): Fix thinko. - - * ch-expr.c (varying_to_slice): If array is not referable, - call save_expr on it, rather than stabilize_reference. - * ch-satisfy.c (safe_satify_decl, for CONST_DECL): - Don't force value to value class if mode is not explicitly - specified. Also, make sure convert etc is only done once. - -Sat Jan 8 16:37:10 1994 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (build_chill_function_type): Don't call - build_function_type, because it does hash canonicalization, - which once in a while looses badly. - * tree.c (build_function_type): Remove no-longer-needed test - for doing_chill_thang. - - * ch-tree.h (CH_DERIVED_FLAG): New flag. - * ch-tree.h (enum ch_expr_class): Renamed to ch_class_kind. - (struct ch_class): New type, used to represent a Chill - 'class' as a first-class value. - (CH_ROOT_RESULTING_MODE): Replaced by CH_ROOT_RESULTING_CLASS. - * ch-typeck.c (chill_expr_class): Change interface to return - a struct ch_class. - (chill_compatible, chill_compatible_classes): Update accordingly. - (chill_root_resulting_mode): Replace by .... - (chill_root_resulting_class): ... new function. - * ch-convert.c (convert_to_class): New function. - * ch-decl.c (layout_enum): Mark enum values with CH_DERIVED_FLAG. - * ch-lex.l (string_or_int): Rename to string_or_char. - * ch-lex.l (build_chill_string, string_or_char, convert_bitstring, - convert_float, convert_number): Set CH_DERIVED_FLAG for literals. - * ch-expr.c (finish_chill_binary_op): Use convert_to_class. - * ch-satisfy.c (safe_satisfy_decl): For CONST_DECL, make sure - DECL_INITIAL gets set to result of convert. - Also, clear CH_DERIVED_FLAG for SYN value. - * expr.c (store_constructor): If a [power]set is exactly one - word long, use single-word move. - -Sat Jan 8 08:38:29 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * c-typeck.c (chill_initializer_constant_valid_p): Fix typo. - -Wed Jan 5 05:18:46 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-typeck.c (build_chill_slice_with_length): Test that ARRAY is of - ARRAY_TYPE before assuming so. Also, subtract 1 from LENGTH in - computation of SLICE_END. - - * ch-typeck.c (chill_location): Treat CONSTRUCTORs like STRING_CSTs. - - * ch-expr.c (build_chill_indirect_ref): Handle MODE == NULL_TREE. - - * ch-expr.c (fold_set_expr): Handle OP1 == NULL_TREE (which happens - for unary set operations). - - * ch-expr.c (build_chill_array_expr): Take new argument FORCE. All - callers changed. All callers changed. - - * ch-convert.c (digest_structure_tuple): Handle SELECTED_VARIANT - being NULL_TREE until we've started walking the list of values via - the loop over VARIANTs. - - * ch-parse.y (build_chill_constructor): If we see an IDENTIFIER_NODE, - treat it as an enum value (and hence constant). Also, only set - TREE_STATIC if the constructor is indeed constant. - * c-typeck.c (chill_initializer_constant_valid_p): If we see a - VAR_DECL, test the TREE_CONSTANT field of the DECL_INITIAL, don't - recurse on the DECL_INITIAL. - -Wed Jan 5 01:24:50 1994 Bill Cox (bill@cygnus.com) - - * Makefile.in: Add CHILL to LANGUAGES variable. - * ch-actions.c (check_range): Call build_binary_op instead of - fold, build to get the common types chosen. - (cond_range_exception, cond_overflow_exception, - cond_type_range_exception): Delete, obsolete. - (chill_convert_for_assignment): Enable this, get particular - about when to generate rangecheck code. - * ch-expr.c (build_chill_function_call): Sketch in where to - perform chill_convert_for_assignment on actual parameters. - (build_chill_addr_expr): Correct compiler warning. - * ch-loop.c (build_chill_iterator): Add runtime check for - negative loop step expression. - * ch-tree.h: Add prototype. - * ch-typeck.c (chill_max_vary_array_ref): Correct misunderstanding. - A varying array's length field counts the NUMBER of active array - array entries, not the byte-length of them. - -Tue Jan 4 17:57:39 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-decl.c (do_decl): Call `suspend_momenary' if the - converted constructor must live on the permanent_obstack. - * ch-convert.c (convert): When building a new SET_TYPE - constructor, re-set the TREE_CONSTANT and TREE_STATIC bits. - * c-typeck.c (chill_initializer_constant_valid_p): Handle VAR_DECLs. - - * ch-typeck.c (chill_location): CONSTRUCTORS that are static - are locations. - * ch-satisfy.c (safe_satisfy_decl): Convert DECL_INITIAL of CONST_DECL - on permanent_obstack if necessary. - - * ch-convert.c (digest_structure_tuple): When building a new SET_TYPE - constructor, re-set the TREE_CONSTANT and TREE_STATIC bits. - - * ch-decl.c (do_decl): Fix handling of REFERENCE_TYPEs which - the patch below helped to mess up. - - * ch-expr.c (build_chill_arrow_expr): Call `mark_addressable'. - (build_chill_addr_expr): Take new argument ERRORMSG. - All callers changed. Also, call `build_chill_addr_expr' where - we used to call `build1 (ADDR_EXPR, ptr_type_node, ...)' since - that now calls `mark_addressable' automagically. - - * ch-decl.c (do_decl): Keep OPT_INIT in DECL_INITIAL if possible. - This is needed because variables may appear in initialization - statements, and their DECL_INITIALs are their values at - initialization time. - * ch-convert.c (digest_structure_tuple,digest_constructor): Changed - to handle VAR_DECLs as initializers. - - * ch-convert.c (digest_structure_tuple): Copy elements of INITS so - they aren't destroyed for later use. - -Tue Jan 4 15:25:30 1994 Bill Cox (bill@cygnus.com) - - * ch-expr.c (chill_expand_expr): Correct check-range lo_limit - parameter for varying_array_ref calculations. - (build_chill_indirect_ref): Prevent seg fault due to syntax error. - * ch-typeck.c (build_chill_slice_with_range): Correct issuance - of bogus error in votrics. - (build_chill_slice_with_length): Change for debug tracability. - -Tue Jan 4 02:43:37 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-convert.c (digest_structure_tuple): Fix phasing problem in - handling variant record initializers. - (various places): Change `pop_init_level' calls to match - `push_init_level' wrt implicit variable. - - * ch-typeck.c (build_chill_slice): Convert the dynamic max index to - `integer_type_node' before using it in comparisons. FIXME: should - this be done in `chill_max_vary_array_index' by default? - -Tue Jan 4 00:24:14 1994 Bill Cox (bill@cygnus.com) - - * ch-actions.c: Fix comments. - * ch-parse.y: Define caseaction_flag. - (caseaction): Create new caseaction_flag node at the start, - then free it at the end. Check it before the ELSE code. - (expanded_case_label): Check the flag here. If set in either - place, generate a jump to the end of the case. - * ch-typeck.c (build_chill_slice_with_length, - build_chill_slice_with_range): Add lots of compile-time - parameter range checking. - -Mon Jan 3 21:49:04 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-convert.c (digest_structure_tuple): Call `push_init_level' with - implicit==0 everywhere, not 1. - (digest_constructor): Ditto. - - * ch-actions.c (check_range): Permit limits to be NULL_TREE. - Also, hack out some dead code. - * ch-typeck.c (build_chill_slice): Check varying and non-varying - slice constructs for range failures. - (build_chill_slice_with_range): Reindented, but not changed. - - * ch-typeck.c (chill_max_vary_array_index): New function. - * ch-expr.c (chill_expand_expr): Call it. - - * ch-decl.c (var_data_id, var_length_id): New variables. - (init_decl_processing): Initialize them. All calls to - get_identifier (VAR_LENGTH or VAR_DATA) are now replaced - by references to these variables. This simplifies the code - w/o obscuring anything. - -Mon Jan 3 21:24:44 1994 Bill Cox (bill@cygnus.com) - - * c-typeck.c: Fix comment. - * ch-actions.c (chill_expand_assignment): Error assigning to - READONLY location. (PR_3903) Pass filename, linenumber - to setbitpowerset runtime routine. - * ch-decl.c (init_decl_processing): Add filename, linenumber - parameters to setbitpowerset prototype. - * ch-expr.c (build_chill_function_call): Error when passing a - READonly location as a LOC or INOUT parameter. - * ch-parse.y (mode): Correct code marking type as readonly. - -Mon Jan 3 19:03:55 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-actions.c (chill_expand_assignment): Disable code that defeats - building varying array references. - * ch-expr.c (chill_expand_expr): Add rangecheck code to - VARY_ARRAY_REF case. - * ch-typeck.c (build_chill_array_ref): Don't call an `expand_' - function (in this case, `validate_varying_array_ref') when we're - doing a `build_' operation. - - * ch-typeck.c (validate_varying_array_ref): Simplify interface - since INDEX parameter can never meaningfully be an INDEXLIST. - * ch-actions.c (expand_varying_length_assignment): Caller changed. - -Mon Jan 3 07:29:45 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-typeck.c (build_chill_cast): Set TREE_CONSTANT on NOP_EXPRs. - * ch-convert.c (digest_structure_tuple): Switch to permanent_obstack - if we need to build a CONSTRUCTOR for a SET_TYPE initializer. - (digest_structure_tuple): If TREE_VALUE (VALUE) == NULL_TREE, don't - call CH_COMPATIBLE or try to convert it to TREE_TYPE (FIELD). This - can happen when constructors are output incrementally. - * c-typeck.c (initializer_constant_valid_p): Handle SET_TYPEs. - * varasm.c (output_constant): Handle NOP_EXPRs in SET_TYPE - CONSTRUCTORS. - -Sun Jan 2 08:17:09 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-convert (digest_structure_tuple): Handle SET_TYPEs. Also, call - `convert' so we can handle INSTANCE types (and other anomolies) - correctly. - - * ch-convert.c (digest_structure_tuple): Fixed variant - structure initialization. Also fixed a typo (TYPE_NAME - was being used on a FIELD_DECL instead of DECL_NAME). - * c-typeck.c (initializer_constant_valid_p): Pass missing - ENDTYPE argument on recursive call. - (set_init_field): New function, needed by ch-convert.c change above. - - * ch-decl.c (layout_chill_variants): Added a FIXME next to an - almost certain typo. - - * ch-expr.c (build_chill_arrow_expr): Call `build1' and set - TREE_CONSTANT for static references. - * ch-except.c (chill_start_on): Change calls to - `build_unary_op' (which is C-specific) to `build_chill_arrow_expr' - which has CHILL semantics. - * ch-convert.c (convert): Ditto (albeit in some disabled code). - -Sat Jan 1 21:26:43 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-satisfy.c (safe_satisfy_decl): Reorder conditional test of - TREE_CODE of DECL in case it's altered by actions in the switch. - - * ch-satisfy.c (satisfy): Undo abort added earlier on 1 Jan. CVS log - mentions where to find code that triggers this case. - - * ch-actions.c (adjust_parm_or_field): Handle CONSTRUCTORS here as - well. - - * ch-convert.c (digest_structure_tuple): Push to permanent_obstack if - we're dealing with a CONSTRUCTOR that is TREE_PERMANENT. - (digest_constructor): Ditto. - -Sat Jan 1 10:29:19 1994 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-parse.y (handleraction,resultaction,assignaction,call): Modified - so that CONSTRUCTORS are properly handled before being used. - - * ch-convert.c (chill_start_init): New function. All callers to - `start_init' changed to call this function instead. - (digest_struct_tuple): Defend against initialization machinery - mucking with CONSTRUCTOR_ELTS of CONSTRUCTORs by grokking both - IDENTIFIER_NODEs and FIELD_DECLs in the TREE_PURPOSE slots. This is - needed because CONSTRUCTORS stored in DECL_INITIALs of CONST_DECLs - can be refered to throughout the compilation unit. Also remove an - extraneous call to `process_init_element' erroneously added to the - variant record sub-loop. - (digest_constructor): Propagate TREE_CONSTANT and TREE_STATIC to - CONSTRUCTORS of SET_TYPE. - * ch-parse.y (build_chill_constructor): Refix typo. Also set - TREE_STATIC if at top level. - - * ch-expr.c (build_chill_arrow_ref): Fix yet another case of - TREE_CONSTANT not being set by calling `build1' when `build_unary_op' - should have been called. - - * ch-convert.c (digest_struct_tuple): Restore code which tracks - field initializations so that the compiler can deduce what variant - initializations to assume. - - * ch-satisfy (safe_satisfy_decl): Turn on initialization machinery - when we push into a scope that has a DECL with a CONSTRUCTOR as its - DECL_INIT. - - * ch-parse.y (build_chill_constructor): Change the name of the - parameter to something more meaningful. Fix typo. Also, handle case - where element is an untyped CONSTRUCTOR. - - * ch-except.c (finish_handler_array): Set TREE_CONSTANT on - constant ADDR_EXPRs. - (chill_start_on): Call `build_unary_op' to set TREE_CONSTANT - on JBUF_REF (instead of calling `build1' which does not). - - * ch-convert.c (convert): Test LENGTH instead of NEEDED_PADDING. - - * ch-typeck.c (chill_expand_tuple): Deleted. - * ch-parse.y (primval rule): Don't call `chill_expand_tuple'; - instead, use initialization machinery for CONSTRUCTORS that - come through here. - * ch-except.c (finish_handler_array): Ditto for CONSTRUCTORS - that are created here. - * ch-satisfy (satisfy): Abort in case we would have called - chill_expand_tuple. FIXME: some other code is needed here, - but I don't know what yet. - - * ch-parse.y (build_chill_constructor): New function to - propagate TREE_CONSTANT bits to CONSTRUCTORS. - (untyped_expr rule): Use it. - (primval rule): Use it. - - * ch-decl.c (do_decl): Call `finish_init'. - * ch-convert.c (convert): If we spontaneously create a CONSTRUCTOR in - this function, make sure the initialization machinery is set up. - - * ch-convert.c (digest_structure_tuple, digest_constructor): Add - missing prototypes. - -Fri Dec 31 11:31:01 1993 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-grant.c (chill_finish_module_code): Mark ADDR_EXPR built by hand - as being TREE_CONSTANT. Otherwise it gets bounded by the initializer - code. - - * ch-decl.c (do_decl): Change in CONSTRUCTOR handling due to... - * ch-convert.c (digest_structure_tuple,digest_constructor): Mostly - rewritten to work with GCC's initialization code. The basic change - was to keep the initializers in sync with the initialization - machinery that `process_init_element' imposes. Both of these - functions now return `void'. - * ch-convert.c (convert): Changed calls to `digest_...' functions. - - FIXME: the code handling UNION_TYPE (and variant records) has not - been tested yet. - -Fri Dec 31 15:32:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (convert_number): Output the converted number if - yydebug is enabled. - * ch-parse.y (signaldef): Set ignore_exprs correctly for a - SIGNAL declaration. - -Fri Dec 31 13:17:48 1993 Bill Cox (bill@cygnus.com) - - * ch-parse.y: Cleanup handling of RETURN actions, to distinguish - a RETURN without a value (which cannot have an exception - handler) from a RETURN with a value (which can). Eliminate - some shift/reduce and reduce/reduce conflicts. - -Thu Dec 30 17:42:32 1993 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-inout.c (build_chill_writetext): Deal with 2 cases where - types returned from `type_for_size' are not expected. FIXME. - * ch-decl.c (init_decl_processing): Mark `char_type_node' unsigned. - This is required when range checking is enabled. - -Thu Dec 30 14:28:25 1993 Bill Cox (bill@rtl.cygnus.com) - - DELAY CASE works now. - * ch-decl.c (init_decl_processing): Move rest of tasking-related - initialization into tasking_init(). - * ch-parse.y (delaycaseaction): Pervasive additions/corrections. - (optsetprio): New non-terminal. - * ch-tasking.c (get_task_name): Delete, obsolete. - (build_instance_type): build pointer to instance type also. - (build_receive_case_start): Cleanup per -Wall messages. - (build_receive_case_label): Move between start and end functions. - (build_delay_case_start): Pass SET name and priority also. - Generally update to correct functioning. - (build_delay_case_label): Move between start and end fucntions, - correct its functioning. - (build_delay_case_end): Correct the code. - (tasking_init): Lots of tasking-related code moved here from - init_decl_processing. - * ch-tree.h: Update, add prototypes. - -Wed Dec 29 10:13:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (build_chill_indirect_ref): Revert change which - failed full regression testing. - * ch-lex.l (name_type_signal): Add debug output. - * ch-parse.y (structured_variable): Add a debug variable. - -Wed Dec 29 02:05:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (get_next_decl): Revert change which failed full - regression testing. - -Tue Dec 28 18:20:14 1993 Bill Cox (bill@rtl.cygnus.com) - - DELAY actions work now. - * ch-decl.c: Correct spelling in comments. - (get_next_decl): NULL out the decl's TREE_CHAIN before returning - it, to prevent accidental access to the remembered_decls. - (init_decl_processing): Add wait_event to runtime functions. - * ch-expr.c (build_chill_indirect_ref): Prevent a syntax error from - becoming a seg fault. - * ch-grant.c: Correct a comment. - * ch-loop.c: Delete/correct comments. - * ch-parse.y (delaycaseaction): Add push/poplevel calls. Turn 'sorry' - into rough draft of actual code. - (delayaction): Don't make a new scope here, use get_unique_identifier - instead. - (locdec): process event decls here, too. - (mode): Add code to forbid READonly EVENT and BUFFER decls. Delete - code which required EVENTs and BUFFERs to be declared at global scope. - (simple_name_string): Add an EVENTNAME. - * ch-satisfy.c (safe_satisfy_decl): Prevent a syntax error from - becoming a seg fault. - * ch-tasking.c (tasking_setup): Add the event queue's max. length - as the 'entry_point' parameter in the list. - (build_receive_case_start, build_receive_case_label): Defer - calling runtime routine until we know whether we have a signal - or a buffer to wait for. - (build_delay_case_start, build_delay_case_end, - build_delay_case_label, build_delay_action, - process_event_decls): Added functions. - * ch-typeck.c (chill_similar): Allow all integers of differing - precisions to be similar. - -Thu Dec 23 18:00:40 1993 Bill Cox (bill@rtl.cygnus.com) - - * gcc.c (CHILL SPECS): Delete references to -M -MM -MD -MMD - options. Delete C-specific defines. Disable piping from - pre-processor to cc1chill (even if -pipe is specified), since cc1chill - rewinds its input for its second pass. Piping still works - from cc1chill to as. - -Thu Dec 23 12:31:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tasking.c (decl_tasking_code_variable): Assure that the - tasking_code variable is allocated on the permanent obstack. - (tasking_setup): Lots of changes - handle EVENT/BUFFER max. - queue length (passed as the entry_point parameter). - Other changes to variable names to increase 'self-documentation' - the only kind GNU CHILL will get, for a while.. - -Wed Dec 22 10:46:31 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_seize): Delete - it's unused. Fix comments. - * ch-loop.c (build_chill_iterator): Convert BY expression - so loop involving a SET works. Additional errors generated - for numbered SET expression as start or end expression. - * ch-tree.h: Prototypes for future DELAY functions. - * ch-typeck.c: Standard indentation. - -Tue Dec 21 15:30:57 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-actions.c (build_cause_exception): New function. - (expand_cause_exception): Re-write to use build_cause_exception. - (check_expression, check_range): New functions. - (chill_convert_for_assignment): New function. - * ch-expr.c (build_chill_pred_or_succ): New function. - (build_chill_succ, build_chill_pred): Removed. - (build_generalized_call): Use build_chill_pred_or_succ. - * ch-lex.h, ch-lex.l (init_lex): Add RID_OVERFLOW and RID_RANGEFAIL. - * ch-lex.l (init_lex): Use new macro to make more terse. - * ch-typeck.c (chill_equivalent): New function. - Also check that ranges have the same bounds. - * ch-typeck.c (my_build_array_ref): Add optional range-checking. - * ch-typeck.c (chill_location): Handle COMPOUND_EXPR properly. - Return 2 if also a referable. - * ch-typeck.c (chill_referable): Re-define to use chill_location. - * ch-tree.h (CH_EQUIVALENT): Re-defined to use chill_equivalent. - - * dbxout.c (dbxout_type): Output the type attribute "@S;" to - distinguish a string from a char array, and to distinguish a - bitstring from regulat (power)set. (Needed for Chill.) - * dbxout.c (dbxout_type): Only check for baseclasses in - type.binfo is a vector. (It is used in Chill for tagged unions.) - -Fri Dec 17 09:56:07 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-convert.c, ch-decl.c, ch-expr.c, - ch-grant.c, ch-inout.c, ch-loop.c, ch-parse.y, - ch-satisfy.c, ch-tasking.c, ch-tree.h, ch-typeck.c: - Fix -Wall problems. - * ch-actions.c (chill_expand_assignment): Error if assigning - a value to a BUFFER or EVENT variable. - * ch-expr.c (invalid_left_operand): Delete, unused. - * ch-grant.c (tasking_setup): Call build_enum_tables. - * ch-inout.c (get_final_type_and_range, build_enum_tables,): - New functions. - (build_chill_writetext): Lots of changes to support other - basic CHILL data types. - * ch-loop.c (build_chill_iterator): Lots of new code to check - the expressions in a STEP loop. - * ch-tasking.c (rc_state): Add fields to flag SIGNAL and BUFFER - names in receivecasealternative. Generate error messages - if they're mixed in the same receive case. - (process_buffer_decl): Renamed from build_buffer_decl. - * ch-tree.h: Fix prototypes. - * ch-typeck.c (smash_dummy_type): Handle all four kinds of LANG_TYPE - correctly. Thanks Per! - -Wed Dec 15 15:05:56 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (push_scope_decls): Re-arrange some more, so - that normal SEIZES (without ALL) are handled before SEIZE ALL. - -Wed Dec 15 13:01:22 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-loop.c (declare_temps): Calculate end-of-array pointer - using correct type (NOT chill_integer_type). - (begin_chill_loop): Build loop-bypass expression in the - type of the start expression, not in the unsigned type. - -Tue Dec 14 15:41:32 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (push_scope_decls): Re-arrange so that normal - (non-seize) declarations are proclaim_decl'd *before* we - handle the ALIAS_DECLs for seizes. The advantage is - that we can now test for (an approximation) to the - 'seizeable' concept, thus avoiding duplicate definitions - when a module has both GRANTs and SEIZE ALL. - - * ch-expr.c (build_chill_arrow_expr): No longer re-write - addr-of-conversion to pointer-conversion-of-addr. - * ch-expr.c (build_chill_addr_expr): Re-write to just use - build_chill_arrow_expr. - -Mon Dec 13 16:44:43 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c (build_chill_addr_expr, build_chill_addr_expr): Don't re-write - - * ch-tree.h (chill_root_resulting_mode): Fix typo (missing '_'). - - * ch-expr.c (finish_chill_binary_op): Use CH_ROOT_RESULTING_MODE - macro (which works on expressions), rather than CH_RESULTING_MODE - (which works on modes, and isn't quite correct). - * ch-tree.h (CH_IS_BOUND_REFERENCE_MODE): New macro. - * ch-typeck.c (chill_read_compatible, chill_compatible): - Use the new macro, which handles NEWMODEs of PTR correctly. - * ch-typeck.c (chill_similar): Return 1 rather than 0 for - dynamic-length array (and string) types (e.g. slices). - * ch-typeck.c (chill_root_mode): If the mode has a Novelty, - just return it as is. (This is still not 100% correct for - NEWMODE of RANGEs, but is close enough.) - -Mon Dec 13 16:27:06 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (locdec): Avoid passing IDENTIFIER_NODEs to - build_buffer_decl, which then seg faults. - * ch-tasking.c (build_buffer_descriptor): Move declaration - of bufdecl closer to its use. - -Mon Dec 13 14:57:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_expand_result): Use expand_expr_stmt - to avoid C-specific conversions. - * ch-lex.l (name_type_signal): Rewrite to support BUFFERs and EVENTs. - * ch-parse.y (sendaction): Delete unused statement, use the 'name' - variable. - * ch-tasking.c: Use expand_expr_stmt to avoid C-specific - conversions. - (build_buffer_decl): Save the tasking_code_variable's decl - in the buffer decl tree. - (build_buffer_descriptor): Real, working version. - -Mon Dec 13 03:13:36 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (print_lang_identifier): Delete code - to print buffer size - it's no longer kept here. - * ch-parse.y (expand_send_buffer): Renamed from - build_send_buffer. - (locdec): Enable building of a buffer decl. - (optresultspec, optresultattr): Add optional - result attributes such as LOC. Semantics - not enabled yet. - * ch-tasking.c (expand_send_buffer): Renamed. - * ch-tree.h (build_send_buffer): Renamed. - * ch-typeck.c (chill_expr_class): Do more complete, - job of classifying expressions. Thanks, Per. - -Mon Dec 13 00:59:30 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c (chill_expr_class): Return CH_DERIVED_CLASS - for bitstring constants. - * ch-typeck.c (chill_novelty): The novelty of an (unnamed) - range mode is that of its parent mode; the novelty of READ M - is that of M. - -Sat Dec 11 15:14:41 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c (varying_to_slice): Call stabilize_reference - rather than save_expr. - * ch-typeck.c (build_chill_slice): Don't emit warning - if array is a SAVE_EXPR (it is effectively referable). - * ch-typeck.c (chill_root_resulting_mode): Handle - correctly the case that one operand is DERIVED and one is VALUE. - -Fri Dec 10 10:00:42 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (decode_decl): Restore code mistakenly deleted. - Move instance-handling code to raw_decode_mode. - * ch-parse.y (formpar): Allow READ modifier in SPEC MODULE. - Add rough draft of DELAY statement handling. - * ch-tasking.c (build_event_type): New function. - * ch-tree.h (build_event_type): Add prototype. - * ch-typeck.c (smash_dummy_type): Add buffer & event handling. - -Wed Dec 8 18:02:26 1993 Bill Cox (bill@rtl.cygnus.com) - - Parse and grant BUFFER modes. - * ch-grant.c (raw_decode_mode): Format BUFFER, EVENT modes. - Moved from decode_decl. - * ch-parse.y: Fix several sorry() messages. - * ch-tasking.c (build_buffer_type): Use a LANG_TYPE to pass the - info. - -Wed Dec 8 12:59:54 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-actions.c (chill_expand_assignment): In a multiple - assignment, check that all the targets are equivalent. - - * ch-typeck.c (chill_l_equivalent, CH_L_EQUIVALENT): New function - and macro to (partially) implement the relation l-equivalent. - * ch-typeck.c (chill_read_compatible): Implement at least - initial check of read-only-ness. - * ch-typeck.c (build_readonly_type): Fix thinkos. - -Wed Dec 8 09:11:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (pop_module): Only warn about duplicate grant - statements if they inhabit different files, by examining - inode numbers. Only report compatibility problems in pass 1. - * ch-lex.l (chill_same_grant_file): New function to support the - above test. - -Tue Dec 7 17:10:36 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (start_chill_function): Handle attributes in pass 1, - rather than in pass 2. (It seems to make more sense that way.) - * ch-parse.y (procedureattr): Build attribute list if pass != 2. - - * ch-parse.y (mode): Don't call build_readonly_type in pass 2. - -Mon Dec 6 14:35:31 1993 Per Bothner (bothner@kalessin.cygnus.com) - - This implements NOVELTY and READONLY checking. - * ch-tree.def: Added comment about use of LANG_TYPE. - * ch-typeck.c (build_readonly_type, smash_dummy_type): New functions. - * ch-tree.h: New prototypes. - * ch-decl.c (push_modedef): If newmode, lazily "copy" the given mode - immediately (even if it's just a type name), using a LANG_TYPE. - * ch-parse.y (mode): Call build_readonly_type to handle READ. - * ch-decl.c (find_implied_types), ch-grant.c (raw_decode_mode), - ch-satisfy.c (satisfy): Handle a LANG_TYPE. - * ch-decl.c: Remove chill_modes_equiv and other unused junk. - * ch-satisfy.c (safe_satisfy_decl/CONST_DECL): Better - mode compatibility checking for SYN declarations. - - * ch-typeck.c (chill_similar): Be more general when checking set - modes for similarity - specifically support calling chill_similar - BEFORE the modes have been satisfied (needed by proclaim_decl). - * ch-decl.c (proclaim_decl): Allow duplicate definitions - of set elements of similar set modes. - - * ch-parse.y (caseaction): Call language-independent - expand_start_case rather than c_expand_start_case (which - doesn't allow chars or booleans). - -Sat Dec 4 22:16:19 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (cond_range_exception, - cond_type_range_exception): Check command-line flag before - generating code. Fix comments. - * ch-expr.c (build_chill_num): Add generation of OVERFLOW - code, commented out. - * ch-loop.c (build_chill_iterator): Comment out - exception code generation. - * ch-parse.y: Delete quasi_signal flag, use - current_module->is_spec_module instead. - * ch-tasking.c (build_buffer_decl, build_buffer_descriptor): - Delete quasi_decl flag. Look at current_module - instead. - * ch-tree.h: Take quasi_decl flag out of buffer - related prototypes. - * ch-typeck.c (valid_array_index, chill_similar): - Comment out runtime range checking for now. - * expr.c (store_constructor): Fix word-size set problem. - * varasm.c (emit_set_data): Fix word-size set problem. - -Wed Dec 1 19:08:12 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Delete unused prototype for build_compound_expr. - * ch-loop.c (begin_chill_loop): Convert operands of the conditional - expression to lp->iter_type before expanding it. Prevents an abort - deep in expand_expr and friends. - -Wed Dec 1 17:00:44 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_expand_assignment): Comment out strange - test and its error message. - * ch-loop.c (begin_chill_loop): Correct call to generate conditional - jump around the loop. - * ch-typeck.c (build_chill_slice): Call correct temporary generator. - -Wed Dec 1 14:19:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (cond_exception): Clarify that it generates - an exception if the given expression is TRUE. Make it so, Number One. - * ch-decl.c (DOLLARS_IN_IDENTIFIERS): Disable these. - (print_lang_type): Print max queue size. - Add casts to DECL_TASKING_CODE_DECL references. Fixes a - portability problem. - (init_decl_processing): Add filename and linenumber arameters - to tasking and memory-allocate runtime prototypes. - * ch-expr.c (finish_chill_binary_op): Check for division - by a constant zero. Replace build_temporary_variable - calls with decl_temp1 calls, to decouple from ch-loop.c. - (build_chill_succ, build_chill_pred): Sketch code to generate - exceptions. Add error check for numbered set. - (build_generalized-call): Correct call for return_memory. - Standardize whitespace before left parens. - * ch-grant.c: Use new macro for checking for BUFFER mode. - * ch-lex.l (name_type_signal): Add attempts to recognize BUFFER - and EVENT names. - * ch-loop.c (build_temporary_variable): Make static, unavailable - to outsiders. - (declare_temps): Make user's variable for him/her, in the - true Z.200 case, where it hasn't previously been declared. - (begin_chill_loop): simplify control flow a bit. - * ch-parse.y (quasi_locdec): Set/reset quasi_flag. - (rccase_label): Delete bogus error checks. Rough draft of - BUFFER-related code. - (assertaction): Remove logical negation - it's now in cond_exception. - (locdec): Sketch of buffer-related code. - (non_array_mode): Add EVENT and BUFFER modes here. Add setting of - set-numbered flag for pred and succ functions. - (optqueuesize): Default to integer_zero_node. - (simple_name_string): Add BUFFERNAME. - * ch-tasking.c: Add casts to DECL_TASKING_CODE_DECL references. - (build_chill_start_process, expand_send_signal, - build_receive_case_start, build_send_buffer): Add filename, linenumber parameters - to tasking-related runtime calls. Sketches of BUFFER mode - processing. - * ch-tree.h: Remove left-hand-side cast in DECL_TASKING_CODE_DECL - macro, for portability to non-gcc compilers. Add prototypes - for buffer-related functions. - * ch-typeck.c: Replace build_temporary_variable calls with - decl_temp1 calls, to decouple from ch-loop.c. - (chill_similar): Add tests for BUFFER and EVENT modes. - -Wed Dec 1 14:05:26 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-actions.c (malloc prototype): Remove; can cause conflicts. - -Wed Dec 1 09:49:58 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (raw_decode_mode): Process a REFERENCE_TYPE. - -Tue Nov 30 14:05:23 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Add filename, line number - parameters to tasking-related runtime routines. - * ch-grant.c (decode_decl): Check for BUFFER mode differently. - * ch-parse.y (BUFFER_CODE, EVENT_CODE): Move token to - lex-only list. - (quasi_locdec): Set/reset quasi_decl flag. - * ch-tasking.c (build_start_process, expand_send_signal, - build_receive_case_start, build_send_buffer): Add filename. linenumber to - (build_buffer_decl, build_buffer-type): New rough-draft functions. - generated runtime routine call. - * ch-tree.h (CH_IS_BUFFER_MODE, CH_IS_EVENT_MODE): New macros - to mark a synchronization mode. Update the prototypes. - * ch-typeck.c (chill_similar): Check EVENT or BUFFER modes for - similarity. - -Tue Nov 30 09:51:47 1993 Doug Evans (dje@canuck.cygnus.com) - - * cccp.c (main): Add missing chill sanitization. - -Sun Nov 28 15:50:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-loop.c (initialize_iter_var): Build count expression - more robustly. - (bottom_loop_end_check): Call emit_line_note. - (end_chill_loop): Delete emit_line_note call. - * ch-parse.y (doaction): Move DO keyword - after end_chill_loop call. - -Wed Nov 24 08:49:07 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-typeck.c (c_expand_start_case): Back out previous - change. - -Tue Nov 23 12:33:50 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-typeck.c (c_expand_start_case): Allow any CHILL discrete - type as a CASE label. - -Tue Nov 23 11:37:42 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (grok_chill_variantdefs): Use NULL as the name - of variant fields (not __CASE or anything based on it). - * ch-decl.c (handle_one_parent), ch-expr.c (compare_records): - Don't check for field name __CASE. - -Tue Nov 23 09:37:54 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (grok_chill_variantdefs): Use a unique dummy - name for the FIELD_DECL. - * ch-parse.y (optstartset): More error tests. - * ch-tasking.c (make_process_struct): Only report error in pass 1. - (build_start_process): Remove bogus restriction, allowing - an INSTANCE expression as the optset parameter. - -Mon Nov 22 17:56:34 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (expand_function_end): Now is takes parameters, not 2. - * ch-decl.c (finish_chill_function): Add 3rd parameter to - call of expand_function_end. - - * ch-expr.c (chill_expand_expr): For set and strings ops, - if target is in a register, use a stack temporary (since we must - take its address). (Similar to Oct 29 change for store_constructor.) - * ch-expr.c (resolve_component_ref): Fix variant field lookups. - -Mon Nov 22 14:23:13 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_expr): Assure that emit_library_call - parameter 1 and its mode are always in sync. - (build_chill_pred, build_chill_succ): Allow pred/succ of a - pointer. - * ch-loop.c (chill_unsigned_type): New function, used instead of - unsigned-type, since it understands the chill_integer_type. - (decl_iteration_var): Delete, use build_temporary_variable - instead. - (declare_temps): Use lp->iter_type for the temp evaluations. - (initialize_iter_var): More careful calculation, to handle - MININT to MAXINT loops w/o overflow/underflow. - (begin_chill_loop): Use the original start/end expressions - for the loop bypass test. - -Mon Nov 22 14:02:06 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c (build_chill_slice): If the argument is - is constant, use a read-only static variant, as the - existing algorithm assumes addressability. - * ch-typeck.c (chill_compatible): De-reference reference types. - * ch-typeck.c (layout_chill_range_type): Set TREE_UNSIGNED. - -Sat Nov 20 20:17:15 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Add filename - and linenumber to allocate, free memory calls. - * ch-expr.c (build_allocate_memory_call, - (build_allocate_global_memory_call): Add - filename, linenumber to call. - * ch-loop.c: Complete rewrite for maintainability. - -Sat Nov 20 17:30:05 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-except.c: Make it so that (by default at least) the - code to push/pop the __exceptionStack is done using library - functions __ch_link_handler and __ch_unlink_handler. This - provides better flexibility (for e.g. multi-threading). - - * ch-decl.c (layout_chill_variants): Allow (useless) selectors - even for tag-less variants. - -Fri Nov 19 14:32:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Add memmove builtin - function definition. - * ch-actions.c (chill_expand_array_assignment): Use memmove - call to copy an array or slice across the assignment. - -Wed Nov 17 18:23:15 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-satisfy.c (satisfy): If a CONTRUCTOR already has a - TREE_TYPE, temporarily clear it before calling chill_expand_tuple, - to force expansion (processing of the elements). - * ch-grant.c (decode_constant): If a tuple (CONTRUCTOR) has - a mode, write it out. - * ch-decl.c (init_decl_processing): Add some missing inits. - -Wed Nov 17 17:13:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-loop.c: Fix unterminated strings in design comments. - Add enumeration to the iterator structure for type of loop. - unused for now. - -Wed Nov 17 16:40:05 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Add long parameters to lots - of powerset runtime routines. - * ch-expr.c (chill_expand_expr): Change parameters to powerset - runtimes so bitlengths are long unsigned ints. - * ch-inout.c (build_chill_writetext): Add filename and linenumber - as runtime parameters, for better error messages. - * ch-loop.c: general pre-rewrite cleanup. - * expr.c (store_constructor): Rewrite set interface to - setpowersetbits for long bitnumbers, rather than shorts. - -Tue Nov 16 13:41:12 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (build_chill_function_call): Stop generating empty - copyback statements, which lead to a seg fault. - -Tue Nov 16 12:20:17 1993 Per Bothner (bothner@cygnus.com) - - * ch-satisfy.c (satisfy): If satisfying a type whose - TYPE_MAIN_VARIANT is not itself, also satisfy the TYPE_MAIN_VARIANT. - * ch-actions.c (build_exception_variant): Remove some crud. - * ch-actions.c (build_exception_variant), ch-tree.h, ch-decl.c: - Remove unused first argument. - * ch-decl.c (start_chill_function): Call build_exception_variant - in pass 1, not in pass 2. - -Tue Nov 16 11:10:03 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (shadow_record_fields): Call new function - build_chill_arrow_expr, which returns a ptr-to-a-type. - * ch-expr.c (build_chill_arrow_expr): New function, works like - build_chill_addr_expr used to do, returning a typed ptr. - (build_chill_addr_expr): Now returns unbound ref - analogous - to C 'void *'. - * ch-parse.y (PREDEF_MODEDECL): Delete unused token. - (operand6): Call build_chill_arrow_expr. Reindent a bit. - * ch-tree.h (build_chill_arrow_expr): New prototype. - -Mon Nov 15 16:38:28 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * stor-layout.c (layout_type): If a SET_TYPE needs more than - INT_TYPE_SIZE bits, use BLKmode (and never DImode). - - * ch-decl.c (start_chill_function): Set DECL_CONTEXT of params. - -Mon Nov 15 14:49:17 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Move tasking stuff (__whoami - build_function_call, etc.) to tasking_init. - * ch-gperf, ch-hash.h: Add ASM keyword. - * ch-parse.y: Add ASM statement rules. - (format_str, text_arg): Delete last rules for WRITETEXT, READTEXT. - * ch-tasking.c: Move tasking stuff here. - -Sun Nov 14 15:50:34 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-parse.y (mode2): Split into array_mode and non_array_mode - to resolve layout ambiguity. - * ch-parse.y (checked_name): Remove. Use name_string instead. - * ch-parse.y (variantdef): Don't crash if no tag fields. - * ch-typeck.c (build_chill_array_type): If varying_p, - actually do build_varying_struct here (rather than in ch-parse.y). - -Fri Nov 12 15:37:45 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-satisfy.c (safe_satisfy_decl): Don't mangle function-local - static names. (Let make_decl_rtl generate a unique name.) - -Sun Nov 14 13:15:26 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (build_chill_lower, cuild_chill_upper): - Rewrite for modes, values, etc. - * ch-inout.c (build_chill_writetext): Add ability - to write out characters. - * ch-satisfy.c (safe_satisfy_decl): Don't mangle function-local - static names. (Let make_decl_rtl generate a unique name.) - * varasm.c (unpack_set_constructor): Subtract - lower domain value from a bit's index value, - to match the runtime and allow powersets - with negative lower bounds. - -Fri Nov 12 14:00:48 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-inout.c (build_chill_writetext): Save reserved words in - uppercase if -fspecial_UC was specified. - -Fri Nov 12 13:27:12 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-expr.c (chill_expand_expr, build_concat_expr): Simplify - string concatenation by treating varying strings as slices. - (varying_to_slice): New function. - * ch-typeck.c (build_chill_slice): Changed to support the above. - -Fri Nov 12 12:07:28 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c (convert): Fall through & convert a VARY_ARRAY_REF. - * ch-expr.c (build_generalized_call): Start module before a - writetext action, so its variables are inside the module-level - function. - * ch-loop.c (init_loop_counter): Correct for_u_bound computation - for enumeration loop on a varying array. - -Thu Nov 11 07:49:53 1993 Bill Cox (bill@rtl.cygnus.com) - - * cccp.c (main): Disable trigraphs for CHILL. - * ch-decl.c (grok_chill_fixedfields): Add special_UC - to conditional to determine case of reserved words. - Make PACK/UNPACK warning more specific. - * ch-expr.c (build_generalized_call): Enable recognition - of WRITETEXT call here. - * ch-gperf, ch-hash.h: Remove WRITETEXT as a reserved - word. It's only predefined. - * ch-inout.c: Add special_UC to conditionals - to determine case of reserved words. - (build_chill_writetext): Change for call from - build_generalized_call. Add code to format - integers. - * ch-lang.c (lang_decode_option): Add special_UC and - special_LC flags and logic to interlock with - ignore_case flag. - * ch-lex.l: Add special_UC to conditionals - to determine case of reserved words. - * ch-parse.y: Delete WRITETEXT as reserved word. - * ch-tasking.c: Add special_UC to conditionals - to determine case of reserved words. - (build_instance_type): Make components of INSTANCE - unsigned 16-bit integers. - * ch-tree.h (build_chill_writetext): Fix prototype. - * ch-typeck.c (build_chill_array_type): Make PACK - /UNPACK warning more specific. - * toplev.c (lang_options): Add -fspecial_LC - and -fspecial_UC flags. - -Wed Nov 10 02:29:53 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Move ch-hash.h from ch-lex.o - rule to ch-lex.c rule, so flex is rerun. - * ch-actions.c (chill_expand_assignment): Error if - user tries to assign to a LHS function. - * ch-decl.c (grok_chill_fixedfields): Use of PACK - /UNPACK is only a warning. - (init_decl_processing): Add ADDR as a builtin function. - * ch-expr.c (build_generalized_call): Add ADDR - as a builtin function. - (build_chill_addr_expr): Sanity check parameters. - * ch-gperf: Remove ADDR as a reserved word, - make ASM into one. - * ch-hash.h: gperf'd version of the above. - * ch-inout.c (chill_stdio_p): Recognize upper/lower - case file names. - * ch-lex.l: Make ignore-case work. Downcase - token before checking for reserved words. - * ch-parse.y: Delete ADDR as a reserved word. - (mode2, optlayout): Allow PACK/UNPACK specifier. - (call): Use build_generalized_call for - primval LPRN modename RPRN. - (primval): Delete ADDR reference. It's now only - predefined, not reserved. - * ch-tree.h: Add BUILT_IN_ADDR as a predefined. - * ch-typeck.c (build_chill_array_type): Just - a warning for PACK/UNPACK usage. - * toplev.c: Add -fignore-case and -fno-ignore-case. - -Tue Nov 9 15:07:02 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Reindent for readability. - * ch-convert.c (convert): Turn a NULL keyword into [0, 0] for - a conversion to INSTANCE. - * ch-decl.c: Change special_UC to ignore_case everywhere. - (init_decl_processing): Add builtin_function calls for lots of - predefined functions. - * ch-expr.c: Change builtin function handlers back to accepting - args, not a treelist. - (route_to_predefined_function): Delete it and its call. - (build_generalized_call): Add lots of builtin functions. - * ch-gperf (backwards, duration, inttime, null): Delete them. - * ch-hash.h: New version. - * ch-inout.c: Change special_UC to ignore_case everywhere. - * ch-lang.c: Delete special_UC flag. - * ch-lex.l: Change special_UC to ignore_case everywhere. - * ch-loop.c (high_domain_value, low_domain_value): Change - interfaces to build_chill_upper and built_chill_lower. - * ch-parse.y: Delete lots of stuff which should only be predefined. - * ch-tasking.c: Change special_UC to ignore_case everywhere. - Change builtin function handlers back to accepting args, - not a treelist. - * ch-tree.h: Add lots of builtin functions to the enumerator. - -Mon Nov 8 18:08:27 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tasking.c (tasking_init): Disable last-minute change for now. - -Mon Nov 8 17:30:22 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: New commands to build ch-hash.h. Add ch-lex.h to - dependencies where it's used. - * ch-decl.c (init_decl_processing): Build predefined constants - for TRUE, FALSE and NULL. Add declaration for abs builtin - function. - (lookup_name): Check for a CONST_DECL, don't ask about DECL_NESTING - stuff for builtin constant like TRUE. - * ch-expr.c (route_to_predefined_function): Add a bunch of - predefined functions to the list. - * ch-gperf: Define the list of reserved words, minus the predefined - words, using the special_UC flag. Remove NULL, TRUE, FALSE - - these are only predefined, not reserved. - * ch-hash.h: Check this into repository, even though it's derived - from ch-gperf, for those users who don't have gperf. - * ch-inout.c (build_chill_io_list_type): Use the special_UC flag - to refer to the IO types. Standardize the indentation. - * ch-lex.h: Add enumerators for TRUE, FALSE, NULL. - * ch-lex.l: Total rewrite of reserved-word recognition, using - the ch-hash.h lookup routines. - * ch-parse.y: Delete a bunch of unused rules for predefined - procedures and their parameters. - * ch-tasking.c (tasking_init): Build predefined functions - for COPY_NUMBER, GEN_CODE, GEN_INST, and GEN_PTYPE. Not - complete yet. Change interface to builtin handlers to accept - just an expression list. - -Wed Nov 3 18:07:08 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Debug, activate rule to make CHILL hash table. - * ch-actions.c: Compress parameter type lists per standard. - * ch-decl.c: Correct spelling in comment, compress parameter lists. - (init_decl_processing): Check special_UC flag to build builtin - function declarations. - * ch-expr.c (route_to_predefined_function): Check for upper OR - lowercase function names. - * ch-gperf: Update the list of keywords. - * ch-inout.c (build_chill_io_list): Check for special_UC flag - to build I/O list type. Compress parameter lists. - (chill_stdio_p): Check for special_UC flag in recognizing - file streams. - * ch-lang.c (lang_decode_option): Add command-line options - for upper-case keywords and user labels. - * ch-lex.l (init_lex): Initialize ridpointers to uppercase - if special_UC flag is set. - (downcase, getlc, check_newline): Don't do this if ignore_case - flag is set. - * ch-parse.y (variantdef, case_expr): Report 'sorry' for use of - multiple selector expressions. - -Sat Oct 30 01:06:19 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c (compare_record, finish_chill_binary_op): Compare - STRUCTs (and INSTANCEs) for equality. - * ch-expr.c (invalid_operand): New functions, combines most of - the functionality of invalid_left_operand and invalid_right_operand. - * ch-convert.c (digest_constructor): Set TREE_CONSTANT if it is. - -Sat Oct 30 11:12:47 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (chill): Add back in the commands to build chill - (the script) from chill.in. - -Fri Oct 29 16:25:38 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c (store_constructor): If SET_TYPE target is in a register, - use a stack temporary (since we must take its address). - - * ch-expr.c (build_allocate_global_memory_call, - build_allocate_memory_call): Cast argument pointer to PTR, - if needed (using location cast). Also, some other cleanups. - * ch-parse.y (bracketed_action): Re-arrange things so that - a handler following BEGIN END comes before the final poplevel. - * ch-typeck.c (build_chill_cast): Just return if already correct type. - - Re-do DO WITH so that build_component_ref for is done lazily - (at each reference) instead of eagerly (at the beginning - of DO WITH). This is needed for tagged variants, - * ch-tree.def (WITH_DECL): New declaration tree code. - * ch-decl.c (lookup_name): Recognize WITH_DECLs. - * ch-decl.c (handle_one_level): Variant parts are currently - indicacted with '__CASE'. Recognize that. - Generate a WITH_DECL (instead of ALIAS_DECL) for each field name. - -Thu Oct 28 22:17:41 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c (build_chill_length), ch-typeck.c (build_chill_cast): - Remove some old crud. - * ch-typeck.c (build_chill_cast): Another attempt at a - compromise between robustness and generality for casts. - Location conversions are now less likely to confuse things. - * ch-parse.y (optactions): Allow further optactions following - an initial semicolon. - * ch-parse.y: Add error messages on EVENT and BUFFER. - - * ch-decl.c, ch-expr.c, ch-parse.y, ch-typeck.c: - Undo some of the Oct 27 changes. - - Convert (some) builtin functions previously using reserved - names to be just predefined. - * tree.h (enum builtin_in_function): Added END_BUILTINS at end. - * ch-decl.c: Add predefines for allocate_memory, - allocate_global_memory, return_memory, writetext. - * ch-expr.c (check_arglist_length): New function. - * ch-expr.c (build_generalized_call): If "function" is - a builtin, build the appropriate tree. - * ch-parse.y, ch-lex.l: No longer recognize many pre-defined - functions at the lexer/parser level. - * ch-tree.h (enum chill_built_in_function): New type. - -Thu Oct 28 16:43:36 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (allocate_memory, allocate_global_memory): - Check for invalid parameters, issue errors. - * expr.c (store_constructor): Calculate bitlength, startrtx - and endrtx of powerset correctly. Define targetx, use it - and XEXP correctly. - -Wed Oct 27 08:25:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (build_max_min): Error for passing empty tuple - as the argument. - -Wed Oct 27 08:25:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Make allocate - builtins have a pointer-to-pointer-to-void - first parameter, rather than a reference parameter. - * ch-expr.c (build_allocate_memory_call, - build_allocate_global_memory_call): Do automatic - ADDR () on the first parameter, for backward - compatibility. - * ch-grant.c (grant_one_decl): Don't grant if - DECL_SOURCE_LINE is zero. - (start_chill_module_code): Set DECL_SOURCE_LINE - to zero so that module-level function isn't granted. - * ch-parse.y (handleraction): Add return_memory action. - * ch-typeck.c (chill_similar): Allow a void_type - to be similar to anything. This makes allocate_memory - and return_memory pointer parameters slide through. - -Tue Oct 26 00:12:19 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c (build_chill_array_ref): Check for and complain - if there are more index expressions than the array rank. - - * ch-actions.c (chill_expand_assignment): Emit appropriate - error message if RHS of multiple assignment is tuple/case/if. - * ch-tree.def (CONCAT_EXPR): Change TREE_CODE_CLASS from - 'e' to the more specific '2'. (Fixes a satisfy bug.) - -Thu Oct 21 17:25:33 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y: Revert experimental error-generating change - that was checked in by mistake. - -Thu Oct 21 12:15:30 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-satisfy.c (safe_satisfy_decl): Satisfy the hidden tasking - code variables associated with a process or signal. - (Apparently I forgot to actually check these in last time.) - * ch-tasking.c: Replace last calls to get_tasking_code with - working references to DECL_TASKING_CODE_DECL. - -Thu Oct 21 10:27:42 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-satisfy.c (safe_satisfy_decl): Satisfy the hidden tasking - code variables associated with a process or signal. - * ch-tasking.c (build_gen_inst, build_gen_ptype): Use the decl's - tasking_code_decl pointer, rather than trying to look it up - in the hash table or linked scope list. - -Wed Oct 20 09:52:44 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (lookup_and_handle_exit): Only output error message - in pass 1. - * ch-convert.c (convert): Correct conversion of VARYING array to/ - from non-VARYING one. - * ch-decl.c (print_lang_decl): Add debug output for DECL_TASKING_CODE_DECL - field in the node. - (decl_tasking_code_var): Delete it. Its calls are replaced woth - generate_tasking_code_variable calls, plus a little glue. - (push_extern_process): generate tasking_code_variable as local - static variable, point the process' function_decl at it for later - reference by build_start_process. - (print_mode): Use CHILL upper-case convention to print modes. - * ch-lex.l: Must initialize tasking-related trees to NULL at start - of each pass, or we lose the fact that the user did or did not - specify a value for each of them. - * ch-parse.y (check_end_label, action, exceptlist): Only output - error message in pass 1. - (sendaction): Add comments. - (sigdef): Comment out special handling for external signals. - Chain tasking_variable_decl onto signal structure decl, for - easier non-symbol-table access later. - * ch-tasking.c (generate_tasking_code_variable): Do work in both - passes, using do_decl so we can pass the pass 2 value of the - process_type or signal_code to it. Only update the process_type - if the incoming pointer isn't null and pass == 2. Use a new - parameter to know whether to include an init expression. - (build_process_header): Attach tasking-code_variable to process - function_decl for easy access later, not through the hash table. - (build_start_process): Get tasking_code_variable out of the process' - function decl. - (build_signal_struct_type): Return the type decl, to be accessed by ... - (build_signal_descriptor): .. this function. - (build_receive_case_label): Get data buffer pointer not from hash - table, but from Tiemann's current rc_state structure instead. - * ch-tree.h: Change prototype, fix comment, add DECL_TASKING_CODE_DECL - macro for tasking_code_variable storage. - -Tue Oct 19 17:39:40 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lex.l (equal_number): If the "number" is a CONST_DECL, - return its DECL_INITIAL. - * ch-satisfy.c (safe_satisfy_decl): Change logic for rtl - generation for decls to not use DECL_ASSEMBLER_NAME. - * ch-decl.c: Set DECL_ASSEMBLER_NAME to DECL_NAME. - This matches C, and allows dbxout to emit proper user-level names. - (It would be cleaner to fix dbxout to use DECL_NAME ...) - * ch-decl.c (outer_decls): New global list of the decls granted - into the outer scope. - (pop_module): Change code that grants into outer scope accordingly. - (lookup_name_for_seizing): Similarly update. - (push_scope_decls): Handle SEIZE ALL from the global scope - by searching outer_decls. - * ch-grant.c (grant_array_type): Fix thinko. - * ch-inout.c (build_chill_writetext): Remove excessive TREE_TYPE. - -Mon Oct 18 15:57:00 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * varasm.c (output_constructor): Add support for non-zero - lower array bound. - * c-typeck.c (output_init_element): Revert recent changes. - * varasm.c (emit_set_data): Fix emitting set constant data. - * ch-lex.l (yywrap): Reset line number to 0, not 1. - It sets incremented to 1 by check_newline. - * ch-tree.h: Restore old version. - * ch-expr.c (finish_chill_binary_op): Convert TRUNC_DIV_EXPR - to RDIV_EXPR if an operand is floating. (This functionality - got dropped when hacking finish_chill_binary_op). - - * ch-actions.c (build_chill_case_expr): Set type to NULL_TREE. - not error_mark_node. - * ch-actions.c (chill_expand_assignment): Allow such borderline - constructs as: LHS OR:= [X]. - * ch-convert.c (convert): Hande CASE_EXPR (and COND_EXPR) - with unknown (NULL_EXPR) type, not just CONSTRUCTORS. - * ch-decl.c (do_decl): Remove CONSTRUCTOR kludge. - * ch-typeck.c (chill_compatible): Allow expr to have NULL mode - if it's a CASE_EXPR or COND_EXPR (and not just CONSTRUCTOR). - -Mon Oct 18 13:20:53 1993 Ken Raeburn (raeburn@rover.cygnus.com) - - * c-typeck.c (output_init_element): Limit previous changes to - ARRAY_TYPE and SET_TYPE initializers. - -Sun Oct 17 23:15:00 1993 Bill Cox (bill@cygnus.com) - - * c-typeck.c (output_init_element): Handle NULL domain case. - * ch-decl.c (do_decl): Revert bogus initializer type change. - * ch-grant.c (chill_finish_module_code): Put module's decl onto - the module_init_list, for chill_finish_compile's possible use. - (chill_finish_compile): Rename variables for clarity, add - commented-out code as example for assignment of module address to its - init_list entry. - -Sun Oct 17 15:16:54 1993 Bill Cox (bill@cygnus.com) - - * ch-convert.c: Move semicolon to separate line - easier to see. - * ch-decl.c (do_decl): Handle untyped_expr initializers by - simply using the variable's declared type - no compatibility - check can be made if the expression has no type. - * ch-expr.c (expand_packed_set): Fix endless loop - increment - the loop variable. - (fold_set_expr): Fix two other endless loops by passing - correct parameters to unpack_set_constructor. - * varasm.c: Standardize 'for' loop. - -Sun Oct 17 12:16:21 1993 Bill Cox (bill@cygnus.com) - - * c-typeck.c (output_init_element): Handle initializer for - array with non-zero lower index bound. - -Sat Oct 16 16:48:48 1993 Per Bothner (bothner@cygnus.com) - - * ch-expr.c (finish_chill_binary_op): Use TREE_SET_CODE - to change TREE_CODE. - -Sat Oct 16 08:07:17 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (finish_chill_binary_op): Disable - rough-draft code, not intended for release. - -Fri Oct 15 21:44:11 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) - - * expr.c (store_constructor): use PROTO for pack_set_constructor - -Fri Oct 15 10:30:09 1993 Bill Cox (bill@cygnus.com) - - * ch-expr.c (finish_chill_binary_op): Activate some - type-setup code. - * expr.c (store_constructor): Subtract arrays minimum element. - Makes orientexpress work. - -Fri Oct 15 09:26:24 1993 Bill Cox (bill@cygnus.com) - - * ch-convert.c, ch-expr.c: Add externs so it'll compile. - * ch-tree.def: Add BASED_DECL definition. - -Thu Oct 14 13:20:02 1993 Bill Cox (bill@cygnus.com) - - * ch-actions.c (build_chill_cause_exception): Pass the - *address* of the filename string to the runtime routine, - rather than passing the string by value. - -Thu Oct 14 13:08:07 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * expr.c (store_constructor): Use a (usually) more efficient - algorithm for setting SET types. - -Thu Oct 14 13:08:07 1993 Per Bothner (bothner@kalessin.cygnus.com) - - Changes to better support 1984 version of Chill, which doesn't - really distinguish BOOL and BITS(1) or CHAR and CHARS(1). - * ch-lang.c, toplev.c, ch-tree.h (flag_old_strings): New flag. - * ch-typeck.c (chill_similar): Support flag_old_strings. - * ch-convert.c (convert_to_boolean): Generalize code to - convert singleton bitstring to Boolean. - * ch-convert.c (convert): Use string_one_type_node. - * ch-convert.c (convert): Add code to convert Boolean to BOOLS(1). - * ch-convert.c (convert): In code that converts fixed string to - varying use new 'e' variable, rather than original 'expr' variable. - Allows cascaded conversions: CHAR -> CHARS(1) -> varying CHARS. - * ch-decl.c (string_type_node, const_string_type_node, - int_array_type_node), ch-tree.h: Removed. - * ch-decl.c (string_one_type_node, bitstring_one_type_node, - bit_zero_node, bit_one_node), ch-tree.h: New globals tree nodes. - * ch-decl.c (init_decl_precessing): Remove some junk. - * ch-expr.c (build_generalized_call): If flag_old_strings, - treat string index as string slice. Also, better error checking. - - Added support for (some kinds of) BASED declarations. - * ch-tree.def (BASED_DECL): New tree code. - * ch-decl.c (lookup_name): Implement BASED_DECL using - build_chill_indirect_ref. - * ch-decl.c (do_based_decls): Make a BASED_DECL. - * ch-parse.y: Call do_based_decls for DCL ... BASED(...). - * ch-satisfy.c (safe_satisfy_decl): Handle BASED_DECL. - - Improve handling of set binary operations. - * ch-expr.c (expand_packed_set): New function. - (fold_set_expr): Re-write. Simpler, more general algorithm. - (build_set_expr): Only used for comparsions now. - (finish_chill_binary_op): Handle set ops better (more directly). - (fold_set_and, fold_set_diff, fold_set_eq, fold_set_or, - fold_set_ne, fold_set_xor): Removed. No longer needed. - - * ch-decl.c: Remove calls to allocate_lang_decl. - * ch-tree.c (build_string_type): If const length, layout immediately. - -Mon Oct 11 17:23:02 1993 Bill Cox (bill@cygnus.com) - - * ch-decl.c (init_decl_processing): Define __whoami and - __wait_buffer functions. - * ch-lex.l (ch_lex_init): Reset tasking numbers to zero. - * ch-parse.y (sigdef): Add new add_taskstuff_to_list - parameter. - * ch-tasking.c (get_tasking_code): Search tasking_list for - tasking code name match. Can't use lookup_name. - (get_task_name): New function. - (generate_tasking_code_variable): Return if pass 1. - Always update *tasking_code_ptr. - (build_process_header): Add new add_taskstuff_to_list - parameter. - (tasking_setup): New code to unpack the tasking - list entries no built by .. - (add_taskstuff_to_list): Accept new parameter, - add it to the list. - * ch-tree.h (add_taskstuff_to_list): Add new - parameter. - -Mon Oct 11 14:54:50 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * Makefile.in (cc1chill): Also link in $(BC_OBJS). - -Mon Oct 11 06:28:39 1993 Doug Evans (dje@canuck.cygnus.com) - - * ch-decl.c (flag_allow_single_precision): New global, - from ss-931002 merge. - -Sun Oct 10 09:11:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Remove references to chill.in and - ch-hash.h. Remove bogus cc1chil : chill - dependency. - -Fri Oct 8 16:00:04 1993 Bill Cox (bill@cygnus.com) - - * ch-actions.c (adjust_parm_or_field): Add parameter to - decl_temp1 call. - *ch-decl.c (decl_tasking_code_var): Replace do_decl call with - decl_temp1 call. - (decl_temp1): Add parameter to signal 'make this external'. - (shadow_record_fields): Add parameter to decl_temp1 call. - * ch-expr.c (chill_expand_case_expr): Add parameter - to decl_temp1 call. - * ch-grant.c (chill_finish_compile): Add code to spoof - get_file_function_name, so we don't get __tmp_s1_code, - for example, as the module-level code's name. - * ch-loop.c (build_temporary_variable, begin_for_range, - init_loop_counter): Add parameter to decl_temp1 call. - * ch-parse.y (quasi_signaldef): Clear quasi_signal flag here, - for easier maintenance. - (sendaction): Rewrite to receive SIGNALNAME token correctly - from ch-lex.l (name_type_signal). - (signaldef): Don't clear quasi_signal here. - * ch-tasking.c (generate_tasking_code_variable): Tell decl_temp1 - to make the variable public (visible to linker). - (build_start_process): Add parameter to decl_temp1 call. - (tasking_setup): Comment out band-aid hack which calls - generate_tasking_code_variable. Shouldn't be necessary. - Use null_pointer_node rather than integer_zero_node in - entry_point. More rewrites. - (build_signal_descriptor): Name the non-signal in the error msg. - Rewrite the building of the signal envelope - avoid seg fault. - Add parameter to decl_temp1 call. - (expand_send_signal, build_receive_case_start, - build_receive_case_end, build_buffer_descriptor): Add parameter - to decl_temp1 call. - * ch-tree.h: Add parameter to decl_temp1 proto. - * chill: Add new CHILL frontend directory - -Tue Oct 5 13:51:27 1993 Bill Cox (bill@cygnus.com) - - * ch-grant.c: Standardize indentation. - * ch-parse.y (end_function): Unconditionally poplevel for processes. - * ch-tasking.c (build_process_header): Unconditionally pushlevel. - (generate_tasking_code_variable): Stop using pass number to - force a one-time action. - * ch-tree.h (build_chill_slice): Delete proto since function went static. - -Mon Oct 4 13:52:36 1993 Bill Cox (bill@cygnus.com) - - * ch-decl.c (decl_tasking_code_var): Use do_decl, since we're - called here in both passes. Set DECL_ASSEMBLER_NAME. - (lookup_name_for_seizing): Move NULL test forward to prevent - seg fault. - * ch-expr.c (finish_chill_binary_op): Mode access to TREE_CODE - to prevent a seg fault in telebras/dynsto.ch. Make indentation - changes. - * ch-tasking.c (build_signal_struct): Rename to build_signal_struct_type. - (build_send_signal): Rename to expand_send_signal. - (generate_tasking_code_variable): Return the var's decl. - (build_signal_struct_type): Move generate_tasking_code_variable - and add_taskstuff_to_list calls to .. - * ch-parse.y (sigdef): .. here. And make indentation changes. - * ch-tree.h: Rename functions, add return values. - -Mon Oct 4 15:43:56 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-convert.c (digest_constructor): Convert element to element_type. - * ch-parse.y (end_function): Use DECL_ARGUMENTS to check - for parameterless process. - -Fri Oct 1 13:57:30 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c (chill_location): New function. - Based on lvalue_p, but also handle Chill-specific VARY_ARRAY_REF. - * ch-typeck.c, ch-tree.h (CH_LOCATION_P), ch-convert.c: Use - chill_location instead of lvalue_p. - - -Fri Oct 1 11:28:42 1993 Bill Cox (bill@cygnus.com) - - * ch-convert.c (convert): Back out Michael's changes, unintentionally - checked in. - * ch-lex.l (handle_use_seizefile_directive): No longer downcase - seize file names. - * ch-parse.y (sendaction): Fix a couple of seg faults. Comment out - SEND BUFFER processing for now. - * ch-tree.h: Fix comment. - -Thu Sep 30 17:00:42 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (CH_CHARS_ONE_P, CH_BOOLS_ONE_P): New macros, - for recognizing singleton strings. - * ch-tree.h (MARK_AS_STRING_TYPE): New macro. - * ch-tree.c (build_string_type, build_bitstring_type), - ch-convert.c (convert): Use it. - * ch-typeck.c (build_chill_slice): Take length rather than upper - bound. This makes it easier to recognize that A(X UP LENGTH) - really has fixed length. Also, if the argument is string, - mark the slice as a string too. Also, handle varying strings. - - * ch-typeck.c (conflate_singleton_strings): New global. - * ch-typeck.c (chill_similar): If conflate_singleton_strings is - set (as it currently is), allow CHARS(1)/BOOLS(1) to be similar - to CHAR/BOOL, as required by the 1984 version of Z.200. - * ch-convert.c (convert_to_char): Convert CHARS(1) to CHAR. - * ch-convert.c ( build_array_type_for_scalar): If input is string, - so is output. - * ch-convert (maybe_turn_scalar_into_arra), ch-tree.h: Removed. - * ch-convert.c (convert): Convert CHAR to CHARS(1). - - This fixes 'X // := Y' and is also a general simplification. - * ch-actions.c (chill_expand_assignment): Convert 'LHS OP := RHS' - to 'LHS := LHS OP RHS' (using stabilize_reference on LHS). - Also, call save_expr on RHS if a multiple assignment. - * ch-parse.y (assignaction): Therefore, no longer need to call - stabilize_reference on RHS. - * ch-typeck.c (build_chill_modify_expr), ch-tree.h: Remove - modifycode parameter. Make it the caller's responsibility to - handle <assigning operator>. - * ch-actions.c, ch-decl.c, ch-except.c, ch-expr.c, ch-grant.c, - ch-loop.c: Fix calls to build_chill_modify_expr accordingly. - -Wed Sep 29 18:02:55 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lang.c (string_index_type_dummy), ch-tree.h: New variable. - * ch-decl.c (integer_minus_one_node), ch-tree.h: New variable. - - * ch-parse.y (arrayindex: modename): Remove useless code. - * ch-satisfy.c (satisfy): Don't gag on string_index_type_dummy, - * ch-tree.c (build_string_type): Pass string_index_type_dummy as - the parent type of the index range. - * ch-typeck.c (layout_chill_range_type): Recognize and handle - string_index_type_dummy - specifically allow an empty range. - -Wed Sep 29 13:36:23 1993 1993 Bill Cox (bill@cygnus.com) - - * ch-convert.c (convert_to_reference): Check for loc-identity - mismatches correctly (and remove one of those chill_compatible - calls). - * ch-decl.c (decl_tasking_code_var): New function, called from - push_extern_process and push_extern_signal. - * ch-parse.y (end_function): Delete parameter. Check current_function_decl - whether it's actually a process, and whether it has parameters. - Make Michael's change simplifying the pass 2 test, preventing a seg - fault. - (procedure, process): Change calls to end_function, remove - code saving value from build_process_header. Delete redundant chill_ - phrases from some function calls. - * ch-tasking.c: Remove some redundant _chill phrases from function - names. - * ch-tree.h: Remove some redundant _chill phrases from function - names. Add the CH_VARYING_ARRAY_TYPE macro, call it from - all relevant places. - * ch-typeck.c: Use the new macro. Cast TREE_CODEs to chill_tree_code. - -Wed Sep 29 13:07:43 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-convert.c (convert_to_reference): Remove redundancies. - * ch-convert.c (convert): Handle convert_to_reference - with a recursive convert call. - * ch-decl.c (do_decl): Add missing compatibility-checking - of initializer (don't depend on convert). - -Tue Sep 28 00:02:25 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (CH_LOCATION_P): New macro. - * ch-typeck.c (layout_chill_range_type): Fix call to - type_for_size, when figuring out a defaulted parent type. - * ch-expr.c (build_chill_lower, build_chill_sizeof): Check - for TREE_CODE_CLASS != 't' rather than == 'd'. - * ch-expr.c (build_chill_function_call): Use CH_LOCATION_P - to check for location, rather than TYPE_CODE_CLASS == 'd'. - - * ch-tree.c (build_string_type): Make 2-pass safe. Also, - change parameter to be length, not index type. - * ch-parse.y (mode2), ch-expr.c (build_concat_expr), ch-lex.l - (build_chill_string): Modify callers of build_string_type accordingly. - * ch-lex.l (check_newline): Don't look for # directive inside a - C-style comment. - * ch-grant.c (grant_array_type): Make more robust for char- - and bit-strings (allow non-constant sizes). Change parameters - and return types. (raw_decode_mode): Use grant_array_type - for bitstrings. (otherwise): Fix grant_array_type callers. - -Mon Sep 27 16:57:57 1993 Per Bothner (bothner@kalessin.cygnus.com) - - Remove changes of Sep 15. - * ch-tree.h (CH_SINGLETON_DOMAIN): Removed. - * ch-typeck.c (chill_similar): Don't allow a singleton - powerset to be similar to its domain. - * ch-convert.c (convert_to_boolean): Don't convert a singleton - SET_TYPE constructor to a Boolean. - - * ch-actions.c (chill_expand_assignment): Handle IN_EXPR on - LHS of assignment, which is what we're current (temporarily?) using. - -Mon Sep 27 06:01:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-convert.c, ch-decl.c, ch-expr.c, - ch-grant.c, ch-inout.c, ch-parse.y, ch-satisfy.c, - ch-tasking.c, ch-tree.c, ch-tree.h, ch-typeck.c: - -Wall cleanup. Add prototypes where missing. - Delete unused variables. Cast uses of tree_codes - to chill_tree_code, which they are. - -Sun Sep 26 13:09:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_decl): Save initializer in pass zero - case also. - * ch-lex.l: Fix comments, indentation. - * ch-parse.y: Standardize error messages to use - uppercase for CHILL keywords rather than quoting them. - Suggestion from docs department. - * ch-tasking.c: Pervasive changes to get processes to - compile and START. - * ch-tree.h: Delete prototypes for functions whic - I made static inside ch-tasking.c. - -Sun Sep 26 02:40:02 1993 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-lex.l (yywrap): Call `check_newline' in case the file - started with a line directive. - -Sat Sep 25 13:54:41 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c: Expand pre-amble comment. - * ch-decl.c (struct scope, push_module): Use new field - tail_chain_module to build child-module list in order. - (Just to make compiler debugging a little less confusing.) - - * ch-decl.c (struct scope): New field weak_decls. - * ch-decl.c (find_implied_types): New interface. Now pre-pend - new enum types to a given input list. This makes it easier to - avoid duplicates, which should at least be more efficient. - Also, handle FUNCTION_DECL. - * ch-decl.c (bind_saved_names): Removed. Distribute its - functionality over new functions (push_scope_decls, pop_scope_decls, - build_implied_names, bind_sub_modules). The goal (which seems to - have been more-or-less attained) was to fix weak name handling. - * ch-decl.c (poplevel): Use new function pop_scope_decls. - - * ch-tasking.c (build_signal_struct, build_tasking_message_type): - Use build_decl directly, rather than grok_chill_fixedfields - (which depends on ignore_exprs and has more overhead). - * ch-tasking.c (build_signal_struct): Construct the type - only in pass 1. - * ch-typeck.c (build_chill_slice): Use my_build_array_ref rather - than build_array_ref (which does C-specific "optimizations"). - (Hence move my_build_array_ref up earlier in the file.) - -Sat Sep 25 03:47:28 1993 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-tasking.c: Declare static variable `void_ftype_void'. - (chill_tasking_init): Initialize `void_ftype_void' here. - (build_tasking_struct): Use, don't declare `void_ftype_void'. - (generate_tasking_code_variable): Call `do_decl', not - `decl_temp1' to declare TASKING_CODE_NAME. - (tasking_setup): Drop into 1-pass mode so that all - tasking-related declarations are installed in the global - scope. Use correct CHILL types for initializers (since - ptr_type_node doesn't have the right meaning for CHILL). - Also, call `do_decl' instead of `decl_temp1' for - `init_struct'. - (add_taskstuff_to_list): Set TASKING_LIST in pass 1 to keep - `chill_finish_compile' in sync between passes. - - * ch-decl.c (do_decl): Set DECL_ASSEMBLER_NAME for - declarations on pass zero. Keep obstacks in sync, and always - call `finish_decl' for pass zero declarations. - (push_chill_extern_function): Keep obstacks in sync, and always - call `finish_decl' for pass zero declarations. - (build_enumerator): Ditto. - (grok_chill_variantdefs): Change PASS test to exclude only - pass one. - (finish_struct): Ditto. - * ch-expr.c (build_chill_component_ref): Ditto. - (build_chill_binary_op): Ditto. - * ch-tree.c (build_powerset_type): Ditto. - (build_bitstring_type): Ditto. - * ch-typeck.c (build_chill_range_type): Ditto. - (build_chill_struct_type): Ditto. - - * ch-decl.c (build_chill_exception_decl): Clarify reasons for - extra pushing and popping of obstacks. - - * ch-inout.c (build_chill_io_list_type): Call `satisfy_decl' - on IO_DESCRIPTOR. This causes IO_DESCRIPTOR to be laid out. - - * ch-grant.c (chill_finish_compile): Clear out both - MODULE_INIT_LIST and TASKING_LIST if either contains stuff - from pass one. - - * ch-parse.y (rccase_label): Add NAME rules so that pass one - works w/o knowing we're parsing a signal. Simplify SIGNALNAME - rules since we only get SIGNALNAME tokens in pass two. - (sendaction): Ditto. - * ch-lex.l (name_type_signal): Enable returning SIGNALNAME and - BUFFERNAME on pass two. The grammar now handles this. - * ch-decl.c (lookup_remembered_decl): Deleted. - -Fri Sep 24 15:27:13 1993 Bill Cox (bill@cygnus.com) - - * ch-decl.c (lookup_remembered_names): Removed. It was being - misused in ch-lex.l. - * ch-lex.l (name_type_signal): Revert last change. Basically, - we cannot use the C typedef/variable name trick in CHILL, due - due to the language's 2-pass nature. - * ch-parse.y (arrayindex): Rewrite for correctness, and to avoid - a seg fault. - * ch-tree.h (lookup_remembered_name): Comment out the prototype. - -Fri Sep 24 11:01:31 1993 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-decl.c (do_decl, push_chill_extern_function): Change pass - checks so the pass == 0 case is handled for built-in types. - (push_modedef): Add check for error_mark_node. - (lookup_remembered_decl): New function. - (pushlevel, poplevel) Change pass checks. - (pushdecl): Check type as well for NULL. - (build_enumerator): Handle pass == 0 case. - * ch-lex.l: Use lookup_remembered_decl to get lastiddecl - during pass 1. - * ch-parse.y: Set pass to zero to indicate initial decl processing. - Replace NAME references with SIGNALNAME references. - (startaction): Only check copy number if not ignoring actions. - Always call build_chill_start_process. - (optstartset): Don't lookup the instance name. - * ch-tasking.c (generate_tasking_code_variable): Replace - do_decl call with decl_temp1 call. - (build_chill_start_action): Check for ignore_actions here. - (build_tasking_message_type): Layout the type. - (rc_state_type): New structure to keep nested receive-case - info in. - (build_chill_receive_case_start, build_chill_receive_case_end): - Use the new struct. - - -Fri Sep 24 04:19:15 1993 Michael Tiemann (tiemann@blues.cygnus.com) - - * ch-tasking.c (build_chill_receive_case_start): `namedecl' - should be a _DECL, not an IDENTIFIER_NODE. - -Thu Sep 23 18:18:24 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (find_implied_types): Handle VAR_DECLs. - - * ch-decl.c (print_lang_identifier): Print IDENTIFIER_OUTER_VALUE. - * ch-actions.c (chill_expand_result): Allow value-less RETURN. - * ch-expr.c (resolve_component_ref): Recognize error_mark. - - * ch-convert.c (digest_constructor): Handle a nested powerset tuple. - * ch-satisfy.c (satisfy): Use return value of layout_chill_range_type. - * ch-typeck.c (chill_similar): Repeatedly get parent modes - of ranges, not just once. - * ch-typeck.c (chill_root_resulting_mode), ch-tree.h: New function. - * ch-typeck.c (layout_chill_rang_type): Re-do type-checking - to follow Blue Book better (check for Compatibility). - - * ch-tree.h (CH_ROOT_RESULTING_MODE): New macro. - * ch-lex.l (use_seizefile_name, current_seizefile_name), ch-tree.h: - New variables. The latter replaces in_seizefile. - - Changes to store in the new DECL_SEIZEFILE field each seize - ALIAS_DECL the name in the most recent use_seize_file directive. - (This requires that use_seize_file directives written to the - grant file be written before the SEIZEs that need it.) - Allow clashing declarations granted into the global scope - (produce a warning), but remember the seizefile case from - (using the DECL_SEIZEFILE field of the grant ALIAS_DECL). - The a SEIZE will select the granted decl that matches its - DECL_SEIZEFILE (in other words: grants from the most recent - use_seize_file will be preferred). - * ch-tree.h (DECL_SEIZEFILE), ch-tree.def: New macro. - * ch-tree.h (global_value, IDENTIFIER_GLOBAL_VALUE): Renamed - to outer_value, IDENTIFIER_OUTER_VALUE. - Changes to cause the use_seize_file directives to be written - out in order as they're seen in source. - * ch-lex.l (files_to_seize, next_file_to_seize, last_file_to_seize): - Changed to have type TREE_LIST of pointer to IDENTIFIER_NODE. - * ch-lex.l (handle_use_seizefile_directive): Modify appropriately. - Don't call grant_use_seizefile. - * ch-lex.l (mark_use_seizefile_written): New function. - * ch-grant.c (decode_decl): Write out use_seize_file directive, - if needed, before writing a seize declarations. - * ch-decl.c (pop_module): Handle decls granted into the global - module specially, setting IDENTIFIER_OUTER_VALUE. - * ch-decl.c (lookup_name_for_seizing): Check IDENTIFIER_OUTER_VALUE. - -Thu Sep 23 19:05:37 1993 Bill Cox (bill@cygnus.com) - - * ch-decl.c (push_chill_extern_process): Delete unused variables, - declare the process' tasking_code variable as external. - * ch-parse.y (process): Force ignore_exprs to FALSE while parsing - the process header. - * ch-tasking.c (sigdef): Move resetting of quasi_signal from here - to (signaldef). - * ch-tree.h: Add prototype. - * expr.c (store_constructor): Emergency first-aid. Rewrite later. - -Thu Sep 23 12:57:53 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c (build_chill_function_call): Move possible call to - chill_start_module_code until we know we're not calling a builtin. - * ch-decl.c (save_expr_under_name): Use pushdecllist, - not proclaim_decl (which provide for popping the decl). - * ch-parse.y (optname): Also allow TYPENAME. - -Thu Sep 23 09:18:35 1993 Bill Cox (bill@cygnus.com) - - * ch-decl.c (print_lang_decl): Make weak name output more standard. - (print_lang_identifier): Make signal-data flag output more standard. - (push_chill_extern_process): Pass correct arg tree to - push_chill_extern_function. - (push_syn_decls, fixup_unknown_type, chill_modes_equiv): - Standardize function header layouts (Makes the tcov script - work better). - * ch-except.c (chill_finish_on): Standardize function header. - * ch-expr.c (fold_set_or): Standardize function header. - * ch-grant.c (print_proc_tail, print_proc_exceptions): Standardize - function headers. - (decode_constant): Make sure that alpha operators are surrounded - with whitespace. - * ch-parse.y: Spell Z.200 correctly in comments. - -Wed Sep 22 10:42:31 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-expr.c (build_chill_addr_expr), ch-tree.h: New function. - * ch-parse.y, ch-decl.c (shadow_record_fields): Use it. - * ch-lex.l (handle_use_seizefile_directive): Don't emit - use_seize_file directive if in_seizefile. - - * ch-convert.c (digest_structure_tuple): Fix code that checks - for excess init values. - * ch-decl.c (layout_chill_variants): Move increment of nlabels - inside the proper loop. - * ch-grant.c (print_struct): Add missing loop for tag_list. - (print_struct): Look for variant fields by checking for a - UNION_TYPE, not a NULL name, since we must use a dummy name. - * ch-parse.y (structured_variable): Various fixing. - * ch-decl.c (shadow_record_fields): Rename arg decl -> struct_val. - - * ch-satisfy.c (safe_satisfy_decl): Disable copying of modes - for NEWMODE (and hence novelty checking), until we figure out - a better way. - - * ch-except.c (finish_handler_array): Use null_pointer_node, - not integer_zero_node (which fails to type-check). - - * c-typeck.c (get_constructor_element_type): New function. - * ch-tree.h (CH_NOVELTY_FLAG): Now also used in TYPE_DECLs. - (CH_NOVELTY): Redefined to call new function chill_novelty. - (CH_CLASS_IS_XXX, TYPE_NEWMODE, CH_CLASS_MODE): Removed. - * ch-typeck.c (classify_chill_expr renamed to chill_expr_class): - Take extra output parameter (for M, as in M-value class). - * ch-typeck.c (chill_novelty): New function. (Also de-references.) - - * ch-expr.c (resolve_component_ref, build_chill_component_ref): - New functions. Handle 2-pass and variant records. - * ch-parse.y (primval DOT name): Use instead of build_component_ref. - * ch-satisfy.c (satisfy, case COMPONENT_REF): - New case, call resolve_component_ref. - - * ch-expr.c (build_generalized_call): Extract single arg from - arg list before calling build_chill_cast. - - * ch-parse.y (defining_occurrence_list): New non-terminal. - Use it to replace locnamelist, synnames, and modenames. - * ch-parse.y: Re-write parsing of variant records. - - * ch-decl.c (grok_chill_variantdefs): Now return a FIELD_DECL - rather than just its type. - * ch-inout.c (build_chill_io_list_type), ch-parse.y: - Change callers appropriately. - - * ch-tree.h (TYPE_TAG_VALUES): Add an extra level of TREE_LIST, - to support multiple tag fields. - * ch-grant.c (print_struct), ch-decl.c (layout_chill_variants): - Support multiple tag fields. - - * ch-convert.c (remove_tree_element, digest_structure_tuple): - New functions, to digest structure tuples, without calling the - code in c-typeck.c. Handles variant tuples and tags (partially). - * ch-convert.c (digest_constructor, convert): Call - digest_structure_tuple when appropriate. - * ch-convert.c (digest_constructor): Re-arrange a bit. - - * ch-decl.c (push_modedef): Defer copying of tree until ... - * ch-satisfy (safe_satisfy_decl): ... here. - - * ch-decl.c (getdecls): Add kludge to help dbxout_init. - -Tue Sep 21 14:19:11 1993 Bill Cox (bill@cygnus.com) - - Partial tasking update - not done yet. - * ch-actions.c: Comments, indentation. - * ch-decl.c (push_chill_extern_process): No longer need to - reformat the arg list for make_process_struct. - (pop_module): Don't seg fault on null DECL_NAME. - (handle_one_level): Error, not warning if tree not recognized. - (shadow_record_fields): Rename formal param for readability. - * ch-grant.c (decode_decl): Write proper header for a process. - * ch-parse.y (quasi_pdef): process now uses processparlist, - which doesn't change with the passes. - (quasi_locdec): Call build_chill_reference_type to defer - doing the type's layout. - (processpar): Use paramnamelist, but reformat it into a - list of identifiers in pass 2, so a processpar is the same - structure in both passes. - (locdec): Call build_chill_reference_type to defer doing the - type's layout. - * ch-tasking.c (generate_tasking_code_variable): Call do_decl to - build the decl. Only update the variable's tree in pass 2. - (make_process_struct): Call build_chill_reference_type to defer - doing the type's layout. - (build_process_header): New code to call make_process_struct. - New pass-2 code to make a PARM_DECL for start_chill_function. - Pass a void_type_node, not a NULL_TREE for an empty list. - Get input for shadow_record_fields from current_function_decl. - (build_buffer_decl): Call do_decl not decl_temp1. - * ch-typeck.c: Reindent to standards. - * gcc.c (SPECS): Add recognition for the '.chi' CHILL suffix. - -Mon Sep 20 12:00:24 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c (classify_chill_expr): An expression with a - REFERENCE_TYPE still has VALUE class, even if an ADDR_EXPR. - * ch-actions.c (adjust_parm_or_field):, ch-tree.h: Change last - parameter, so we can reliably recognize LOC parameters. - * ch-tasking.c, ch-expr.c: Change callers appropriately. - -Sun Sep 19 22:26:25 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (CH_READ_COMPATIBLE, CH_REFERABLE): New macros. - * ch-typeck.c (chill_referable, chill_read_compatible): New functions. - * ch-typeck.c (chill_compatible): Allow un-resolved CONSTRUCTOR - (with NULL TREE_TYPE), when reasonable. (Simplifies callers.) - Also, handle case of expr being of reference class. - * ch-actions.c (adjust_parm_or_field): Major re-arrange - to handle conversions and LOC args better. - * ch-actions.c (chill_expand_assignment): Simplify conversions. - * ch-expr.c (build_chill_function_call): If needed, call - chill_start_module_code. - * ch-decl.c (declare_predefined_file): New function, used - to pre-define stdin, stdout, and stderr. - * ch-inout.c (chill_stdio_p): Change names of predefined - files from chill-stdin etc to plain stdin (and change their types). - * ch-lex.l: Remove some obsolete stuff. - * ch-convert.c (convert): Move conversion from reference to - to beginning of convert() so other conversion can work better. - Also, remove bogus direct setting of TREE_TYPE. - -Fri Sep 10 12:23:41 1993 Wilfried Moser (fs_moser@cygnus.com) - - * Makefile.in: Change installation of the chill script. gcc will - be called always with the full path. That made problems when - somebody was using chill but didn't have the installation - directory in PATH. - * ch-parse.y: Change parsing of WRITETEXT action. - * ch-tree.h: Add some new prototypes according to the - (partial) implementation of WRITETEXT. - * ch-typeck.c: Add new function chill_varying_string_type_p. This - functions checks a type for being CHAR(n) VARYING. - * ch-decl.c (init_decl_processing): Add new built-in functions - _writestring and _writeunixstd. - Add call to build_chill_io_list_type in ch-inout.c. - * ch-inout.c (build_chill_writetext): Add some code there. - Add new function build_chill_io_list_type. - Add new static function chill_stdio_p. This function checks - the text argument for being chill_stdin, chill_stdout or - chill_stderr. - -Fri Sep 17 22:02:04 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (push_modedef): Fix TYPE_MAIN_VARIANT thinko. - -Thu Sep 16 18:38:53 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (allocate_lang_decl): Do nothing. - * ch-tree.h (struct lang_decl, DECL_GRANT_FILE, DECL_SEIZE_FILE): - No longer used; remove. - - * ch-tree.h (TYPE_TAG_FIELD renamed to TYPE_TAGFIELDS), ch-grant.c - (print_struct), ch-parse.y (opttagfield -> opttagfields), ch-decl.c - (make_chill_variants, layout_chill_variants): Add (initial) part - of support for multiple tags. - * ch-decl.c (lookup_tag_fields): New function. - * ch-parse.y (stmt_count): Not used; removed. - * ch-parse.y (mode2): Clear current_fieldlist before - parsing STRUCT fields; restore afterwards. - - * ch-parse.y (push_action): Moved to ch-actions.c. - -Wed Sep 15 18:19:37 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c (convert_to_boolean): Convert a SET_TYPE - constructor to a boolean. - -Wed Sep 15 17:52:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (push_modedef): Enable novelty-setting code. - * ch-tree.h (CH_SINGLETON_DOMAIN): New macro. - * ch-typeck.c (chill_similar): Add checking of singleton - powerset against its base type. - -Tue Sep 14 17:11:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (adjust_parm_or_field): Create a - temporary for an non-referencable actual parameter - passed to a LOC formal parameter. - (chill_expand_assignment): Correct compatibility checking. - - * ch-decl.c (push_modedef): Set up a type's NOVELTY value. - * ch-parse.y (opsigdest): Only check for process name - in pass 2, when we know. - * ch-tree.h (CH_NOVELTY_FLAG, CH_NOVELTY): Define. - * ch-typeck.c: Fix comment. - -Mon Sep 13 17:33:11 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-grant.c (lookup_decl_in_process, register_decl_as_output, - decl_seen_p, processed_decls, allocated, nr_decls): Removed - no-longer-useful functions and variables that used to guard - against writing a decl multiple times. Since we now just - go through the decl list linearly, that is no longer an issue. - * ch-satisfy.c (safe_satisfy_decl): Handle missing current_module. - - * ch-decl.c (start_chill_function): Clear DECL_ASSEMBLER_NAME. - Don't make TREE_PUBLIC. Don't generate rtl yet. - * ch-decl.c (pop_module): If a decl is granted, set TREE_PUBLIC, - and its DECL_ASSEMBLER_NAME. - * ch-decl.c (fix_identifier): New function. - * ch-grant.c (grant_one_decl): Don't set TREE_PUBLIC. - * ch-tree.h (struct module): New field prefix_name. - * ch-satisfy.c (safe_satisfy_decl): If assembler_name isn't - set, prefix it by the module name(s). - * ch-satisfy.c (safe_satisfy_decl, case FUNCTION_DECL): - Call make_function_rtl if needed and !LOOKUP_ONLY. - * ch-typeck.c (chill_similar): Flesh out substantially. - * ch-typeck.c (chill_compatible): Re-structure. - - * ch-actions.c (adjust_parm_or_field): Use CH_COMPATIBLE - instead of chill_comptypes to compare actual and formal. - -Sun Sep 12 21:10:10 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-parse.y (labellist): Don't do anything if ignore_exprs. - - * c-typeck.c (output_pending_init_elements): Handle - !constructor_incremental case of filling in empty positions. - (Patch by Jim Wilson. CYGNUS LOCAL until we have approval.) - * ch-decl.c (pop_module): Don't grant a seized name. - * ch-grant.c (decode_constant): Support CALL_EXPR. - * ch-tree.c (build_bitstring_type): Don't try to fold non-constant - size if pass==1 (since it may be an unsatisfied name). - - -Sun Sep 12 18:06:23 1993 Bill Cox (bill@rtl.cygnus.com) - - 2-pass fixes for processes. Partially done. - * ch-actions.c (chill_expand_assignment): Add real - novelty-checking sketch, $ifdef'd out for now. - * ch-decl.c: Generally fix indentation. Move tasking - init code from init_decl_processing to ch-tasking.c. - Delete ObjC-related cruft. More accurate parameter name - for shadow_record_fields. Move debug_scope before - its first call. - * ch-expr.c (build_chill_function_call): Return if not - pass 2. - * ch-grant.c (print_proc_tail): Avoid trying to format - a VOID return type, or using a NULL pointer. - (decode_decl): Minor changes for PROCESS arg access. - * ch-lang.c (lang_decode_option): Use -itu flag to - enable 'pedantic' mode. - * ch-lex.l (init_lex): Initialize compiler-directive - variable trees. - (name_type-signal): Disable the returning of SIGNAL and BUFFER - name tokens. - * ch-parse.y (rccase_label_flag): Renamed from rccase_ifs. - All uses renamed also. - (end_function): Always poplevel, not just in pass 2. - (quasi_pdef): Check for end-label matching. - (quasi_formparlist): Write more clearly. - (rcaltlist, optelsercvcase, optstartset): Add ignore_actions - guards. - (rccase_label, sendaction): Use NAME, not SIGNALNAME - or BUFFERNAME. - (process): Handle like procedure. - (mode): Add SIGNAL as a generic signal parameter. This - is a client-specific extension, so pedantic is checked. - * ch-tasking.c: Pervasive rewrites for 2-pass. Still not done. - * ch-tree.h (CH_NOVELTY): Make it an lvalue. - * ch-typeck.c: Fix comment. - -Sun Sep 12 15:03:21 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * c-typeck.c (digest_init): Compare types using comptypes - instead of comparing pointers. (Helps Chill front end.) - * ch-expr.c (finish_chill_binary_op): - * ch-typeck.c (build_chill_array_ref, build_chill_bitref), - ch-expr.c (finish_chill_binary_op): For now, prefer IN_EXPR - over BIT_FIELD_REF because of various problems with BIT_FIELD_REF - (incomplete support for variable fields, and possible bug in - optimize_bit_field_compare). - * ch-expr.c (finish_chill_binary_op): Fix type-checking - and appropriately coerce operands for IN_EXPR and comparsions. - * expr.c (expand_expr, case ARRAY_REF): Coerce lower bound (if - non-zero) to sizetype before subtraction. - * expr.c (expand_expr): Remove Chills-specific calls to - __inpowerset from case BIT_FIELD_REF to case IN_EXPR. - -Fri Sep 10 15:47:52 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.def (UNDEFINED_EXPR): New kind of expression. - * ch-grant.c (decode_constant), ch-expr.c (chill_expand_expr), - ch-convert.c (convert): Handle UNDEFINED_EXPR. - - * ch-expr.c (build_char_array_expr): Move CONCAT_EXPR support to ... - * ch-expr.c (build_concat_expr): ... here. - Now also folds concatenation of STRING_CST and UNDEFINED_EXPR. - Also, make result varying only if one of the operands are. - - * ch-expr.c (build_chill_binary_op): Move stuff from here to ... - * ch-expr.c (finish_chill_binary_op): ... here, as needed for - proper 2-pass split. Also, clean up and simplify heavily. - - * ch-tree.h (enum ch_expr_class): The 5 kinds of expression classes. - * ch-typeck.c (classify_chill_expr): New function: Determine - class of expression. - * ch-typeck.c (chill_compatible_classes): Re-structure; fix - asymmetry bugs. - * ch-tree.h (CH_CLASS_IS_XXX): Re-define to use classify_chill_expr. - - * ch-convert.c (maybe_turn_scalar_into_array): Complain - unless scalar is a char constant (and we want a string). - * ch-convert.c (convert): New code for converting to variable - string/array. Avoid type errors by padding (with an UNDFIEND_EXPR). - * ch-typeck.c (chill_expand_tuple): Don't do conversion to - varying type here; that is handled by convert now. - * ch-decl.c (digest_constructor): Moved to ... - * ch-convert.c (digest_constructor): ... here. - * ch-decl.c (do_decl): Simplify; just use convert for initializer. - * ch-decl.c (chill_digest_init): Merged into convert, and removed. - * ch-decl.c (init_decl_processing): Set constructor_no_implicit flag. - * ch-except.c (finish_handler-array), ch-decl.c (finish_decl): - Replace chill_digest_init by convert. - * ch-actions.c (chill_expand_array_assignment): Simplify; use convert. - * ch-lex.l (build_chill_string): Make string type be derived - from integer, not sizetype, because upper bound can be -1. - -Thu Sep 9 18:21:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-typeck.c (my_build_array_ref): Delete pedantic - C-specific error message. - -Thu Sep 9 17:44:20 1993 Jeffrey Wheat (cassidy@eclipse.cygnus.com) - - * gcc.c: pass {I*} spec to cc1chill. Fixes -Ifoo not working problem. - -Thu Sep 9 12:22:22 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c (build_chill_array_ref): Remove redundant and - broken call to my_build_array_ref. - -Wed Sep 8 13:03:49 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-except.c (finish_handler_array), ch-decl.c (finish_decl): - Don't use store_init_value, since it calls digest_init instead - of chill_digest_init. - * ch-except.c (finish_handler_array): Use build1 (ADDR_EXPR, ...) - instead build_unary_op to avoid C-specific optimizations. - * ch-typeck.c (my_build_array_ref): Don't use default_conversion - to convert array to pointer. - * c-typeck.c (process_init_default): New function, to support - default values for array tuples in Chill. - * c-typeck.c (default_conversion): Don't convert array to pointer - if compiling Chill. - * ch-decl.c (digest_constructor): New function; used to be guts - of chill_digest_init. Now recursive, to handle nested tuples. - - * ch-decl.c (chill_digest_init): Handle struct labels. - * ch-grant.c (get_tag_value): Use decode_constant in general case. - * ch-grant.c (decode_constant): Add support for lots of missing - binary and unary operators. - -Wed Sep 8 10:11:04 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lang.c: Look for '-I' option for seize file path. - * ch-lex.l: Fix comment about above option. - -Wed Sep 8 00:37:32 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-satisfy.c: Move code to set (and restore) file-and-line - from satisfy_decl to safe_satisfy_decl, for the sake of satisfying - alias decls that refer to real decls with errors. - * ch-actions.c (lang_init): Move to ch-lang.c. - * ch-decl.c (init_decl_processing): Move code to initialize - file-and-line from here ... - * ch-lang.c (lang_init): ... to here, to avoid clobbering. - - * ch-decl.c (chill_digest_init): Add support for SET_TYPE, - and index values. - * ch-typeck.c (chill_expand_typle): Just call chill_digest_init. - * c-typeck.c: Fix various things that got broken - in the latest merge. - -Tue Sep 7 15:45:58 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (build_enumerator): Handle a "unnamed set element" - (obsolete feature) by generating a dummy name. - * ch-decl.c (finish_decl): Call rest_of_decl_compilation with - "correct" value of top-level (to get better debugging output). - * ch-decl.c (bind_saved_names): Allow a null DECL_NAME. - -Tue Sep 7 15:48:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_expand_return): Correct breakage - due to recent fsf merge. - -Tue Sep 7 11:16:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: Add multilib.h. - * ch-decl.c (chill_digest_init): New function. Calls were - changed, since it has fewer parameters than old digest_init. - * ch-parse.y (untyped_expr, primval, tupleelement): Calls to - new init stuff. - (elementlist): Delete unused code. - * ch-satisfy.c (safe_satisfy_decl): Just return if decl == NULL. - * ch-tasking.c (build_tasking_enum): Attempt to adapt to 2-pass. - * ch-tree.h: Delete digest_init prototype. - * ch-typeck.c (digest_init): Much new code. - -Tue Sep 7 12:06:28 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c, ch-parse.y, ch-tree.h, ch-typeck.c: Revert - files to their pre-init-change state. - -Mon Sep 6 15:28:27 1993 Bill Cox (bill@rtl.cygnus.com) - - Preliminary adaptation to rms' new initializer code. - * ch-decl.c (do_decl): Call chill_digest_init, not - digest_init, which rms made static. - * ch-expr.c (chill_truthvalue_conversion): Delete C- - specific code. - * ch-loop.c (init_loop_counter): Indent for readability. - * ch-parse.y (untyped_expr, primval, tupleelement): Call new init code. - * ch-tree.h: Prototype changes for new init code. - * ch-typeck.c (chill_expand_tuple): Call new init code. - * chill.texi: Add necessary '-f' prefix on options. - -Wed Sep 1 13:21:53 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-convert.c (build_array_type_for_scalar), - ch-tasking.c (build_chill_receive_case_end): Index type - specification is now chain of types (not chain of TREE_LIST). - * ch-satisfy.c (satisfy): Don't try to satisfy the - abstract_origin of an ALIAS_DECL if DECL_POSTFIX_ALL. - * ch-expr.c (build_chill_binary_op): If pass 1, do NOT - call finish_chill_binary_op. - * ch-parse.y (arrayindex): Simplify. - -Tue Aug 31 14:57:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (print_lang_decl): Print weak-name status. - (print_lang_identifier): Print signal_data as T or F. - * ch-lex.l (convert_bitstring, convert_charliteral, - convert_float, convert_number): Pass string directly to convert - as a parameter. Return token code consistently, return 0 - for error. - (equal_number): Parse differently, allowing hex, binary - and octal constants. - * ch-parse.y (dowithaction, structured_variable): Only - push/pop scopes once per DO WITH. - (structured_variable_list): Check ignore_actions flag here. - * gcc.c: Delete 'traditional' from string, add 'itu' - as the standard flag's name. - -Mon Aug 30 15:12:26 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-typeck.c, ch-tree.h (build_chill_range_type): Take 3 - parameters instead of 2 (explicit low and high bounds). - * ch-parse.y (arrayindex): Build range type from low:high. - (rangesize, optrangesize): Removed. - (where appropriate): Use new build_chill_range_type interface. - * ch-grant.c: Clean up writing of range and array types. - * ch-satisfy.c (satisfy): Don't ignore the return value of - layout_chill_array_type. (It may be an error mark.) - * ch-typeck.c (build_chill_array_type): Simplify. - * ch-typeck.c (layout_chill_array_type): Clean up checks. - -Fri Aug 27 12:55:59 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (decl_temp1): Set DECL_ASSEMBLER_NAME. - (push_chill_extern_function) Don't set current_function_decl. - * ch-parse.y (tupleelement): Don't wrap index is a TREE_LIST - (i.e. a range), don't wrap a PAREN_EXPR around it. - * ch-grant.c (decode_constant): For tuple CONSTRUCTORs, - add support for ranges in purpose. - -Wed Aug 25 16:58:13 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: Add g++.sum - * ch-actions.c (chill_expand_result): Stop building a temp. - Assign the expression directly into function's DECL_RESULT. - * ch-decl.c: Add formfeeds. - (start_chill_function): Don't need to zero DECL_RESULT's pointer any more. - (push_chill_function_context): Delete C pedwarn message. - * ch-expr.c: Move builtin functions together. - * ch-parse.y (end_function): Delete unused code. - Reformat %union for readability. Delete _MAX and _MIN - tokens. - -Wed Aug 25 13:24:06 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (get_result_tmp_name): Delete unused function. - (chill_expand_result, chill_expand_return): Rewrite for - 2-pass. - * ch-decl.c (start_chill_function): NULL out the RESULT_DECL's - chain field, so we can make a temp, evaluate a RESULT action's - expression into it, and hang it on here. - * ch-parse.y (end_function): Look for RESULT temps to emit. - (assertaction): Indentation. - -Wed Aug 25 08:34:36 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l, ch-parse.y: Delete CONTINUE_EVENT token. - It wasn't used anyway. - -Tue Aug 24 17:51:18 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_expand_result, chill_expand_return): - No need to make a temp for the value, just use DECL_RESULT. - -Tue Aug 24 16:38:24 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.c (layout_powerset_type): Remove redundant code. - Generalize (in error message) to also handle bitstrings. - * ch-tree.c (build_bitstring_type): Remove all layout-like - stuff, and defer that to layout_powerset_type. - * ch-expr.c (chill_expand_expr): For various SET_xxx_EXPRs, - allocate stack temp for target using correct mode. - -Tue Aug 24 10:27:19 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-decl.c, ch-except.c, - ch-grant.c, ch-lang.c, ch-loop.c, ch-tree.h, - ch-typeck.c: Change build_modify_expr calls to - build_CHILL_modify_expr calls. - * ch-expr.c (build_chill_modify_expr): Adapted from - build_modify_expr in c-typeck.c. - -Mon Aug 23 16:48:39 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-convert.c, ch-decl.c, ch-expr.c, - ch-grant.c, ch-lang.c, ch-lex.l, ch-loop.c, - ch-satisfy.c, ch-tasking.c, ch-tree.c, ch-typeck.c: - Major re-allocation of functions to files. - -Mon Aug 23 12:15:11 1993 Bill Cox (bill@rtl.cygnus.com) - - Thanks for the tip, Jim. - * Makefile.in: Add dependency lines for ch-except.o and - ch-satisfy.o. Correct dependency lines for ch-convert.o, - ch-expr.o, ch-inout.o, and ch-loop.o. - (chill, install-common): Add clean-up commands. - -Sat Aug 21 17:11:26 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (get_type_precision): New function. - (layout_enum): Call it. - * ch-tree.c (layout_powerset_type, build_bitstring_type): - Call it. - -Sat Aug 21 13:59:40 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Define setbitpowerset - runtime function. - * ch-expr.c (chill_expand_assignment): Call setbitpowerset - to set a bit. - * ch-parse.y: Indentation. - -Fri Aug 20 17:29:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y: Delete unused %type declaration. - * ch-tasking.c (build_signal_struct): Delete return, since - function returns void. - * ch-typeck.c: Indent to standard. - * stor-layout.c: Fix comment. - * toplev.c: Change -L option ti -I. - * varasm.c (emit_set_data): Align set constant to word - boundary. - -Fri Aug 20 08:20:07 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Fix indentation, comments. - * ch-decl.c (push_chill_extern_signal): Use same interface - as build_signal_struct. - * ch-parse.y (quasi_signaldef): Move build_signal_decl - here to sigdef. Add quasi_signal to distinguish contexts - where sigdef gets used. - * ch-tasking.c: Replace make_signal_struct and build_signal_decl - with build_signal_decl, which doesn't loop through a - TREE_LIST. - * ch-tree.h: Fix protos. - -Wed Aug 18 17:36:53 1993 Bill Cox (bill@cygnus.com) - - * ch-actions.c: Fix comments. - * ch-decl.c (push_modedefs): Return the new decl. - (shadow_record_fields): Move pushlevel (0) calls into - the grammar, so they'll get done in both passes. - * ch-parse.y (dowithaction): Always compute & save # of - 'with' variables seen (both passes), and always pop that - number of levels. - (structured_variable_list): Always chain variables into a list. - (structured_variable): Put pushlevel here (from shadow_record_fields). - * ch-tasking.c: Indentation fixes. - * ch-tree.h: Change proto. - * chill.texi: Add Blue Book section numbers to unimplemented - features list. - -Wed Aug 18 15:48:43 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-actions.c (build_generalized_call): New function. - Classifies semantically (if pass 2) this that look like calls. - * ch-parse.y (call): Invoke build_generalized_call. - * ch-parse.y (sigdef): Use defining_occurrence instead of NAME. - * ch-parse.y (opt_untyped_exprlist): New non-terminal. - * ch-satisfy.c (satisfy): Handle CALL_EXPR. - -Tue Aug 17 16:36:15 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (find_implied_types): Handle INTEGER_TYPEs (ranges). - -Mon Aug 16 18:07:36 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.h (TUPLE_NAMED_FIELD): New macro. - * ch-parse.y (labelled structure tupleelement): - Set TUPLE_NAMED_FIELD flag. - * ch-grant.c (decode_constant): Check for TUPLE_NAMED_FLAG. - * ch-satisfy.c (satisfy): Check for TUPLE_NAMED_FLAG. - Do satisfy the elements of a CONSTRUCTOR even if call - chill_expand_tuple isn't correct. - * ch-satisfy.c (satisfy): Satisfy TYPE_TAG_VALUES of a RECORD_TYPE. - * ch-parse.y (label_spec): Defer any semantic checking until ... - * ch-decl.c (layout_chill_variants): ... here. - Also make sure to call layout_type on the union type. - * ch-decl.c (bind_saved_names): For weak names, allocate an - ALIAS_DECL, rather than a CONST_DECL. - - Add support for implied (weakly visible) names. - * ch-tree.h (DECL_WEAK_NAME): New macro. - * ch-satisfy.c (satisfy of IDENTIFIER_NODE): Don't complain - if lookup_name fails if LOOKUP_ONLY - name might be weakly visible. - * ch-decl.c (proclaim_name): Handle DECL_WEAK_NAME appropriately. - * ch-decl.c (concat_lists, find_implied_types): New functions. - * ch-decl.c (bind_saved_names): Search for implied names. - * ch-tree.h (C_DECL_VARIABLE_SIZE): Removed. - * ch-lang.c (layout_chill_struct_type): Don't use - C_DECL_VARIABLE_SIZE. - -Mon Aug 16 16:10:43 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Delete extra space in error message. - * ch-parse.y: Fix comment. - * expr.c (store_constructor): Avoid passing NULL to convert, - and getting back an error_mark_node and trying to process - *that* node. - -Mon Aug 16 14:41:29 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c: Add more overview comments. - * ch-decl.c (proclaim_decl): New function. - * ch-decl.c (temp_pushdecl, struct shadowing): Removed. - * ch-decl.c (bind_saved_names): Remove blevel parameter; - use current_scope global instead. Do some other cleanups. - * ch-decl.c (save_expr_under_name): Create an ALIAS_DECL. - * ch-decl.c (pushdecllist, save_expr_under_name): Use proclaim_decl. - * ch-satisfy.c (satisfy, safe_satisfy_decl): Be more careful - to not do inappropriate things (e.g. type layout) if LOOKUP_ONLY. - - * chill.texi: Start collecting Chill documentation here. - * ch-parse.y (mode): Ignore READ specifier, for now. - -Mon Aug 16 11:13:07 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_comptypes): Correct handling reference - of type 1. - (build_chill_length, build_chill_num, - build_chill_sizeof): Convert result to CHILL integer. - (build_chill_function_call): Clean up INOUT and OUT - parameter handling. - * ch-decl.c (build_chill_function_type): Handle INOUT and - OUT parameters. - * ch-loop.c: Fix up comments. - * ch-parse.y: Fix up comments. - -Sun Aug 15 15:06:01 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_lower, build_chill_upper): - Re-write, mostly to delete bogus ENUMERAL_TYPE handling. - * ch-decl.c (save_expr_under_name): New function to save - addressing expressions for DO WITH and DO FOR handling. - (handle_one_level): Call new function. - * ch-loop.c (init_loop_counter): Call it here, too. - Check lp->user_var before passing it to lookup_name. - (high_domain_value, low_domain_value): Correct call - to build_chill_upper and build_chill_lower. - (begin_chill_loop, end_chill_loop): Move pushlevel, - poplevel up into the grammar, so they're done in both - passes. - * ch-parse.y (doaction): Unconditionally make a scope - for a loop, pop it later. - (controlpart, iteration): Save return from - build_chill_iterator. - * expr.c: Readability changes. - -Sat Aug 14 19:42:32 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_case_expr): Complete rewrite - for 2-pass. About 1/2 the size, too. - * ch-parse.y (actionlabel): Unconditionally do INIT_ACTION. - This assures that a label preceding a module's first action - is enclosed in the module-level function that's generated. - -Sat Aug 14 14:56:07 1993 Per Bothner (bothner@kalessin.cygnus.com) - - Re-implement how EXIT is done. - 'LABEL: BEGIN ... EXIT LABEL; ... END' is converted to - 'LABEL: BEGIN ... GOTO EXIT!LABEL; ... EXIT!LABEL: ; END'. - Hence we no longer need any support for EXIT in stmt.c. - * stmt.c (stamp_nesting_label, expand_exit_labelled): Removed. - * ch-actions.c (lookup_and_handle_exit): Handle like 'GOTO EXIT!name'. - * ch-tree.c, ch-tree.h (munge_exit_label): New function. - * ch-parse.y: Re-write bracked actions to support EXIT new way. - * ch-decl.c, ch-loop.c: Remove calls to stamp_nesting_level. - * ch-parse.y: Replace SC by new token semi_colon, which - resets the 'label' global. Also make sure that label gets - reset whenever we might start a new action statement. - * ch-parse.y (possibly_define_exit_label): New function. - - * ch-except.c (chill_start_on): Wrap an ADDR_EXPR round the jmpbuf. - * ch-grant.c (chill_finish_compile): Make sure - get_file_function_name is only called once. - * ch-expr.c (chill_expand_array_assignment): Use store_expr, - instead of incorrectly calling emit_block_move. - - * ch-parse.y (procedure): Call push_chill_function_context - in *both* passes (if nested). - * ch-parse.y (primval): Call get_type_of before chill_expand_type. - * ch-parse.y (tupleelement): Only build PAREN_EXPR during pass 1. - -Fri Aug 13 16:36:36 1993 Per Bothner (bothner@kalessin.cygnus.com) - - Re-implement GRANT and SEIZE, to support prefixes and prefix - rename. All of the Blue Book semantics for these should - now work (except FORBID). - * ch-tree.def, ch-tree.h (DECL_OLD_PREFIX, DECL_NEW_PREFIX, - DECL_POSTFIX, DECL_POSTFIX_ALL): New ALIAS_DECL layout and macros. - * ch-tree.c (get_identifier3, build_alias_decl, decl_old_name, - decl_check_rename): New functions. - * ch-lex.h, ch-lex.l, ch-grant, ... (grant_all_seen): Removed. - * ch-satisfy.c (satisfy_decl): Handle SYN initialized with tuple. - * ch-satisfy.c (satisfy_decl): Set DECL_ASSEMBLER_NAME here ... - * ch-decl.c (pushdecllist): ... instead of here, which is too late. - * ch-grant.c (decode_prefix_rename): New function. - Use to print out GRANT and SEIZE statements. - * ch-decl.c (ALL_POSTFIX): New global variable. - * ch-decl.c (bind_saved_names, pop_module): Change to use new - ALIAS_DECL layout, and support general prefix rename and ALL. - * ch-decl.c (various places): Don't barf if DECL_ANME is NULL. - * ch-parse.y (build_prefix_clause): New function (handle PREFIXED). - * ch-parse.y (optprogendname, optname): Rename to opt_end_label. - * ch-parse.y: Add support for compound name strings, but defer - using all over teh place, due to parser ambiguities. - Howver, do use defining_occurrence where appropriate. - * ch-parse.y: Re-write syntax and semantics of GRANT and SEIZE - statements to support Blue Book functionality. Neato! - -Fri Aug 13 17:10:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Redo decl_temp1 calls to save resulting decl. - * ch-decl.c (decl_temp1): Rewrite to return generated decl. - (decl_temp): Deleted. - * ch-loop.c: Redo decl_temp1 calls to save resulting decl. - * ch-satisfy.c (safe_satisfy_decl): Reorder switch for - readability, add comment. - * ch-tasking.c: Redo decl_temp1 calls to save resulting decl. - * ch-tree.h: Delete decl_temp proto, change decl_temp1. - -Fri Aug 13 13:39:59 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (decl_temp): Break the chain of decls. This - prevents an infinite loop. - * ch-lang.c (make_chill_pointer_type): Fix compiler warning. - * ch-lex.l (equal_number): Check passes in looking up a - symbolic value. - * ch-parse.y: Fix comments. - * ch-tasking.c (tasking_setup): Only act in pass 2. - (make_signal_struct, build_signal_decl, - build_chill_receive_case_label): Don't go indirect - thru NULL decl pointer. - -Thu Aug 12 11:02:34 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (route_to_predefined_function): New function called - from build_chill_function_call, to call the proper predefined routine. - (build_chill_card, build_chill_length, build_chill_lower, - build_chill_max, build_chill_min, build_chill_num, - build_chill_pred, build_chill_sizeof, build_chill_succ, - build_chill_upper): Rewritten to run only in pass 2. - * ch-decl.c (init_decl_processing): Build predefined functions for card, - length, lower, max, min, num, pred, sizeof, succ and upper. Delete - unused builtin_function calls. - * ch-grant.c (chill_finish_module_code): Save current_function_decl - before calling finish_chill_function, and use that to build the - initializer structure. - * ch-lex.l: Remove following tokens, since they're now just predefined, - not reserved: card, length, lower, max, min, num, pred, sizeof, succ - and upper. - * ch-loop.c: Readability, indentation changes. - * ch-parse.y: Delete tokens for card, length, lower, max, min, num, pred, - sizeof, succ and upper. Delete special rules for calls to these. - Delete mode_location and upper_lower_arg non-terminals. - (pmodearg): Eliminate convolutions. - (call): Add rule for typename parameter. - * ch-tasking.c: Readability changes. - * ch-tree.h: Add prototypes. - -Thu Aug 12 00:38:17 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (save_decl): Set DECL_CONTEXT (decl). - * ch-grant.c (chill_finish_module_code): Call - finish_chill_function with nested==0. - * ch-tree.h, ch-decl.c, ch-tasking, ch-parse.y: Rename - {push,pop}_c_function_context to {push,pop}_chill_function_context. - * ch-parse.y (end_function): If nested, call - pop_chill_function_context regardless of which pass we're in. - -Wed Aug 11 02:34:02 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-actions.c (finish_chill_binary_op): Handle error marks. - * ch-decl.c (do_decl): Laying out decl and generating rtl - is too late to do here (if there are forward references), so ... - * ch-satisfy.c (satify_decl): ... do it here instead. - * ch-decl.c (finish_enum): Fixup types of enum decls now. - * ch-satisfy.c (safe_satisfy_decl): New routine. Supports - checking illegal cyclic definitions. - All *satisfy* routines now take a 'chain' parameter (instead - of 'lookup_only') used for checking cycles. - * ch-satisfy.c (satisfy_decl): Return DECL_INITIAL if appropriate. - * ch-satisfy.c (satisfy): Lots of little fixes. - - * ch-lex.l (init_lex): Make all the standard ridpointers be - lowercase, so that lookup_name on lower-cased user input - will find the standard types. - * ch-lex.l: Remove all the standard types, in effect - converting them from reservered anmes to predefined names. - * ch-lex.l, ch-parse.y: Remove PREDEF_MODEDECL - no longer used. - * ch-grant.c (gfile): Rename to grant_file_name. - * ch-lex.l (yywrap): Don't try to seize current grant_file_name. - - * initname.c: Removed. get_file_function_name is now in tree.c - * Makefile.in (CHILL_OBJS): Remove initname.o - - * ch-decl.c (do_decl): New function, based on loop body of do_decls, - * ch-decl.c (do_decls): Just call do_decl. - * ch-grant.c (chill_finish_module_code): Minor cleasnups. - Use new do_decl routine. Clear init_entry_decl's source line. - * ch-grant.c (print_proc_tail): Fix for new param list structure. - * ch-parse.y (whatpdef): Removed. Cleaned up procedure - and process, allowing proper end-label-checking. - * ch-typeck.c (build_chill_cast): Remove decl->type conversion. - -Wed Aug 11 00:33:44 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (layout_enum): Don't call rest_of_type_compilation. - - * ch-lex.l (RETURN_PREDEF): Don't call lookup_name. - * ch-expr.c (build_chill_indirect_ref): Call get_type_of. - * ch-parse.y (call): Call get_type_of before build_chill_cast. - -Tue Aug 10 21:33:10 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-actions.c (build_char_array_expr): If a concat operand is - a constant char, convert it to a STRING_CST. - * ch-decl.c (finish_decl): Call rest_of_decl_compilation - with toplev=0. - * ch-typeck.c (build_chill_cast): Allow type to be TYPE_DECL. - - * ch-parse.y (actionlabel): Call define_label in both passes. - * ch-actions.c (lookup_and_expand_goto, lookup_and_handle_exit): - New functions, using lookup_name to find LABEL_DECLs. - * ch-parse.y (GOTO, EXIT): Use above new functions. - * ch-tasking.c (struct rc_state_type *current_rc_state): - Use to store state for the current receive case statement. - (build_chill_receive_case_start, build_chill_receive_case_end): - Don't generate temporary LABEL_DECL; just use gen_label_rtx. - * ch-decl.c: Remove all stuff dealing with specific label scopes, - including functions push_label_level, pop_label_level. - * ch-decl.c (define_label): Re-write for 2-pass. - * ch_tree.h (lang_identifier): Removed label_value. - * ch-tree.h (IDENTIFIER_LABEL_VALUE): Removed. - - * ch-parse.y (modename): Changed to yield identifier, not type. - This allows following changes, which work better for 2-pass: - (location): primval ARROW optmodename -> primval ARROW optname. - (primval): Tuple can now be prefixed by unsatisfied name. - - * ch-actions.c (chill_grant_only): Renamed to grant_only_flag. - * ch-lex.l (yywrap): Don't read seizefiles if grant_only_flag. - * ch-decl.c (switch_to_pass_2): Exit if grant_only_flag, - - * ch-satisfy.c (satisfy): Support CONSTRUCTOR, REFERENCE_TYPE. - * ch-satisfy.c (satisfy_decl, satisfy): Kludge around - to a TYPE_DECL can be simplified to its type. - * ch-expr.c (build_chill_indirect_ref): New function. - * ch-lex.l (prepare_paren_colon): Make kludge even uglier, - since the left paran might already have been seen. - * ch-lang.c (make_chill_pointer_type): Allow parameter - to select pointer or reference type. - (build_chill_reference_type): New function. - Either function: Be more careful (in case arg is identifier). - * ch-except.c (initialize_exceptions): Make - exception_stack_decl be public. - * ch-actions.c (build_char_array_expr): Can only - constant fold if operands are STRING_CST. - * ch-grant.c (raw_decode_mode): Allow TYPE_DECL. - (chill_finish_compile: Set TREE_PUBLIC of init function to 1. - -Tue Aug 10 17:55:12 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_char_array_expr): Set array sizes correctly. - * ch-decl.c: Fix comment. - * ch-parse.y (pmodearg): Build tree_list in all cases. - * varasm.c (assemble_tasssking_entry): Delete unused code. - -Tue Aug 10 13:58:21 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_char_array_expr): save/restore - a tree's constant status. - (build_chill_binary_op): Don't convert an expression - if the type we're converting to is NULL. - * ch-convert.c (maybe_turn_scalar_into_array): New functions. - Call it from convert, and from .. - * ch-expr.c (chill_expand_assignment): call new function. - Move convert code earlier, too. - * ch-decl.c (lookup_name): Delete bogus error message. - * ch-tree.h (CH_NOVELTY, SCALAR_P): Handle NULL_TREE. - Add protos. - * ch-typeck.c (valid_array_index): Comment out some strange code - which now seg faults. - (chill_expand_tuple): Re-enable prepending of VARYING - length to a tuple. - (chill_similar): Return FALSE if either mode is NULL_TREE. - -Tue Aug 10 07:29:31 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c: Delete proto for unused function shadow_tag_warned. - Add commented-out calls to pushtag, in case we decide later - to fill in TYPE_STUB_DECL for dbxout. - * ch-lang.c (build_chill_struct_type): Add commented-out - calls to pushtag, in case we decide later to fill in - TYPE_STUB_DECL for dbxout. - -Mon Aug 9 23:09:08 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (chill_seize): Don't get_next_next in pass 2. - * ch-decl.c (get_next_decl): Skip ALIAS_DECLs. - * ch-decl.c (bind_saved_names): Handle SEIZE ALL. - * ch-lang.c (layout_chill_struct_type): Don't call - rest_of_type_compilation - it crashes without a TYPE_STUB_DECL. - * initname.c (get_file_function_name): Get new file and - function for language-independent constructor name generation. - * ch-grant.c (get_init_function_id): Removed. - * ch-grant.c (chill_finish_compile): Call get_file_function_name - instead of get_init_function_id. - -Mon Aug 9 18:33:36 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c: Formfeeds and comments. - * ch-parse.y (quasi_formpar): Treat just like real formpar. - Eliminate restriction on single name. - (pmodearg, pmodearglist): Remove ignore_exprs stuff. - -Mon Aug 9 17:21:14 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lex.h (enum rid), ch-lex.l (init_lex): Added RID_ALL. - * ch-lang.c (build_chill_pointer_type): Layout the pointer type, - if the pointee is laid out, even if pass==1. - * ch-parse.y: Set ignore_exprs=(pass=2) for entire spec module. - -Mon Aug 9 15:44:01 1993 Bill Cox (bill@rtl.cygnus.com) - - This version compiles the 5-line program. Thanks, Per! - * ch-decl.c (print_lang_decl, print_lang_identifier): - Add appropriate calls to indent_to(). Rename reverse_scopes - to switch_to_pass_2, and wait to set pass = 2 until - here. - * ch-grant.c (chill_finish_module_code): Set module_init_list - non-NULL in pass 1; in pass2, chain on the module_init - structure's decl. - (chill_finish_compile): Clear module_init_list to NULL. - * ch-parse.y (quasi_formparlist): Rewrite to avoid seg fault. - Rename reverse_scopes to switch_to_pass_2, delete setting - of pass = 2. - * ch-tree.h: Rename reverse_scopes proto. - -Mon Aug 9 13:21:34 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (build_enumerator): If name is NULL, - don't call save_decl or get_next_decl. - * ch-decl.c (layout_enum): Fix calculation of next value. - * ch-grant.c (print_enumeral): Re-do for new 2-pass scheme. - * ch-grant.c (decode_constant): Better CONSTRUCTOR support. - -Mon Aug 9 11:59:12 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-convert.c, ch-decl.c, ch-grant.c, - ch-lang.c, ch-parse.y, ch-tree.h: gcc -Wall cleanup. - Lots of new prototypes. - -Mon Aug 9 01:00:33 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lex.h: Remove unused RID_'s. Make sure RID_MAX is last. - * ch-decl.c (init_decl_processing): Moved ridpointers - initialization to init_lex(). Use them consistently. - * ch-lex.l (RETURN_PREDEF): New macro. Uses ridpointers - for all preferedined types. - * ch-lex.l (init_lex): Upper case all RIDs, so grantfiles - (and error messages?) will use uppercase. - * ch-decl.c (build_chill_enumerator): Merged into build_enumerator. - * ch-lang.c (finish_chill_enum): Merged into ... - * ch-decl.c (finish_enum): .... this function. - * ch-decl.c (layout_enum): New function. Does all the pass-2 - stuff for enumerations. - * ch-decl.c (finish_enum, start_enum): Only trivial pass-1 stuff. - * ch-satisfy.c (satisfy): Support ENUMERAL_TYPE. Improve ranges. - * ch-parse.y: Check ignore_exprs instead of ignore_decls when - parsing and building types. - -Sun Aug 8 16:26:40 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lex.h: Add some missing RID_'s. - * ch-decl.c (init_decl_processing): - -Sun Aug 8 15:32:54 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (module_has_actions): Delete this and all - references. It was a botch. - (chill_finish_module_code): Move finish_chill_function_call inside - the test whether actions were found at module level. - Use current_function_name in the initializer build, - and init_entry_id in the module_list setup. - (chill_finish_compile): Call lookup_name to get the - decl from a module_init_list entry. - * ch-parse.y: Revert module_has_actions additions. - * ch-satisfy.c (satisfy): After satisfying the type referenced - by a pointer_type, call layout type for the pointer. - * ch-tasking.c (tasking_registry): Only active in pass 2. - * ch-typeck.c: Call build_chill_pointer_type everywhere. - -Sun Aug 8 13:13:29 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-tree.def (PAREN_EXPR): New unary op: '(' EXPR ')'. - * ch-parse.y (primval): If pass 1, generate PAREN_EXRR. - * ch-satisfy.c (satisfy): Reduce PAREN_EXPR to its operand. - * ch-grant.c (decode_const): Handle PAREN_EXPR. - * ch-decl.c (pop_module): Fix think. Inprove error message. - -Sun Aug 8 10:31:04 1993 Bill Cox (bill@rtl.cygnus.com) - - Generally, replace 'function' with 'procedure' - and 'type' with 'mode' in error/warning messages. - * ch-actions.c: See Generally. Fix up 'too many' and 'too few' error msgs. - * ch-decl.c: See Generally. - (init_decl_processing): Call build_tasking_enum from here. - Now, it doesn't need a flag to do its work only once. - Also, build the TaskingStruct decl here. - * ch-grant.c: Remove references to `current_grant_file'; - there's now only one. See Generally. Do gcc -Wall cleanup. - * ch-lex.l: Remove references to `current_grant_file' - and delete USE_GRANT_FILE token. - * ch-parse.y: Remove call to build_tasking_enum, and its extern. - * ch-tasking.c (tasking_setup): Move TaskingStruct build - to init_decl_procesing. Delete build_tasking_enum calls. - * ch-tree.c: See Generally. - * ch-tree.h: Add proto for build_tasking_struct. - -Sun Aug 8 08:59:23 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c: Make unnamed_module_number static, reset it to zero - before pass 2, so same module names get generated in both passes. - (push_module): Return user name or generated name. - (init_decl_processing): Build __tmp_initializer_type. - Code moved from chill_finish_module_code. - * ch-grant.c: New flag module_has_actions. Set TRUE by push_actions, - used, reset by chill_finish_module_code. Replaces test of - module_function_name. Shuffled finish-up code to end of module. - (chill_finish_module_code): Use global_bindings_p to determine - 'nested' parameter for finish_chill_function. Use new - module_has_actions flag to trigger generation of module_init list - entry. We now can handle not only multiple modules per file, - but modules nested inside functions (I think). - * ch-lang.c (build_chill_pointer_type): Restore missing assignment. - * ch-parse.y (push_actions): Set module_has_actions flag. - (modulion, spec_module): Save possibly-generated module name - returned by push_module. - * ch-satisfy.c (satisfy): Put switch cases into alpha order, add - case for POINTER_TYPE. - * ch-tasking.c: Replace build_pointer_type calls with - build_chill_pointer_type calls. - * ch-tree.h: Fix, add prototypes. - -Sat Aug 7 17:32:22 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-parse.y: Remove many useless tests for ignore_decls. - * ch-parse.y: Remove obsolete support for _EXTERN and _INIT. - * ch-parse.y: Reset ignore_exprs while parsing declarations, - but handle initializers appropriately. - * ch-grant.c (decode_constant): Update (for 2-pass) support - for CONSTRUCTOR and SET_TYPE. - * ch-grant.c (chill_initializer_name): Renamed to - module_function_name. - * ch-grant.c (function_generated): Removed; - use module_function_name != NULL instead. - * ch-tree.h, ch-parse.y: Removed unused current_locnamelist. - * ch-decl.c (push_modedef): Simplify to take just one mode. - * ch-tasking.c (make_process_struct, make_signal_struct): - Change calls to push_modedef correspondingly. - * ch-tree.c (build_powerset_type): Move the stuff that's - suitable for pass 1 into new function make_powerset_type, - and that for pass 2 into new function layout_powerset_type. - * ch-lang.c: Move pass-1 stuff from build_chill_pointer_type - into new function make_chill_pointer_type, and split - build_chill_struct_type into make_chill_struct_type - and layout_chill_struct_type. - * ch-decl.c (grok_chill_variantdefs): Similarly split up - into make_chill_variants and layout_chill_variants. - * ch-satisfy.c (satisfy): Add support for SET_TYPE, and UNION_TYPE. - Call layout_chill_struct_type for RECORD_TYPE. - -Sat Aug 7 09:59:55 1993 Bill Cox (bill@rtl.cygnus.com) - - Fixup previous check-in. - * ch-decl.c: Restore unnamed_module_number, which *was* - used after all. - * ch-grant.c (get_init_function_id): Return type s.b. tree. - -Sat Aug 7 09:28:17 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (print_lang_decl, print_lang_type): Add - correct parameter list. Add print statements for - nesting_level, signal_dest, buffer_size, and the - signal_data flag. - (decl_temp, decl_temp1): Delete unused code. - (init_decl_processing): Call build_instance_type and - build_tasking_type in both passes. - Generally change current_scope comparisons against - global_scope to global_biidings_p calls. - * ch-except.c (push_handler): Add space before parameter paren. - * ch-grant.c (chill_start_module, chill_finish_module, - chill_finish_compile): Complete re-write for 2-pass and - multiple modules per source file. - * ch-parse.y (pass1_2): Call chill_finish_compile once each pass. - * ch-tasking.c: Diffused small adaptations to 2-pass. - * ch-tree.h (print_lang_decl, print_lang_type): Correct - the prototypes. - (chill_finish_module_code): Add module name parameter. - * ch-typeck.c: Fix comments, add whitespace. - -Fri Aug 6 12:17:07 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (temp_pushdecl, bind_saved_names): The simple-minded - way I allocated the shadow_list on an obstack was too fragile, - so just use xmalloc/free instead. - -Fri Aug 6 08:31:49 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-satisfy.c (satisfy): Satisfy TYPE_MIN_VALUE and - TYPE_MAX_VALUE for vanilla integer type. Only need - to satisfy TREE_TYPE for integer range type. - -Fri Aug 6 00:53:11 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lang.c (build_chill_range_type): Split up into two new - functions (make_chill_range_type, layout_chill_range_type); - only former part is done in pass 1. - * ch-lang.c (build_chill_array_type): Split up in the same - way (yielding make_chill_array_type, layout_chill_array_type). - * ch-satisfy.c (satisfy): Handle array and range types. - * ch-tree.h (TYPE_RANGE_PARENT): Removed. Not used. - * ch-parse.y (mode2): Handle optional rangesize. - -Thu Aug 5 15:13:42 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-grant.c (print_an_int): Re-enable (but don't search for SYN). - * ch-grant.c (raw_decode_mode): Support printing - of an IDENTIFIER_NODE (unresolved type name). - * ch-grant.c (decode_constant): Support printing of an unresolved - IDENTIFIER_NODE, as well as some kinds of binary operations. - * ch-grant.c (grant_one_decl): Don't call globalize_decl. - - * ch-grant.c (decode_decl): Add support for ALIAS_DECLs - (from SEIZEs and GRANTs). - * ch-grant.c: Remove support for multiple grantfiles. - * ch-grant.c, ch-parse.y: Removed grant_count, for now at least. - * ch-lex.h (in_seizefile): Moved to ch-tree.h. - * ch-tree.h (CH_DECL_SEIZED), ch-tasking.c, ch-decl.c: Removed. - * ch-tree.h (CH_DECL_GRANTED): Added. - * ch-actions.c (build_chill_exception_decl): Use - IDENTIFIER_LOCAL_VALUE, not obsolete IDENTIFIER_GLOBAL_VALUE. - * ch-grant.c (write_grant_file -> write_spec_module): Rename. - Change to accept list of remember_decls and granted_decls. - -Thu Aug 5 11:58:21 1993 Stan Shebs (shebs@rtl.cygnus.com) - - * expr.c: Remove no-longer-used PROCESS_DECL tree type. - -Thu Aug 5 10:03:27 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (init_decl_processing): Only build types - in pass 2, since dbxout machinery is only ready for - output then. - * ch-grant.c (chill_finish_module_code): Do most of the - work in pass 2. - -Thu Aug 5 06:54:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (receivecaseaction): Pass label-group - numbers around. - * ch-tasking.c (build_chill_receive_case_start): - Generate unique labels for each case, pass back - the label-group's number. - (build_chill_receive_case_end): Accept label-group - number from parser, use it to build labels - * ch-tree.h: Change prototypes. - -Wed Aug 4 13:21:13 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (decl_temp1): Call finish_decl(). - - * ch-grant.c (chill_start_module_code): Don't call - push_c_function_context - not needed since we're not nested. - * ch-grant.c (chill_finish_module_code): Call finish_chill_function - with nested=0, not 1 (twice). - * ch-grant.c (chill_finish_module_code): Clear function_generated. - -Tue Aug 3 20:06:22 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-decl.c (push_chill_extern_function): Set TREE_PUBLIC. - -Tue Aug 3 19:08:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): Handle parameter - attributes better - LOC still not handled. - * ch-tree.def: Amplify comment. - -Tue Aug 3 18:07:36 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lex.l (handle_use_seizefile_directive): Update - next_file_to_seize correctly. - * ch-actions.c (build_chill_abs): Create an ABS_EXPR, not an rts_call. - -Tue Aug 3 14:03:50 1993 Bill Cox (bill@rtl.cygnus.com) - - First Aid, not real long-term fixes... - * ch-decl.c (pop_module, lookup_name_for_seizing): Check - current_module pointer for NULL before using it. - (init_decl_processing): Set up wchar_type_node before using it. - * ch-grant.c (chill_finish_module_code): Don't build - initializer_type or initializer_decl until pass 2. - * ch-lex.l: Readability - single statement per line. - * ch-tasking.c (make_process_struct): Hide get_parm_info - call inside #ifdef for now. - -Tue Aug 3 09:59:23 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (pushdecllist): Add forward decl. - * ch-parse.y (handler): Add rules which allo - empty onalternativelist. - * ch-tasking.c (get_tasking_code_name): Add - cast of alloca() result. - -Tue Aug 3 00:11:40 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-lex.l (handle_use_seizefile_directive): Make files_to_seize - a queue. Check for duplicate use_seizefile-s immediately. - * ch-lex.l (yywrap): Use this more portable mechanism, - rather than the flex-specific <<EOF>>. Also, clear saw_eof. - * ch-lex.l: Don't call push_module/pop_module automatically. - * ch-decl.c (push_chill_extern_function: Modify for 2-pass. - -Mon Aug 2 14:24:59 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-parse.y: Rename actionstatement -> nonempty_actionstatement. - New actionstatement is now nonempty_actionstatement | SC. Use - where appropriate. This is closer to Blue Book terminology. - - * ch-tree.def (ALIAS_DECL): New tree type. - * ch-decl.c: Merged all the code we need (I hope) from c-decl.c, - which is no longer used for cc1chill. - * c-decl.c: Remove all Chill-related code. - * Makefile.in (CHILL_OBJS): Don't use c-decl.o. - * ch-decl.c: No longer use IDENTIFIER_GLOBAL_VALUE anywhere. - Introduce a 'nesting_level' level concept instead. - * ch-decl.c: Merged push_scope into pushlevel; pop_scope into - poplevel; struct scope and struct binding_level. - * ch-decl.c: Other major name lookup algorithm changes. - * ch-tree.h (struct lang_identifier): Remove granted_value field. - * ch-tree.h (IDENTIFIER_GRANTED_VALUE macro): Removed. - * ch-tree.h (DECL_NESTING_LEVEL): New macro. - * ch-satisfy.c (satisfy, satisfy_decl): New 'lookup_only' arg. - * ch-tree.h (struct module): New fields nesting_level, granted_decls. - * ch-grant.c (seize_implied_names, do_seize, chill_seize): Move ... - * ch-decl.c: ... here. - * ch-grant.c (start_chill_function2): Remove. - * ch-grant.c (chill_start_module_code): Now called in both passes. - * ch-actions.c (lang_init): Code moved to ... - * ch-decl.c (init_decl_processing): ... here. - * ch-actions.c (chill_expand_result, chill_expand_return): - Handle being called during pass 1. - * ch-lex.l (name_type_signal): Don't try lookup_name during pass 1. - * ch-parse.y (PUSH_ACTION, push_action): Is now invoked during - both passes, for the sake of chill_start_module_code. Change all - actions rules to invoke PUSH_ACTION unconconditionally. - * ch-parse.y, ch-decl.c (push_module): Module label is now optional. - -Mon Aug 2 15:02:32 1993 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (store_constructor): Convert library function - parameters to proper integer precision before calling - emit_library_call. - -Mon Aug 2 08:46:06 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (seize_implied_names): Check POWERSET's - base type for names to seize. - -Fri Jul 30 19:59:30 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.h: Delete unused definition of JOINER - macro. Expand comment about INSTANCE_TYPE. - -Thu Jul 29 14:57:11 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c (unreferenced_type_of): New function. - (convert): Call new function. - -Thu Jul 29 07:34:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l: Allow C-style comments before the module - header. Use #undef to assure that strchr isn't a - macro (portability), and remove the extra paren- - theses in its extern name. - (check_newline): Call getlc less often, so that user - labels aren't lowercased before their time. Add BEGIN - INITIAL before starting pass 2, so the header is - correctly ignored. - -Wed Jul 28 14:23:24 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (chill_start_module_code): Cast alloca() - return value. - -Wed Jul 28 12:39:51 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) - - * ch-grant.c: remove extra parens around extern function - declarations (they confuse the DECstation compiler) - -Wed Jul 28 12:28:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Stop deleting flex's #line lines. - -Wed Jul 28 07:05:25 1993 Bill Cox (bill@cygnus.com) - - Adjust after FSF merge: - * calls.c (expand_call): Add comment. - * ch-expr.c: Add newline. - * expmed.c (store_split_bit_field): Add comment. - -Tue Jul 27 17:32:13 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_binary_op): Set code0 and - code1 only in pass 2. - (get_result_tmp_name): Cast alloca return for portability. - * ch-decl.c (pop_module): Test current_module ptr before - using it. - * ch-lex.l: Set lineno and input_filename for pass 2 - error messages. - -Tue Jul 27 15:14:06 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l: Fix the syntax error at line 329. Will I - *ever* quit fixing these in the ch-lex.c file? Stay tuned.. - -Tue Jul 27 15:01:25 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l: Pervasive rewrite for queueing seize files, - then parsing them at the end of pass 1. Still some - problems. - -Tue Jul 27 07:40:39 1993 Bill Cox (bill@rtl.cygnus.com) - - * chill.in: Check for .i suffices only, and use -xchill - to bracket the argument. - -Thu Jul 22 19:17:23 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (print_lang_identifier): Oops. Syntax error. - -Thu Jul 22 18:56:16 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (pushdecllist): Standardize loop for readability. - * ch-decl.c (decl_temp): Call pushdecllist to store decl - into hash table, move after current_scope declaration. - (decl_temp1): Move also. - * ch-lex.l (getlc): New function. Force char to lower case. - (check_newline): Call it, so comparisons work on uppercase - keywords. - -Wed Jul 21 22:17:22 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_decls): Add saving of decl tree - address into ID node in pass 2, reindent. - * ch-grant.c (start_chill_function2): New function. - (chill_start_module_code, chill_finish_module_code): Call it. - * ch-loop.c (build_temporary_variable, begin_for_range): - Replace start_decl, finish_decl pairs with decl_temp1 calls. - * ch-parse.y (parnamelist): Eliminate warning by eliminating - the %type for now. - * ch-actions.c, ch-tasking.c: Replace do_decls calls with - decl_temp1 calls. - * ch-tree.h: New prototypes. - * stmt.c (stamp_nesting_label): Check parameters for NULL. - * toplev.c (lang_options): Add '-L' option. - -Wed Jul 21 21:06:18 1993 Bill Cox (bill@rtl.cygnus.com) - - Portability fixes. - * ch-decl.c (save_decl): Make definition match forward declaration. - * ch-lex.l (RETURN_TOKEN): Don't use the 'do { .. return } while 0' - in the macro - Sun's compiler throws warnings. Thanks, Brendan. - * ch-satisfy.c (satisfy): Add forward declaration. - (SATISFY): Add outer parens for greater safety. - -Wed Jul 21 12:59:20 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * c-decl.c (pushdecllist): New function. Add a list of decls - to the current scope, checking for duplicates. - * c-decl.c (start_function): Remove some Chill junk. - (This function should no longer be used for Chill.) - * ch-lex.l (ch_lex_init): New function, to re-init for 2nd pass. - * ch-lex.l (<<EOF>>): Cleanup, and re-start for 2nd pass. - * ch-tree.h (UNSATISFIED, UNSATISFIED_FLAG): New flags. - * ch-tree.h (CH_CLASS_IS_VALUE, CH_CLASS_IS_REFERENCE): - Implement. Add comments. - * ch-tree.h (CH_COMPATIBLE_CLASSES, CH_ROOT_MODE, CH_RESULTING_MODE): - Better Blue Book type checking. - * ch-actions.c (finish_chill_binary_op): Handle folding - and other stuff that couldn't be done in pass 1. - * ch-actions.c (build_chill_binary_op): Bail out early if pass 1. - Use new CH_ROOT_MODE macro to handle integer promotions etc. - * ch-except.c (push_handler): Bail out if pass 1. - * ch-tasking.c (make_process_struct): Defer making this work. - * ch-parse.y (assignaction): Simplify, and move some code ... - * ch-expr.c (chill_expand_assignment): ... here. - * ch-typeck.c (chill_root_mode, chill_resulting_mode, - chill_compatible_classes): New functions, implementing the - correspondingly named Blue Book concepts. - * ch-parse.y generally: Lots of little tweaks to support - 2-pass compilation. - * ch-parse.y (push_module, pop_module): Moved to ... - * ch-decl.c (push_module, pop_module): ... here. - * ch-parse.y (push_action): New function. - * ch-parse.y (pdef): Move complicated action to ... - * ch-parse.y (end_function): ... new function here. - * ch-parse.y (procedure): Major re-write. - * ch-parse.y (paramname, paramnamelist): New, to avoid conflict (?). - * ch-decl.c (do_decls, push_syndecls, push_modedef, - start_chill_function, finish_chill_function): Do different things - on each pass. Hence, can use code in c-decl.c to lesser extent. - * ch-decl.c (build_chill_function_type): First arg is now - just the return type, rather than a singleton list. - * ch-decl.c (massage_param_node): Remove not needed (we - now encode parameter attributes directly in the TREE_PURPOSE). - * ch-decl.c (chill_munge_params): New function, called by parser. - * ch-decl.c (push_parms): Removed function. - * ch-decl.c (push_cope, pop_scope, save_decl, get_next_decls): - New functions, to coordinate decls between passes. - -Wed Jul 21 14:23:25 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (lang_decode_option): Add option -Lpath - to specify seize file path. - (ch_singleton_set): Readability formatting. - Add comment, move functions to easier found places. - * ch-lex.l (setup_seizefile_read): Check for *no* slashes. - (register_seize_path): Use memcpy so pathlen has an effect. - * gcc.c (default_compilers): Add -L option to chill - compiler SPECs. - -Wed Jul 21 12:59:20 1993 Per Bothner (bothner@kalessin.cygnus.com) - - * ch-satisfy: New file. Used for name lookup. - * Makefile.in (CHILL_OBJS): Add ch-satisfy.o. - -Wed Jul 21 12:16:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * toplev.c (main): Delete -L option handling - breaks - non-chill compilers. - -Wed Jul 21 09:29:24 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c: #undef strchr and strrchr names in extern - declarations, to prevent RS6000 compiler from reporting - their misuse as macros. - * ch-lex.l (setup_seizefile_read): Refer to list of paths - for seizefiles specified by -L options on command line. - (register_seize_path): Add a new path to the seize file list. - * toplev.c (strip_off_ending): Recognize chill suffix. - (main): Recognize -L option, specifying a seize file path. - -Tue Jul 20 12:41:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (convert_float): Make it really portable, - using the appropriate macros. - -Tue Jul 20 11:26:02 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (convert_float): More casts for vxworks - portability. - -Tue Jul 20 11:01:30 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (convert_float): Give variable `d' correct - type so build_real call is correct. Should remove - vxworks portability problem. - (convert_float): Re-indent to standards. - -Mon Jul 19 17:32:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_char_array_expr): Add field decls to - constructor. Now, it generates the library call. - * ch-expr.c (chill_expand_array_assignment): Make sure that all - error messages say 'mode' not 'type'. - -Mon Jul 19 14:44:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-convert.c, ch-decl.c, ch-grant.c, ch-lang.c, - ch-loop.c, ch-parse.y, ch-tasking.c, ch-tree.c, ch-typeck.c: - Make sure that all error messages say 'mode' not 'type'. - * ch-decl.c (push_modedef): Add novelty computation, - storage in each newmode. - * ch-parse.y: Delete novelty counter - moved to ch-decl.c. - Reformat slightly for readability. Fix comments. - * ch-tree.h: Delete print_lang_type prototype. - -Mon Jul 19 06:43:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_expand_return): Disable - error message which requires 2-pass analysis, for - now. - * ch-convert.c (convert): Build length-only constructor - for empty string (PR 2930). - -Fri Jul 16 16:08:33 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_array_assignment): Check - non-varying string assignments for conformance to - the "string assignment condition" (PR 2920). - -Thu Jul 15 13:25:33 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_array_expr): Check parameters. - Call convert to build unitary array from scalar if - needed. Rewrite CONCAT_EXPR handling. - * ch-convert.c (build_array_type_for_scalar): New functions. - (convert): Call new function, to convert scalar to unitary - array. Only call chill_expand_tuple if expression hass - NULL_TREE type. - * ch-expr.c (chill_expand_expr): Allow a larger static - varying array to be assigned to a smaller, with a runtime - test (to be provided). - * ch-parse.y (locdec): Comment out bogus error msg. - (elementlist): Replace several lines with chainon call. - * ch-tree.h (SCALAR_P): New macro. New prototype for - build_array_type_for_scalar. - * ch-typeck.c (build_chill_cast): Re-indent. - (chill_expand_tuple): Comment out strange addition of - varying string's length to front of constructor list. - -Thu Jul 15 05:58:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-except.c (start_handler_array): Use unique identifier for - exception array, so we can have > 1 array per reach - (PR 2931). The change was originally entered June 23, and - subsequently lost. - -Mon Jul 12 16:07:53 1993 Bill Cox (bill@rtl.cygnus.com) - - Get executable test cases running again... - * c-typeck.c (build_function_call): Bypass default - parameter promotions, format param syntax check for - CHILL; they've already been converted in - build_chill_function_call. - * ch-actions.c (chill_expand-return): Correct tests - for function which returns no value. - * ch-convert.c (base_type_size_in_bytes): Check for - NULL type parameter, just return. - (convert): Allow conversion of CHAR to varying array - of CHAR. - Change error msg to "conversion" from "assignment". - Remove default from case, which short-circuited before - REFERENCE_TYPEs got converted. Deleted second copy - of REFERENCE_TYPE code. - * ch-lang.c (build_chill_range_type): Simply exit if - NULL input parameter. - * ch-loop.c: Fix comment. - -Sun Jul 11 11:27:08 1993 Bill Cox (bill@cygnus.com) - - * ch-actions.c (chill_expand_result, chill_expand_return): - Move here from ch-typeck.c. Add a temporary to remember the - result value in. Change return handler to fetch that - temporary value, if there is one. - * ch-parse.y (pdef): Call chill_expand_return to fetch - the temp's value. - * ch-tree.h, ch-typeck.c: Move return, result functions to - ch-actions.c. And their prototypes. - -Fri Jul 9 15:47:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-convert.c, ch-decl.c, ch-except.c, - ch-expr.c, ch-grant.c, ch-inout.c, ch-lang.c, - ch-lex.l, ch-loop.c, ch-parse.y, ch-tasking.c, - ch-tree.c, ch-tree.h, ch-typeck.c: gcc -Wall cleanup. - -Fri Jul 9 09:41:05 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (decode_decl): Grant BUFFER, INSTANCE variables. - (print_integer): Delete old non-working INSTANCE code. - * ch-lex.l (name_type_signal): Recognize BUFFER name, too. - * ch-parse.y (rccase_label): Move all actions inside if. - Use BUFFERNAME to recognize receice case buffer clause, - eliminate one shift-reduce conflict. - * ch-tasking.c (build_buffer_descriptor): Check for - CH_DECL_BUFFER flag, remove unused code. - -Thu Jul 8 11:17:32 1993 Bill Cox (bill@rtl.cygnus.com) - - Declaring and sending buffers.. first draft - * ch-actions.c (lang_init): Define the send_buffer runtime - function. - * ch-decl.c (do_decls): Standardize loop, so stepping - isn't hidden. - * ch-lex.l: Clean up prototypes for readability. - * ch-parse.y (sendaction): Add send buffer action. - (locdec): Add rule for buffer declaration. - * ch-tasking.c (generate_tasking_code): standardize indentation. - (make_signal_struct): Readability changes. - (build_chill_send_buffer, build_buffer_decl, - build_buffer_descriptor): New functions. - * ch-tree.h (IDENTIFIER_BUFFER_SIZE): Add place to save - buffer's maximum queue length in buffer decl. - (CH_DECL_BUFFER): Add flag in decl. Clean up for - readability. Add prototypes. - * ch-typeck.c (build_chill_cast): Call convert rather - than storing directly into TREE_TYPE field. - -Tue Jul 6 12:34:32 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (lang_init): Set warn_switch so case labels - get checked. Move build_chill_case_expr to ch-expr.c. - * ch-expr.c (chill_expand_case_expr): Enable checking - of expression case labels. - * ch-grant.c: Move a comment. - -Mon Jul 5 10:02:27 1993 Wilfried Moser (fs_moser at rcsw1j) - - * ch-lex.l: Add compiler directive SUPPORT_CAUSING_ADDRESS. - * ch-except.c (initialize_exceptions): Change the layout of the - structure __ch_handler. The entry __jbuf is moved to the end - of the structure and its size was changed to _JBLEN+10. - * ch-decl.c (push_chill_extern_process): Add processing of - processes with no arguments. - * ch-grant.c (decode_decl, do_seize): Add processing of - processes with no arguments. - * ch-tasking.c (build_process_header, build_chill_start_process): - Add processing of processes with no arguments. - (make_process_struct): Add processing of IN attribute for - process arguments. - (tasking_setup): Add NUL-character to name of a tasking - element. The name must be NUL terminated. - (build_chill_send_signal): Default SEND_SIGNAL_PRIORITY - to 0 with a warning if -Wall specified on command-line. - -Fri Jul 2 16:01:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y: Change 'empty' comments to new non-terminal - so that exyacc doesn't discard them. - * ch-lang.c (build_chill_range_type): New error messages. - -Fri Jul 2 12:43:25 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (action): Catch and report actions which - shouldn't have exception clauses, but do. Unfortunately, - catching more than one of these per compilation will - have to await the general addition of syntax error - recovery to the parser. - -Fri Jul 2 10:45:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (locdec): Issue error for initialization - of bitstring with tuple, not for powerset init with - tuple. - -Thu Jul 1 15:29:26 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lang.c (build_chill_array_type): Check for indices - that didn't fold into constants, issue error (PR 2924b). - * ch-parse.y: Add novelty counter, alphabeticalize. - * ch-tree.h: Define CH_NOVELTY for novelty checks later. - -Thu Jul 1 14:03:04 1993 Bill Cox (bill@rtl.cygnus.com) - - For Wilfried Moser. - * chill.in: Add -ansi switch at compiler call to avoid - translation of i.e. sun to 1 by cpp. - -Wed Jun 30 22:21:33 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (raw_decode_mode): Add code for - integer and enumeral ranges. Standardize indentation. - -Wed Jun 30 14:02:23 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (print_an_int): New function to print a - decimal integer string or the CONST_DECL (SYN) which - best matches it. - (print_integer): Call the above function. Replace - calls to SAME_TYPE macro with TYPE_MAIN_VARIANT - comparisons, as suggested by Jim Wilson. - (decode_decl): Set current_grant_modename sooner, - be sure to clear it when done. - -Wed Jun 30 10:10:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_max_min): Change interface to accept - just a max/min flag. Get min/max values from an - enumeral constructor. - (build_chill_max, build_chill_min): Change calls to - build_max_min. - * ch-lang.c (deep_const_expr): Check for NULL_TREE - arguments, don't seg fault. - -Wed Jun 30 09:20:09 1993 Bill Cox (bill@rtl.cygnus.com) - - * config/sparc/sparc.c (sparc_type_code): Add SET_TYPE - to switch cases, preventing abort. - -Tue Jun 29 19:04:37 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c: Update comment. - * ch-parse.y (range_or_mode): New non-terminal used in - lexpr to implement mode as case label. - -Tue Jun 29 13:13:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_case_expr): Pass in the - optional ELSE clause, error for multiple case-selector - expressions, error for missing ELSE clause. - * ch-expr.c (chill_expand_assignment): Error if multiple - location assignment and locations not novelty - equivalent. - * ch-parse.y (caseaction): Add range_list_clause non- - terminal, sorry message for it. - (assignaction): error if operator used on multiple - assignment. - (case_expr): Pass optional ELSE tree to - build_chill_case_expr for checking. - * ch-tree.h (build_chill_case_expr): Change proto. - -Fri Jun 25 17:22:41 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_comptypes, build_chill_binary_op): - Allow PROC mode variables. - * ch-convert.c (convert): Turn a NULL literal into a zero - valued pointer-to-function, given such a type. Also - build the ADDR_EXPR of a function variable. - * ch-grant.c: Pervasive -Wall -pedantic cleanup. - (print_enumeral, print_integer, print_struct) Moved these - large functions out of the switch in raw_decode_mode for - readability, and to encourage future code-sharing. - (print_proc_tail, print_proc_exceptions): Moved these out - of decode_decl, to share them. They're used also to - output PROC modes. - * ch-parse.y (mode2): Enable PROC modes. - (procmode): Represent PROC mode as a ptr-to-function type. - (call): Recognize ptr-to-function as indirect call. - Cleanup 'primval LPRN untyped_exprlist RPRN' action code. - -Thu Jun 24 15:59:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c: (raw_decode_mode): Add support for unnamed - and user-numbered enumeration members. - -Thu Jun 24 13:52:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_array_expr, build_chill_length): - Explicitly convert a varying array's length field to an - integer_type_node, now that it's only a chill_integer_ - type_node. - * ch-expr.c (chill_expand_expr, - expand_assignment_to_varying_array, - chill_expand_array_assignment, - expand_varying_length_assignment): Explicitly - convert a varying array's length field to an integer_type_node, - now that it's only a chill_integer_type_node. - * ch-loop.c (init_loop_counter, top_of_loop_test): Change - to handle varying array location iterations. - * ch-parse.y (mode2): Count number of named SET members, - as opposed to '*' members. Issue error if there were none. - (setelement): Count named set members. Generate a unique - identifier for the '*' element. - * ch-typeck.c (validate_varying_array_ref): Explicitly - convert a varying array's length field to an integer_type_node, - now that it's only a chill_integer_type_node. - -Wed Jun 23 19:18:28 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lang.c (finish_chill_enum): Change test for too- - large enumerations. - * ch-parse.y (setelement, optsetvalue): Allow numbered, - unnamed set elements. - -Wed Jun 23 16:25:06 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-typeck.c (process_init_constructor): Suppress - errors about un-initialized array elements if the - array is VARYING, as signaled by C_TYPE_VARIABLE_SIZE. - * ch-actions.c (lang_init): Set flag_short_enums, so that CHILL - enumerations *can* be only a byte in size. - (adjust_parm_or_field): Convert untyped parameter before - looking at its type to process it. - * ch-convert.c (convert): Generate [ -1, -1 ] value for - an INSTANCE type. - * ch-decl.c (do_decls): Assure that a CONSTRUCTOR has a - type, so that output_constant doesn't seg fault. - * ch-except.c (start_handler_array): Use unique identifier for - exception array, so we can have > 1 array per reach. - * ch-lang.c (finish_chill_enum): Error if number of - enumeration values exceeds 256. - * ch-parse.y (check_end_label): Error, not warning if start - and end labels don't match. - (assignaction): Convert RHS. Allows untyped tuples to be - passed to stabilize_reference. - (exceptlist, onexceptprefix): Error if non-unique exception - name is coded. - * ch-tree.c: Added form feeds, comment reformatted. - * ch-typeck.c (chill_expand_tuple): Compare tree value to - NULL_TREE, not zero. Add a constructor element for a - VARYING array's length to the constructor list. - (build_varying_struct): Mark the type as VARYING for - process_init_constructor. - * toplev.c (lang_options): Add '-lang-chill' and - '-fchill-grant-only' options to table. - -Tue Jun 22 13:13:41 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): Add check - to prevent calling a PROCESS like a PROCEDURE. - * ch-parse.y (rcalternative): Add check for an - receive case alternative after a RECEIVE CASE - statement. - * ch-tree.h: Fix macro ENCAPSULATED_ARRAY_P. - * ch-lang.c (lang_finish): Remove resetting errorcount - and sorrycount for granting. - -Mon Jun 21 17:56:48 1993 Bill Cox (bill@rtl.cygnus.com) - - Receiving signals works. - * ch-actions.c (lang_init): Add else_clause flag to - __wait_signal parameter list. - * ch-lex.l: Add SIGNALNAME token, return when appropriate. - * ch-parse.y (SIGNALNAME): New token. Delete - empty_untyped_exprlist token, no longer used. Add - name_or_signal non-terminal. Standardize a few NULL - tests. Add real RECEIVE CASE semantics. Add checks that - SIGNALS, BUFFERs are only declared at global scope. - (call): Add signal declarations with/without data fields. - * ch-tasking.c (get_tasking_code_name, get_tasking_code, - build_chill_receive_case_start, build_chill_receive_case_end, - build_chill_receive_case_label): New functions. - Replace build (CONSTRUCTOR, ... calls with build_nt - (CONSTRUCTOR, calls. - * ch-tree.h: New prototypes. - -Thu Jun 17 18:36:38 1993 Bill Cox (bill@rtl.cygnus.com) - - SIGNAL declaration compilation, seizing & granting, - SENDing also. - * ch-actions.c (lang_init): Move instance_type_node - build to ch-tasking.c. Call build_tasking_message_type. - Build a type for send_signal. Put builtin_function - calls into alpha order. - (adjust_proc_param): Rename to adjust_parm_or_field, - add is_signal flag, so signal fields can use it. Rename - calls to it, add flag to calls. - * ch-decl.c (push_chill_extern_signal): Add function. - * ch-grant.c (decode_decl): Correct signal decl output. - (do_seize): Correct check for process seizure. Add - code for seized signal decl. - * ch-lex.l (yylex): Treat POS, ROW, STEP as reserved. - * ch-loop.c (get_unique_identifier): Standardize loop - temporary's name to assure that it's not granted. - * ch-parse.y (SIG_NAME): Delete unused token. - (spec_declist): Delete silly printf. - (quasi_signaldef): Add non-terminal. - (sendaction, optsendwith, optsendto, optpriority): - Implement actual working semantics. - (call, empty_untyped_exprlist): Allow empty signal - fields between parens. - * ch-tasking.c: Rename adjust_proc_param calls, add - is_signal flag to calls. Make instance_type_node a - type, not a TYPE_DECL, change references. Fix all - CONSTRUCTOR builds. Add make_signal_struct function. - Move build_instance_type here from lang_init. - (build_tasking_message-type, build_signal_descriptor, - build_chill_send_signal): New functions. - * ch-tree.h: Add, update protos. - * ch-typeck.c (build_chill_cast): Check for NULL expression - type as well as error_mark. - -Thu Jun 17 12:28:03 1993 Jim Wilson (wilson@sphagnum.cygnus.com) - - * Makefile.in (STAGESTUFF): Add chill to list. - -Wed Jun 16 07:12:53 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Complete the renaming of ch-process.c - to ch-tasking.c. - * ch-decl.c (push_chill_extern_function): Drop is_process - parameter, and marking process decl trees. - (push_chill_extern_process): New function for - SEIZEd processes. Lotsa form feeds added for print - readability. - * ch-grant.c (decode_decl): Handle GRANTing of SIGNAls. - (do_seize): New parameter seize_all. Handle sseizing - processes. - (chill_seize): Pass seize_all parameter. - (chill_grant): Check for __tmp_ prefix, to disable - *either* seizing or granting. - * ch-parse.y (quasi_pdef): Delete is_process parameter for - push_chill_extern_functon, call push_chill_extern_process - for processes. - (specialinit): Comment these rules as needed only until - 2-pass compiler is operational. - (extprocedure): Delete is_process parameter. - (simpledec): Delete `sorry' about SIGNAL decls. - (optsigdest): Correct check for process name. - * ch-tasking.c (build_signal_decl): Finish coding. - * ch-tree.h: Add macro to save a SIGNAL's destination - process name in an id node. Add/change prototype. - -Mon Jun 14 18:17:13 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (lang_init): Build instance_type_node. - Change `this' to a runtime function call. - * ch-grant.c (do_seize): Generate tasking-code - variable for seized process. - * ch-lex.l (equal_number): Also accept synonym - name for numeric value. - * ch-parse.y (primval): Add process-related - function calls. - (signaldef, etc.): Rough draft of SIGNAL definition - processing. - (stopaction): Call runtime function. - (pdef): Pop symbol level if ending a process - and there were parameters. - (primval): Call `whoami' runtime function for THIS. - * ch-tasking.c (build_process_header): Be sure - to define the tasking enum, if it hasn't already - been done. Only call shadow_record_fields if there - are parameters. - (build_tasking_enum): Only call start_enum *after* - checking the already_built flag. - (build_copy_number, get_tasking_code, - build_gen_code, build_gen_inst, build_get_ptype, - build_proc_type): New functions for process-related - builtins. - (build_signal_decl): New function for SIGNAL - declaration - rough draft. - * ch-tree.def (INSTANCE_TYPE): new tree code. - * ch-tree.h: New prototypes. Defines for instance - type field access. - -Sat Jun 12 21:15:02 1993 Bill Cox (bill@rtl.cygnus.com) - - Get start-process action working: - * ch-actions.c (adjust_proc_param): new function, - extracted from build_chill_function_call and called - from there. - * ch-tree.h, ch-grant.c (do_seize): Add process_type - parameter to add_taskstuff_to_list call, prototype. - * ch-parse.y (start_parlist): New non-terminal for - START action. - (startaction): Reference start_parlist, check for - integer-valued process copy-number. - (optstartset): Check instance parameter - must be - an INSTANCE_TYPE location. - * ch-tasking.c (generate_tasking_code_variable): New - function, extracted from tasking_setup and called - from there. Also called from build_process_header. - (build_process_header): Add process_type parameter - to add_taskstuff_to_list call. Remove incrementing - of process_type (moved into generate_tasking_code - _variable). - (build_chill_start_process): Complete rewrite. - (add_tasking_stuff_to_list): Add stuffnumber parameter - putit on the list. - -Sat Jun 12 06:08:09 1993 Bill Cox (bill@rtl.cygnus.com) - - Getting processes compiled, initialized and granted: - * .cvsignore: Add chill file. - * c-decl.c (shadow_record_fields): Allow PARM_DECL - as well as VAR_DECL. - * ch-actions.c (lang_init): Move build of - initializer_type into ch-tasking.c. Change - definition of THIS to function call. - * ch-decl.c (massage_param_node): Add comments. - (start_chill_function): Set nested flag in - start_function call based upon current_function_decl, - not as constant zero. - * ch-grant.c (decode_decl): lotsa code by Wilfried to - GRANT process decls. - (finish_chill_module): Completely rewrote interface - to runtime. - * ch-lex.l (THIS): Just return the token code. - * ch-parse: Add THIS token. - (processpar, processparlist): New rules, to collect - process parameters. - (pdef): Add code to pop the process' WITH scope. - (procedure): Set process WITH scope flag to zero. - (process): Move most code into build_process_header. - (primval): Output function call for THIS. - * ch-tasking.c (add_taskstuff_to_list, build_tasking_enum, - make_process_struct, build_process_header): New code - to handle process translation and interface to runtime. - * ch-tree.h: New prototypes. - -Thu Jun 10 13:32:51 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Change ch-process.c to ch-tasking.c. - A delayed part of the last change.. - -Thu Jun 10 11:14:59 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: Add 'chill' file. - * ch-actions.c (lang_init): Add new runtime function - __register_process. - * ch-decl.c (push_chill_extern_function): Add is_process - input flag, use it. - * ch-grant.c (decode_decl): Recognize a process for - granting. - (do_seize): Put seized processes onto the tasking_list. - (chill_finish_module_code): Declare init_list entry, - link it onto the init_list. Call tasking_setup and - tasking_registry. - * ch-lex.l: Make tasking-related variables global, - delete their initialized flags. - * ch-parse.y: Add is_process flag to push_chill_extern_function - calls. Put processes onto the tasking_list. - * ch-process.c: Renamed to ch-tasking.c. - * ch-tasking.h: New file. - * ch-tree.h: New, adjusted prototypes. - -Wed Jun 9 10:59:27 1993 Wilfried Moser (moser@deneb.cygnus.com) - - * chill: This file is replaced by chill.in and will be - generated during 'make' and 'make install'. This script - now finds the correct chillrt0.o and libchill.a during - linking. - * chill.in: New file that replaced chill. - * Makefile.in: Add rules to make chill out of chill.in. - -Wed Jun 9 09:03:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: Add gfloat.h and xlimits.h. - * ch-actions.c (lang_init): Create new type for module- - level initializer list entry. - * ch-grant.c (chill_start_module_code): Rename actual - module-level code to just the modulename, which is - *not* public. - (chill_finish_module_code): Allocate space for initializer - list entry, build real initializer function, which puts - the list entry on the runtime list. Name the init function - as the module's constructor function. - * ch-tree.h (build_init_struct): Add prototype. - * ch-typeck.c (build_init_struct): Add function, called - from lang_init. - Note: these changes require a new devo/chillrt/chillrt0.c. - -Thu Jun 3 17:04:01 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c: Fix comment. - * ch-actions.c, ch-grant.c: Standardize front end: - #define first, etc. Add comments. - (lang_init): Delete unused flag, code for inapplicable - gen-decls option. (lang_decode_option): Delete - gen-decls option, add grant-only option, flag. - * ch-convert.c, ch-decl.c, ch-except.c, ch-tree.c, - ch-typeck.c: Add form feed after front end. - * ch-expr.c: Standardize testing for error_mark node. - * ch-lang.c: Remove unused deep_fold function. - -Fri May 21 11:04:22 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-typeck.c (build_binary_op, build_unary_op): - Recognize BOOLEAN_TYPE. - * ch-actions.c (build_chill_unary_op): Remove - some crufty work-arounds. - -Thu May 20 19:03:48 1993 Per Bothner (bothner@deneb.cygnus.com) - - * ch-grant.c (decode_constant): If the granted value is a - cast, make sure to emit an appropriate expression conversion. - -Thu May 20 16:35:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lang.c (build_chill_range_type): Initialize the - precision variable. Double-negative ranges work now. - -Thu May 20 11:24:42 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_unary_op): Compound a wretched - hack which hides a BOOLEAN_TYPE from the underlying - C code. - -Wed May 19 16:45:54 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: (CH_SINGLETON_SET): Add function, call it - from chill_comptypes. (build_chill_unary_op): Give - better name to unsigned flag. - * ch-expr.c (chill_expand_assignment): Correct calling - sequence for setpowersetbits runtime routine. - * ch-grant.c (raw_decode_mode): Give better name to - unsigned flag. (decode_constant): Check for null - 'val' ptr, avoid seg fault. - * ch-lex.l (convert_number): Give better name to - unsigned flag. (convert_bitstring): Move increment - of bl counter to emphasize that it increments once - per loop. - * ch-tree.h: (NO_SOURCE_UNARY_MINUS): Define new flag. - * ch-typeck.c (chill_expand_tuple): Build BOOLEAN - constructor if given a singleton set constructor. - -Thu May 13 17:03:04 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (pushdecl): Complete May 9 change. - * ch-actions.c (build_chill_unary_op): Set the - TREE_UNSIGNED flag FALSE for raw_decode_mode. - * ch-grant.c (grant_array_type): Correct the May 12 - check for circularity. - (raw_decode_mode): Use TREE_UNSIGNED flag to - control range's printing. - (chill_grant): Remove useless, bogus code. - * ch-lex.l (convert_number): Set the TREE_UNSIGNED - flag TRUE for raw_decode_mode. - -Wed May 12 18:04:01 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (push_syndecls, push_modedef): Comment - reminders to check for circular definitions. Later! - * ch-grant.c (grant_array_type, decode_decl): Prevent - circular definitions in the use of the array's - type name. - -Wed May 12 16:06:13 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (grant_array_type): If array_type has - a name, just use it. - * ch-lang.c (build_chill_range_type): Don't force - unsigned ranges on output. - * expr.c (store_constructor): Preclude seg fault. - -Wed May 12 07:49:00 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (fold_set_*): Correct tests for - range set-constructor list entries. - (lang_init): Define setpowersetbits function. - * expr.c (store_constructor): Handle non-constant - set constructors. - -Tue May 11 18:25:40 1993 Per Bothner (bothner@cygnus.com) - - * ch-lang.c (build_chill_range_type): If the parent type - is unknown, and the endpoints of the range are integer - constants, use the smallest suitable integer type. - * ch-lang.c (build_chill_range_type): Remove kludge - for dealing with char ranges. - -Tue May 11 15:24:31 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_repetition_op): Build a - range-type set constructor if there's only one value - in the repeated constructor. - (fold_set_*): Abort if range value seen, for now. - * expr.c (store_constructor): Handle range-type by - storing bytes rather than bits as much as possible. - -Mon May 10 18:45:18 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (invalid{left right}_operand): Add - handlers for REPLICATE_EXPR. - (build_chill_repetition_op): Build constructor list - for repetition of bitstring. - * ch-parse.y (call): Recognize more trees as arrays, - to avoid error msg. - (operand5): Add count, string temporaries, use them. - -Mon May 10 16:49:08 1993 Per Bothner (bothner@cygnus.com) - - * ch-grant.c (seize_implied_names): Fix code that assumed - a FUNCTION_DECL (or PROCESS_DECL) to work on types instead. - * ch-grant.c (generate_set, grant_parent_of_enum, - grant_parent_enum): Removed unused functions. - * ch-grant.c (raw_decode_mode): Remove commented-out code. - -Mon May 10 10:54:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (do_seize, seize_implied_types): Move - result and parameter processing to proper place. - (chill_seize): Mark unseized identifier with - error_mark_node, to avoid excessive errors. - * ch-parse.y (call): Check for ERROR_MARK before - reporting an error. - -Sun May 9 17:21:24 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (pushdecl): If a strongly-visible name is - seen, in conflict with a weakly-visible name, take - the strongly-visible one and don't complain. - * ch-actions.c (chill_comptypes): Allow chain of ref- - erence types > 1 in length. - * ch-grant.c: Turn disguised for-loops into actual - ones, so continue works. Delete redundant code in - seize_implied_names. Reindent. - * expmed.c (store_split_bit_field): Disable abort for - CHILL. - -Sun May 9 17:11:33 1993 Per Bothner (bothner@cygnus.com) - - * ch-convert.c (convert): Move handling of SET_TYPE until - after we've handled de-referencing and such like. - * ch-grant.c (grant_array_type): Simplify; remove (now-) - bogus call to generate_set. - * ch-grant.c (get_type): Remove obsolete stuff. - -Fri May 7 10:30:34 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (lang_init): Add definition of psslice - runtime routine. (build_chill_binary_op_1, - build_chill_binary_op): Have result type of - TRUTH_ANDIF_EXPR be boolean, not integer. Some - reindenting. - * ch-convert.c (convert): Use consistent notation - for expression. - * ch-parse.y: Add front-end pass count. (locdec): - Add syntax for other BASED declaration. - * ch-tree.c: Fix comment. - * ch-typeck.c (build_chill_slice): Implement a runtime - call for bitstring slices. (build_chill_cast): - Add code for BITS_BIG_ENDIAN bit loop. - (chill_expand_tuple): Don't pass ref type to - digest_init, only underlying type. - -Thu May 6 12:52:14 1993 Per Bothner (bothner@cygnus.com) - - * ch-typeck.c (build_chill_cast): type_for_size takes - a size in bits, not bytes. - -Wed May 5 19:02:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Break out separate routines for set - folding, handle ranges in set_fold_eq and set_fold_ne. - Fix folding as req'd by TTC test. - * ch-grant.c (raw_decode_more): Check for content match - to decide output mode, not pointer identity. - * ch-typeck.c: Add cross-reference comment. - * varasm.c (emit_set_data): Clarify parameter name. - Handle INTEGER_CST as set constructor. - (output_constant): Handle CONSTRUCTOR node for sets. - Apparently forgot to actually 'checkin' this one last - time. - -Wed May 5 12:23:58 1993 Jim Wilson (wilson@sphagnum.cygnus.com) - - * ch-parse.y, ch-tree.h (get_current_declspecs): Obsolete; deleted. - -Tue May 4 15:47:44 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (fold_set_expr): new function to fold - set expressions. Calls inserted into - build_chill_binary_op and build_chill_unary_op. - (build_chill_repetition_op): New function, called - from build_chill_function_call. - * ch-expr.c (chill_expand_assignment): Call - build_chill_repetition_op. - * ch-grant.c (decode_constant): Comment out deep_fold - call. The earlier fold_set_expr calls should make - this one unnecessary. Prevent seg fault when name - of structure field is NULL. Standardize for loop. - * ch-parse.y: Fix comments. - (operand5): build a REPLICATE_EXPR. Don't call - build_repetition_op until we have a type. - * ch-tree.def (REPLICATE_EXPR): Define tree-code. - * ch-tree.h (build_chill_repetiton_op): Fix proto. - * ch-typeck.c (chill_expand_result): Call - build_chill_repetition_op if needed. - * varasm.c (emit_set_data): Clarify parameter name. - Handle INTEGER_CST as set constructor. - (output_constant): Handle CONSTRUCTOR node for sets. - -Mon May 3 13:06:47 1993 Per Bothner (bothner@cygnus.com) - - * ch-typeck.c (build_chill_cast): Allow more liberality to - casting: Any discrete type to any non-discrete type that is the - same size as some other discrete type (and vice versa). - * stor-layout.c (layout_type, case SET_TYPE): If the number - of bits will fit in a char or short, only use that many bits. - -Mon May 3 08:22:45 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (decode_constant): Revert interpretation - of SET_TYPE as integer. - -Mon May 3 07:55:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * chparse.y (casealternative): Allow empty action list. - -Sat May 1 15:07:01 1993 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (expand_expr): Add parameter to __inpowerset - runtime call, to match new runtime. - -Sat May 1 14:55:58 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Cleanup from -Wall. Reindent. - Redefine __inpowerset to take a 'minval' parameter - that matches the new runtime. Added comments. - * ch-expr.c (chill_handle_case_label): Handle - NULL or ERROR trees. - * ch-grant.c (get_type): Survive bogus type params, - return empty string. - * ch-tree.c (build_powerset_type): Diagnose powerset - of non-discrete type. - * ch-typeck.c (discrete_type_p): Reindent. - -Fri Apr 30 16:08:54 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (decode_constant): Interpret SET_TYPE - with integer value, so we output the same stuff as - the user gave us. - * ch-parse.y: Fix indentation. - -Fri Apr 30 09:34:03 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_comptypes): Simplify, correct - integer subrange analysis. - * ch-grant.c (seize_implied_names): Add handling for - PROCESS_DECL, PROCESS_TYPE. - (do_seize): Call seize_implied_names for process, - procedure parameters and return value. - * ch-lang.c (finish_chill_enum): Canonicalize enum - types. - * ch-tree.def (PROCESS_TYPE): Add. - * ch-typeck.c (valid_array_index): Call chill_comptypes - rather than broken macro CH_COMPATIBLE. The logic - in chill_comptypes will get moved to the macro later. - -Thu Apr 29 13:07:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_lower, build_chill_upper): - Handle enumeration types. - (build_chill_binary_op): Call chill_comptypes - to error check IN arguments. Change error - messages to say 'mode' rather than 'type'. Cast - tree codes when build is called. - * ch-expr.c (chill_expand_array_assignment): Call - chill_comptypes to validate assignment args. - * ch-lex.l: Add newline for readability. - -Wed Apr 28 15:22:18 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (ch-hash.h): Add rule to build this - from chill.gperf. Not yet used. - * ch-actions.c (build_chill_binary_op): Allow enum - subranges on RHS of IN operator. - * ch-grant.c (decode_constant): Recognize - error_mark_node as empty powerset initializer, - re-indent a bit. - * ch-lang.c (deep_fold): Return error_mark_node for - NULL input pointer or incoming error_mark_node. - * ch-lex.l: Ignore PACK and UNPACK keywords. Return - POS, ROW, and STEP as user-defined names. - (name_or_type): New function for above. - * ch-parse.y: Move token defs for following, comment - them separately: NOPACK, PACK, POS, ROW, STEP - * varasm.c (output_constant): Check for VAR_DECLs in - records & unions, like arrays. Don't abort. - -Tue Apr 27 17:42:29 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (CH_PROMOTING_INTEGER_TYPE_P): - rewrite for generality. - * ch-decl.c (grok_chill_variantdefs): Use chill - comptypes, so that subrange compatibility is ok. - (start_chill_function): Use lookup_name(), not - IDENTIFIER_GLOBAL_VALUE, for full generality. - * ch-expr.c (chill_expand_assignment): Need to - handle non-NOP modify codes here, since C code - in build_modify_expr won't understand powersets, - etc. - -Tue Apr 27 09:05:31 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_max_min): Assign the set's - base type to the function's return type. - (build_chill_function_call): Before complaining - about parameter mismatches, convert certain actual - parameters. - * ch-expr.c (chill_expand_assignment): Before - complaining about LHS/RHS mismatches, convert - certain RHS expressions. - * ch-grant.c (decode_constant): Deep-fold incoming - expression, so we can output it. - * ch-lang.c (deep_const_expr): New function, called - from const_expr, actually traverses the tree - looking at its leaves for 'const'ness. - (deep_fold): New function to fold already-built - trees. - * ch-parse.y (case_expr): Add whitespace. - * ch-tree.h: Add prototype for deep_fold. - -Tue Apr 27 07:21:43 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_comptypes): Allow enumeration - subranges as compatible with the parent enum. - (build_chill_function_call): Before checking type - compatibility, use convert on typeless expressions, - like constructors. - * ch-expr.c (chill_expand_assignment): Before - checking type compatibility, use convert on - typeless expressions, like constructors. - * ch-lex.l: Add comment. - -Thu Apr 22 17:23:25 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: Add genopinit, insn-opinit.c - * c-common.c (binary_op_error): Prevent seg fault on - unknown node code. - * ch-typeck.c (build_chill_array_ref): Remove old - lower-bound-of-array-index-nonzero code. - * expr.c (expand-expr, get_inner_reference): Remove - old lower-bound-of-array-index-nonzero code. - -Thu Apr 22 16:01:09 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (shadow_record_fields): Add pushlevel for - each PROCESS parameter, too. - * ch-process.c (make_process_struct): First working - version. - * ch-tree.def: Add PROCESS_DECL definition. - * ch-tree.h: Add CH_IS_EVENT_MODE macro, change proto - for make_process_struct. - * expr.c (expand_expr): Add references to - PROCESS_DECL. Add #include of ch-tree.h. - * tree.c (decl_function_context): Add check for a - PROCESS_DECL, and #include for ch-tree.h. - -Thu Apr 22 09:25:08 1993 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (expand_expr): Add missing prototypes, and - parameters to expand_expr call. - -Wed Apr 21 16:17:07 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (shadow_record_fields): Add ability to - handle pointers to records/unions. For PROCESS - compilation. - -Thu Apr 22 09:25:08 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_expr): Add missing - parameters to expand_expr calls. Some trivial - reformatting for readability. - -Wed Apr 21 16:17:07 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l: Make send_*_prio externally visible, - default them to zero, eliminate the init flags. - Same for process_type. - -Sat Apr 17 10:59:50 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_binary_op): Build a - BIT_FIELD_REF tree for IN_EXPR operations. - * ch-typeck.c (build_chill_array_ref): Build a - BIT_FIELD_REF tree for access to packed array of - bits. - -Fri Apr 16 12:33:34 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (EXIT action): Improve error checking, - messages. - * ch-typeck.c (chill_expand_tuple): Remove code to - pack sets (moved to varasm.c long ago). - * varasm.c (unpack_set_constructor): Rename size to - bit_size, since 'size' always means bytes. - (pack_set_constructor): Rename size to wd_size, - since 'size' always means bytes. - (output_constant): Set size to zero, so that extra - bytes of padding aren't output after set constants. - -Fri Apr 16 11:57:50 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: Add .gdbinit. - * ch-decl.c (start_chill_bindings): Add function name - to binding contour's exit_label for EXIT stmt. - * ch-parse.y (EXIT action): Call lookup_name to avoid - inserting label for function name. Also check - IDENTIFIER_LABEL_VALUE for label's decl. - (caseaction, beginendblock, ifaction): Call - stamp_nesting_label to put action's label into - contour for EXIT to find. - -Thu Apr 15 17:17:05 1993 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (expand_expr): Unify, clean up handling of - IN_EXPR, and handling of bit-string element ref. - Now, all goes through IN_EXPR handler. - * stmt.c (stamp_nesting_label, expand_exit_labelled): - New functions, which allow either label or - function decls. - -Thu Apr 15 17:17:05 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c ch-actions.h ch-convert.c ch-decl.c ch-except.c - ch-expr.c ch-grant.c ch-inout.c ch-lang.c ch-lex.h ch-lex.l - ch-loop.c ch-parse.y ch-process.c ch-tree.c ch-tree.def - ch-tree.h ch-typeck.c: Add 1993 copyright, fix titles. - * ch-actions.c (build_chill_binary_op): Move runtime function call - to expr.c. Just build a tree here. Clean up error checking. - * ch-convert.c (convert): Simply store a type into an expression if - TREE_TYPE (expr) == NULL. Prevent error if an enum is to be - converted to a set of such enums. - * ch-loop.c (init_loop_counter): Restore error msg for undeclared - variable if no local scope is to be created for the loop. - * ch-typeck.c (build_chill_array_ref): Turn bit array ref into IN_EXPR, - remove redundant code which wasn't ever called. - -Wed Apr 14 07:54:00 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore (y.tab.c) : Add to list. - * ch-convert.c (convert): Check pointers better - avoid NULL reference. - Remove redundant check for ERROR_MARK - already checked earlier. - * ch-parse.y (get_type_of): Add parameter checks for NULL ptrs and - error_mark_node. - -Tue Apr 13 16:00:37 1993 Per Bothner (bothner@cygnus.com) - - * c-decl.c (start_function): If there is a previous - function declaration of the same name, steal its RTL. - This is a kludge needed for forward declarations of - nested functions. - * ch-decl.c (push_chill_extern_function), ch-tree.h: New - function, for external and seized function declarations. - Make sure to use permanent obstack. - * ch-parse.y (quasi_pdef, extprocedure): Use new function. - - * ch-grant.c (chill_finish_module_code): Since module - function is no longer visible,, can't get it using - lookup_name(). Use current_function_decl instead. - - * ch-decl.c (build_chill_function_type): Add void_type_node - to end of parameter types list. - - * ch-grant.c (chill_start_module_code): Make sure module - function isn't visible (and hence isn't granted). - -Tue Apr 13 15:48:25 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-loop.c (begin_chill_loop): Also stamp the user's loop name into - current contour for DO FOR EVER loops. - -Tue Apr 13 14:37:39 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (actionstatement): Add error rule. Delete - POP_UNUSED_ON_CONTEXT. Add comments about label name usage. - (nohandleraction): Better error check in EXIT processing. - (optexprlist): Comment out make_function_rtl call. - (seizestatement): Change error to warning. - -Tue Apr 13 08:29:31 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (raw_decode_mode): Supply missing parameter in get_type - call. - * ch-loop.c (begin_chill_loop): Take loop label as parameter. Stamp - its name into the current contour's exit_label, for EXIT to use. - * ch-parse.y: (actionlabel): Save label tree in global variable. - (actionstatement): Clear label to NULL when action is finished. - (handlerstatement, nohandlerstatement): Split actions into - categories which do/don't permit exception handlers. - (exitaction): Move code into nohandleraction, make it work. - (doaction): Pass (possibly NULL) label tree to begin_chill_loop. - * ch-tree.h: Add parameter to begin_chill_tree prototype. - * stmt.c (stamp_nesting_label, expand_exit_labelled): Add functions. - Note: This implementation of EXIT only exits from loops, not yet - from other bracketted statements. - -Mon Apr 12 13:41:55 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-grant.c (chill_grant): Remove obsolete code. - - * ch-decl.c (push_synmode, push_newmode): Merged to yield ... - * ch-decl.c (push_modedef): ... w/ slightly different interface. - * ch-tree.h, ch-process.c (make_process_struct), ch-parse.y - (modedefinition): Use new push_modedef function. - * ch-parse.y (modedefinition): Don't depend on inherited - attributes (- implemented incorrectly!): Use a global variable - parsing_newmode to distinguish synmode and newmode. - -Mon Apr 12 08:10:34 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-loop.c: Diffuse cleanup after big functional changes. - * ch-parse.y: Eliminate temporary variables, now unnecessary. Use - parse-time stack instead. - * ch-tree.h: Change build_chill_iterator prototype. - -Sun Apr 11 15:50:33 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c (convert): Replace an ERROR_MARK type - from a - untyped_expr with the given type. Move chill_expand_case_expr - call inside chill_expand_expr. - * ch-expr.c, ch-tree.h, ch-typeck.c (chill_handle_case_default, - chill_handle_case_label, chill_expand_case_expr): Move to ch-expr.c - from ch-typeck.c. - * ch-loop.c: Major reorganization to support multiple iterators in - DO FOR loop, very little new code, just a re-org. - * ch-parse.y (iterationlist): Add handling for multiple loop iterators. - -Sat Apr 10 14:40:12 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_lower, build_chill_upper): Clean up. - * ch-grant.c (chill_grant): Avoid making strange SYNMODE for enum - member. - * ch-lex.l (equal_number): Add function to look in the input for '=' - followed by a decimal literal. Call it from directive scanning. - (start state 'ccitt'): Deleted, unused. Moved unused, but reserved, - tokens to NORMAL state. - (compiler_directive): Replaced by equal_number. Now the only - recursive call to yylex happens in check_newline at the beginning - of a compilation. - -Sat Apr 10 09:55:50 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_case_expr): Added from ch-parse.y. - * ch-lex.l (ENTRY, PERVASIVE, ROW, STEP): Add token recognition to - 'reserve' them. - * ch-parse.y (case_expr): Move code into ch-actions.c. There will - need to be much more written. - * ch-tree.def (VARY_ARRAY_REF): Add comment. - * ch-tree.h (build_chill_case_expr): Add prototype. - * ch-typeck.c (build_chill_cast): Allow untyped_expr - just assign the - type to the expr. Check for CASE_EXPR, call expand_case_expr. - -Sat Apr 10 01:10:51 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-parse,y (in_pseudo_module): New variable. Try if we're - in a seizefile, but not in a module nested in the seizefile. - Use for backwards compatibility with old grantfiles. - * ch-decl.c (do_decls, push_syndecls, push_newmode, push_synmode): - If in_pseudo_module, grant new declaration. - * ch-decl.c (pushd_newmode): If there is a granted previous - incomplete type, fix it up. - * ch-grant.c (seize_implied_names): Do remaining types. - Guard against recursion. - * ch-tree.h (IDENTIFIER_ENUM_VALUE): Removed, not used. - * ch-tree.h (CH_DECL_ENUM), ch-grant.c (chill_grant), ch-lang.c - (finish_chill_enum): Enum constants are marked with - CH_DECL_ENUM so they don't get written to the grantfile. - * ch-tree.h (IDENTIFIER_GRANTED_VALUE): Allow fast seizing. - * ch-lex.l: Re-write to use start states, to avoid calling - yylex() recursively. - * ch-lex.l (compiler_directive); This is now obsolste. FIXME. - * ch-lex.l: Call push_module and pop_module when reading a - seizefile. This creates a pseudo-module. - * ch-parse.y: Clean up handling of empty declarations and - action statements; semicolons are now optional a number of - places. - * ch-parse.y: Remove some bogus tests for "statement - out of sequence" (they're both legal and work). - * varasm.c (mak_function_rtl): Remove kludge that may - not be necessary (and loses anyway). - -Fri Apr 9 09:37:38 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_array_assignment): Remove false error about - arrays that are too small. - * ch-parse.y (callaction): Don't pass an error_mark_node to - c_expand_expr_stmt. - -Fri Apr 9 00:26:54 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch_tree.h (DECL_HIDDEN_BY_MODULE, ENCAPSULATED_ARRAY_P): - New macros. - * ch-actions.c (build_chill_function_call): Use latter. - * ch-typeck.c (chill_similar): Fix typo. - * ch-grant.c (raw_decode_mode): Handle ENCAPSULATED_ARRAY_P - parameter types. - * ch-grant.c (seize_implied_names): Handle ranges of enums. - * ch-grant.c (do_seize): Set DECL_SOURCE_FILE and _LINE of - seized declaration to be the point of the seize itself. - * ch-grant.c (chill_grant), ch-tree.h: Add a parameter - which is the list (in order) of decls in the module. - Don't reverse the getdecls() list; that is handled by caller. - * ch-grant.c (chill_grant): Test that a declaration is - visible before writing it. - * ch-parse.y (push_module): Make sure to hide declarations - from surrounding module. - * ch-parse.y (pop_module): Restore those declarations. - * ch-parse.y (pop_module): This function is now responsible - for writing out for calling chill_grant() to the grant file. - * ch-actions.c (lang_finish): Remove calls to chill_grant(). - -Thu Apr 8 16:56:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_char_array_expr): Add handling of varying - arrays in relational expressions. - * ch-decl.c: Add prototype for lookup_name_current_level. - * ch-expr.c (chill_expand_expr): Make concat_expr's temp a BLKmode, - so its length is used as the temp's size. - (chill_expand_array_assignment): Correct for varying := varying - assignment, clean up. - * ch-typeck.c: Add prototype for require_complete_type. - -Wed Apr 7 16:41:29 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-loop.c (for_location, begin_chill_loop, end_chill_loop): Major - diffuse changes to fix location loops. - * ch-parse.y (location): Remove ref through NULL ptr. - -Wed Apr 7 13:42:06 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-decl.c (massage_param_node): New function. - It handles the LOC/IN/OUT/INOUT parameter distinction, - as well as calling build_chill_array_parm_type if needed. - * ch-tree.h (massage_param_node): New prototype. - * ch-decl.c (push_parms): Use new massage_param_node(). - * ch-parse.y (pmodearg): Use new massage_param_node(). - * ch-parse.y (formpar): Don't call build_chill_array_parm_type; - now handled by massage_param_node. - * ch-typeck.c (my_build_array_ref): Handle non-zero array - lower bounds. - * ch-actions.c (build_chill_function_call): If the formal - parameter is a pseudo record wrapped around an array, make - sure we wrap the actual parameter in a record CONSTRUCTOR. - * ch-typeck.c (build_chill_array_parm_type): Make sure - the pseudo struct type is allocated on the permanent_obstack. - * ch-parse.y (location): Remove thinko. - * ch-actions.c (chill_comptypes): Comment out test for - NEWMODEness - it gets broken by the forward declaration hacks. - -Tue Apr 6 18:05:40 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Move build_varying_struct to ch-typeck.c. - * ch-parse.y (formpar): Turn ARRAY_TYPE parms into structure. - * ch-parse.y (location): Do build_component_ref for an array wrapped - in a structure. - * ch-tree.h: Add prototype, #define for build_chill_array_parm_type. - * ch-typeck.c (build_chill_array_parm_type): Add function, move - build_varying_struct here from ch-actions.c. - -Mon Apr 5 19:56:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-decl.c: Use tree_int_cst_equal and integer_zerop - rather than in-line code - tests LOW and HIGH values. - * ch-lang.c: Use tree_int_cst_lt rather than inline code. - * ch-typeck.c (my_build_array_ref): Handle case where array low bound - isn't zero. - -Mon Apr 5 15:45:10 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-typeck.c (my_build_array_ref): Add some more code from - build_array_ref. Change checks, error messages to mention - 'discrete types'. I.E. types which don't kiss and tell.. - -Sat Apr 3 09:27:03 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-except.c, ch-expr.c: Turn externs into prototypes. - * ch-grant.c (chill_grant): Remove orphan #else. - * ch-tree.h: Add prototype for build_chill_bin_type. - * ch-typeck.c: Turn externs into prototypes, delete code which - was commented out in chill_expand_return; it will never be used. - -Fri Apr 2 21:55:14 1993 Per Bothner (bothner@rtl.cygnus.com) - - Major re-write of New module/seize/grant stuff. - Now, a grantfile is a spec module and contains all the - top-level declarations of the granting module, not just - those that are granted. It also contains explicit grant - statments naming those declared names that are granted. - It also has seize statements and use_seize_file directives - to correctly handle transitive dependencies. - - * ch-parse.y: Change to allow multiple modules per source file. - Allow spec modules (including quasi definitions) as well as - regular modules. - Allow spec modules inside normal modules; these behave as if - they were outermost. This violates the Blue Book, but is - needed by the new grantfile mechanism. (A grant file is a - spec module that gets included by the use_seize_file directive.) - * ch-parse.y (struct module *current_module, push_module, - pop_module): Support module nesting (for spec modules only). - - * ch-tree.h (struct module): New. - * ch-grant.c (granted_decls): New list of declarations - that have been granted into the outermode pseudo-module. - * ch-grant.c (decode_mode): If the decl has a name, - always write the name, not just if the decl has already - been written. Since we write out all decls, we can assume - it will be written later, and depend on the forward - declaration kludges to catch it. - * ch-grant.c (decode_decl): Don't write out _EXTERN. - Instead write out standard (Blue Book) quasi-definitions. - * ch-grant.c (push_granted): New function. - * ch-grant.c (seize_implied_names): New function. Re-write - how set element names are seized when a set type is seized. - * ch-grant.c (chill_seize): Work by seraching the - granted_decls list and copying the declaration. - * ch-grant.c (chill_grant): Write all declarations - declared in this module. Write GRANT statements for - those granted. seize statements for decls seized from - other modules. Write extra syntax to make a complete - spec module. - * ch-grant.c (grant_use_seizefile): Copy use_seize_file - directives into grant file. - * ch-lex.l (setup_seizefile_read): Call grant_use_seizefile. - - * ch-lex.l (struct input_state, current_input_state, - push_input_file, pop_input_file): New (type, variable, - function*2). Used to save and restore state on an input file. - * ch-lex.l: Clean up to handle nested input seizefiles - (needed by new grant/seize mechanism. - * ch-lex.l (skip_to_end_of_directive): New function. - * ch-lex.l (compiler_directive: USE_SEIZE_FILE): Make sure - we skip to the end of the directive *before* we switch - input files. - * ch-lex.l (setup_seizefile_read): Prevent reading the - same seizefile twice (otherwise likely with new grant/seize). - * ch-lex.l: Recognize SPEC. Misc cleanups. - - * ch-parse.y: Fixed foreward references of types. - Removed the unknown_type_node crock. - * ch-decl.c: Remove all uses of unknown_type_node. - Check for TYPE_SIZE zero instead. - * ch-decl.c (fixup_unknown_type): Make sure new mode - gets copied into old mode. Merge their variant chains. - * c-decl.c (lookup_name_current_level): Make non-static. - * ch-decl.c (lookup_name_current_level): No longer needed. - - * ch-parse.y (call): Allow an implicitly defined function - name following the CALL keyword. - * ch-tree.h (struct lang_identifier): Add implicit_decl, - and make sure order of fields matches c-tree.h. - - * ch-actions.c (lang_init, build_allocate_memory_call, - build_allocate_globals_memory_call): Fix names (add initial '_') - and prototypes of _allocate_[global_]memory (2nd param is ref). - Use build_chill_function_call, not build_function_call, - so the reference parameter gets handled. - * ch-actions.c. (lang_init): Make sure boolean_{true,false}_node - have boolean_type_node as their types. - * ch-actions.c (build_chill_lower, build_chill_upper): Fix to - work for arrays with BOOLEAN_TYPE ranges (and simplify some). - - * ch-except.c: Make sure an end_label is generated, - and jump to it if there is no exception. - - * ch-convert.c (convert_to_reference): Strip off NOP_EXPR casts. - * expr.c (expand_expr): Handle NOP_EXPR as Chill-style casts. - (Need cleaning up and FSF installation!) - * ch-parse.y: If taking the address of a cast, move the - ADDR_EXPR inside the NOP_EXPR. - - * ch-typeck.c (my_build_array_ref): Simplified, more suitable - versions of build_array_ref from c-decl.c. (E.g. don't barf - if index type is char or bool.) - * ch-typeck.c (build_chill_array_ref): Use my_build_array-ref. - - * ch-typech.c (build_chill_bin_type): New function. - Support BIN(N) range type specification. - * ch-parse.y (mode2), ch-lex.l: Recognize BIN(N). - - * ch-tree.h (CH_SIMILAR): Redefine in terms of chill_similar. - * ch-typeck.c (chill_similar): New function. Recognize that - that range types are similar to their parent types. - - * ch-tree.h: Declare flag_local_loop_counter. - * ch-loop.c: Whether the loop variable is local to the loop - in now controlled by flag_local_loop_counter, instead of - #ifdef'd on CREATE_SCOPE. - * ch-actions.c (lang_decode_option): Recognize flags - "-f[no-]local-loop-counter". - * toplev.c (lang_options): Add Chill flags -f[no-]local-loop-counter. - - * varasm.c (make_function_rtl): Due to problems with forward - references, don't rename nested functions in Chill. (Kudge!) - -Sun Mar 28 10:12:45 1993 Ken Raeburn (raeburn@kr-pc.cygnus.com) - - * ch-lex.l (push_back, readstring): Fix prototypes. - -Fri Mar 26 18:32:15 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y: Put %type directives back into alpha order. - (variant_alternative): Simplify error_mark test. - (variantfields, varianthack): Add error_mark checks. - -Fri Mar 26 13:36:23 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (convert_charliteral): Rewrite to avoid bogus error msg. - * ch-parse.y (get_type_of): Add function to deal with possible fwd - declared type name. Call it from lotsa places. Add lotsa checks - for error_mark_node. Standardize indentations. - -Thu Mar 25 15:00:11 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_assignment): Avoid seg fault while checking - for array assignments. - * ch-parse.y (action): Add recognition for allocate_memory and - allocate_global_memory system calls. - (mode2): Remove ill-conceived error check that broke REFs to - as-yet-undeclared types. Check for IDENTIFIER_NODE, lookup its - DECL if there, pass TREE_TYPE of decl to build_pointer_type. - (variantfields, varianthack): Clean up. - (variantfield): Check for IDENTIFIER_NODE, lookup its DECL if - there, pass TREE_TYPE of decl to grok_fixedfields. - (labellist): Explicitly assign error_mark_node to signal error. - * ch-typeck.c (chill_compatible): Report FALSE for bad parameters, - rather than seg faulting. - -Thu Mar 25 10:35:58 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (lang_init): build_function_type for allocate_memory - and allocate_global_memory runtime routines. Move discrete_type_p - into ch-typeck.c. - * ch-typeck.c (discrete_type_p): Move here, where it belongs, call it - in build_chill_cast. - -Wed Mar 24 16:25:16 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-grant.c: Don't grant previously seized names. - -Tue Mar 23 15:25:39 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in (ch-actions.o): Add dependencies (expr.h insn-codes.h) - * dwarfout.c (fundamental_type_code): Add handling of BOOLEAN_TYPEs, - avoid abort. - -Tue Mar 23 09:03:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_char_array_expr): Just build a type for the - result of a CONCAT_EXPR, and pass the tree back. - chill_expand_array_assignment can do a better job of - code-generation. - * ch-expr.c (chill_expand_array_assignment): Generate the CONCAT_EXPR - code. - -Mon Mar 22 12:42:58 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-except.c (start_handler_array): Make sure the handler - array and its type get on the permanent obstack. - * ch-grant.c (write_grant_file): Don't write the _INIT=name - specifier: It isn't needed, and loses (because of funny - characters in the chill_initializer_name). - * ch-decl.c (push_synmode): Set TYPE_NAME(mode) = syndecl. - * ch-lang.c (finish_chill_enum): Don't allocate a dummy - TYPE_DECL for the enum. I don't think it is needed (?), - and removing it is needed for the change above. - - * ch-grant.c (grant_array_type, decode_mode): Remove unused - 'decl' parameter. - * ch-grant.ch (raw_decode_mode): New function, based on old - decode_mode. - * ch-grant.c (decode_mode); This is now just a wrapper around - raw-decode_mode - but does not call raw_decode_mode if the - type is named and has already been emitted. - -Fri Mar 19 11:55:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Add prototypes, remove unused variables. Attempt to - continue generating grant file in presence of error (Wilfried's - patch to lang_finish). - * ch-expr.c: Change assign_stack_temp calls so temps get recovered - after each statement. Move convert call into - chill_expand_assignment from ch-parse.y. - * ch-grant.c: Generally re-order, clean up. Include Per's decode_mode - simplification. Include commented-out hack in decode_mode to return - type's name if type SEIZEd or already GRANTed in this file. - * ch-lex.l: Add prototypes. - * ch-parse.y (assignaction): Move convert call into - chill_expand_assignment. - -Thu Mar 18 16:04:45 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c (convert): Remove unused variable, fix int_size_in_bytes - comparison. - * ch-decl.c: Add prototypes, correct error message spelling, remove - unused variables. - * ch-lang.c (build_chill_range_type): Add error message. Add prototypes. - Correct comment spelling. - * ch-lex.l: Add prototypes, remove unused variable, put double parens aarround - assignment in conditional. - * ch-loop.c: Add prototypes, remove unused variable. - * ch-parse.y (structured_variable): Return NULL_TREE is invalid WITH - parameter is seen, don't count it in structured_variable_list. Pre- - vents seg fault when only WITH operand is invalid. - * ch-parse.y (label_spec): Correct assignment within IF expression which - was intended to be equality test. Remove unused variables. - * ch-tree.h: Add prototype. Remove unused EXCP_CODE enumeration, and - prototyping editorial comments. - * ch-typeck.c: Disable generation of code to validate array index for - now. Should be done as a call-back from more generic array_ref code. - Clean up parameter checking. Remove unused variables. - -Fri Mar 12 11:57:32 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (chill_varying_type_p): Return FALSE if given NULL type. - * ch-actions.c (build_chill_binary_op): Pass ALL arrays to - build_char_array_expr. - * ch-convert.c (convert): protect against seg fault, if type == NULL. - * ch-expr.c (chill_expand_expr): Add FIXME comment. - -Fri Mar 12 11:04:02 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_expr): Completely rethink set unary ops. - Thanks very much to dje! - -Thu Mar 11 21:06:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_char_array_expr, build_chill_binary_op): - Move CONCAT_EXPR handling from binary_op to array_expr. Add - handling for relationals between varying arrays to array_expr. - -Thu Mar 11 19:20:37 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_set_expr, build_chill_binary_op): Calculate - *BIT* length of powersets and arrays of BOOLs. - (invalid_left_operand, invalid_right_operand): Disallow relationals - with arrays of BOOL as operands. - * ch-convert.c (convert): Test TREE_CODE for ERROR_MARK rather than - comparing pointers. - * ch-decl.c (push_newmode): Re-indent. - * ch-expr.c (chill_expand_expr): Calculate *BIT* length of powersets - and arrays of BOOLs. - * ch-lang.c (build_chill_array_type): Add parameter error checking. - -Mon Mar 8 17:13:00 1993 Bill Cox (bill@rtl.cygnus.com) - - * expr.c (store_constructor): Handle set construction. - * varasm.c (output_constant): Prevent seg fault - terminate case - alternative with a 'break'. - -Mon Mar 8 17:13:00 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (): Move SET_TYPE constructor to expr.c. - * ch-loop.c (end_chill_loop): Only do expand_end_loop if not POWERSET loop. - * ch-typeck.c (build_chill_cast): Fix error msg spelling. - -Mon Mar 8 13:16:05 1993 Bill Cox (bill@rtl.cygnus.com) - - * fold-const.c (fold_convert): Allow CHAR_TYPE CONVERT_EXPR to - be folded. - -Mon Mar 8 10:13:57 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (get_tag_value): Correctly output certain enumerations. - Correct some non-standard indentations. - -Fri Mar 5 14:58:35 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Fix up comment. - -Thu Mar 4 18:05:43 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Define builtin '__nepowerset' and call it - avoid - negating the result of calling __eqpowerset. New function - discrete_type_p(). - * ch-grant.c (get_tag_value): Don't seg fault referring to an - anonymous enumeration's name. - * ch-lex.l: Turn EVEN token into an ignored compiler directive. - * ch-loop.c (end_chill_loop): Output end-of-loop marker. - * ch-parse.y (label_spec): redefine variant structure label_spec - to agree with the Z.200 spec. - (locdec): Error if set/bitstring initialized with a tuple. - (case_label, arrayindex): Use new discrete_type_p - function. - * ch-process.c: Fix typo. - -Wed Mar 3 14:30:53 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-lang.c, ch-tree.h: Rename build_range_type to - build_chill_range_type. Call new build_range_type() in tree.c. - * ch-parse.y: Call build_chill_range_type as approriate. - * ch-typeck.c (build_chill_cast); Clean up. - -Wed Mar 3 09:36:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y: Define CONTINUE_EVENT token. - * ch-parse.y (mode2): Give error message for SYN modea = modeb - where modeb is undefined. - -Tue Mar 2 20:16:37 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Add builtin function descriptions for memset and - bitsetpowerset. Allow build_chill_num expression to exceed 16 bits, - but not 32. - * ch-tree.h: Correct chill_handle_case_default prototype. - * ch-actions.h, ch-lex.h: Add prototypes. - * ch-lex.l, chill.gperf: Add CONTINUE_EVENT token. - -Thu Feb 25 17:35:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (init_decl_processing): Disable creation of C-specific - builtin functions. They pollute the CHILL name space. - * stor-layout.c (variable_size): Allow variable-size objects at file - scope, for CHILL. - -Fri Feb 26 07:14:34 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (finsh_decl): Don't output non-constant storage size - error for CHILL - * ch-actions.c: Call build_temporary_variable, fix build_tree_list - call in build_chill_cause_exception. - * ch-convert.c, ch-expr.c: Use tree_cons to build list's last entry - * ch-loop.c (build_temporary_variable): New function - * ch-process.c: Call build_temporary_variable, spell start_process - correctly. - * ch-tree.h: Extern for build_temporary_variable - -Thu Feb 25 12:09:01 1993 Bill Cox (bill@rtl.cygnus.com) - - * c-decl.c (init_decl_processing): Disable initial creation of C-specific - builtins - they pollute the CHILL name space. - * ch-typeck.c (valid_array_index): Correct upper-bound check. - * expr.c (expand_expr): Use actual library name for __inpowerset - builtin. - * stor-layout.c (variable_size): Disable complaint about variable- - size type or decl at file scope. Perhaps later this s.b. a warning. - * varasm.c (emit_set_data): Add function. - (output_constant): Call new emit_set_data function for VAR_DECLs, - in addition to CONSTRUCTORs. - -Thu Feb 25 11:34:36 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: Change all builtin functions names to their - actual library names. Change references to boolean_type_node - to references to the TREE_CODE == BOOLEAN_TYPE, to follow the - convention. - build_set_expr: Remove length parameter, call powersetlen() instead. - remove handling of CHAR arrays - they're handled in build_char_array_expr. - Call __eqpowerset to test for equality - we can't use a byte-length - - need bitcount instead. - build_chill_compound_expr, internal_build_compound_expr: Copy from C - version that does stuff we don't want. - build_binary_op: Check for in_size_in_bytes return < 0, indicating - size is changeable at run time. Build two memcpy calls to implement - string concatenation. - powersetlen: Add function. - build_chill_card: Call powersetlen. - build_chill_max_min: Common code for powerset max/min. - build_chill_length: Move VARYING array handling before regular char - array handling. - * ch-expr.c chill_expand_expr: Disable concatenate code - we need to - the VARYING status of the target to do this correctly. Use powersetlen - for the powerset operations, not a byte length. - * ch-loop.c: Make CREATE_SCOPE #define to enable creation of a new scope - for each CHILL loop, as Z.200 requires. Add powerset and error flags - to loop structure. Evaluate user's powerset expression into a temp, - scan it destructively with __ffsetclrpowerset or __flsetclrpowerset - for powerset loop. Only do loop-end assignments if NOT a powerset - loop, which has much less overhead now. - * ch-tree.h: Add prototype for powersetlen. - -Fri Feb 19 08:40:24 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l (convert_number): Evaluate number and pass it as - HOST_WIDE_INT. - -Fri Feb 19 08:56:44 1993 Michael Tiemann (fs_tie at rcsw18) - - * ch-typeck.c (build_chill_array_ref): Handle newmodes - correctly. - - * ch-actions.c (chill_comptypes): Always initilize ERRSTR if - we are going to return 0. - - * ch-convert.c (convert_to_reference): Don't use - TYPE_MAIN_VARIANT, because REFTYPE's type may be a newmode - (which must match the type of the expr). - - * ch-grant.c (chill_seize): Don't let a type be copied just - because we are seizing it. - - * ch-lang.c (finish_chill_enum): Convert TYPE_MIN_VALUE and - TYPE_MAX_VALUE to integer type. - - * ch-loop.c (begin_for_range): Set lp->iter_type based on the - tree type of the bounds. - (build_loop_top): type of GE_EXPR and LE_EXPR is - boolean_type_node, not lp->iter_type. - (for_location): Ditto. - - * ch-action.c (build_chill_lower,build_chill_upper): Handle - ENUMERAL_TYPE. Also, handle different kinds of arguments more - cleanly. - - * ch-parse.y (iteration): Convert start_exp and end_exp to - match the type of modename. - - * ch-grant.c (chill_seize_aggr): Search also through anonymous - types. - - * ch-grant.c (chill_seize): Check to see if SEIZEITEM has - already been seized, and if so, do nothing. - - * c-typeck.c (process_init_constructor): If DEFAULT_VALUE - comes out error_mark_node, set ERRONEOUS. - - * ch-actions.c (build_chill_binary_op_1): If EXP is NULL_TREE, - don't use it. - - * ch-action.c (chill_comptypes): Test for structural - equivalence of enums. - - * ch-typeck.c (build_chill_array_ref): Convert INDEX to - TYPE_MIN_VALUE of DOMAIN if the types are compatible. - - * ch-grant.c (chill_seize): If DECLS is a TYPE_DECL for an - ARRAY_TYPE, seize the domain type if its a set. - -Thu Feb 18 20:02:15 1993 Per Bothner (bothner@rtl.cygnus.com) - - * c-typeck.c (process_init_constructor): Emit error if some - array elements are not initialized. - * c-typeck.c (process_init_constructor): Call digest_init() - recursively to expand default_value. - * ch-expr.c (chill_expand_array_assignment): Simplify, and - handle the case that the lhs has dynamic size (e.g. a slice). - * ch-parse.y (elementlist): Handle the case that tupleelement - generates more than one TREE_LIST node. - -Thu Feb 18 12:40:56 1993 Michael Tiemann (fs_tie@rcvie.co.at) - - * .cvsignore: add yacc sources, xgcc and stmp-* files. (Bill) - * c-typeck.c (lookup_field): add function, calls. - * ch-actions.c (build_chill_binary_op): figure return_type differently. - * ch-convert.c (convert_to_reference): return error_mark_node, - STRIP_NOPS. (convert): Braces for readability. - * ch-decl.c (build_chill_function_type): accept typespec as parm. - Handle exceptions. - (grok_chill_variantdefs): call comptypes, not chill_comptypes. - * ch-expr.c (chill_expand_assignment): handle references. - * ch-grant.c (chill_seize_set, chill_seize_aggr): new functions - * ch-parse.y (structured_variable): check for REFERENCE_TYPE, - call convert. Generally handle reference types. - - -Thu Feb 18 09:30:11 1993 Michael Tiemann (fs_tie@rcvie.co.at) - - * ch-actions.c (chill_comptypes): Figure out which newmode or - synmode decls look most canonical. - * ch-convert.c (convert): handle location conversions of records, - unions and arrays. - * ch-decl.c (fixup_unknown_type): changes for variant records - * ch-parse.y (tupleelement): avoid confusing digest_init. - * ch-typeck.c (build_chill_array_ref): give element ref the - type of the ELEMENT, not the array (Bill Cox). - -Wed Feb 17 11:52:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y: change push_newmode and push_synmode interfaces. - * ch-actions.c (build_chill_binary_op): convert operands. - -Wed Feb 17 10:54:24 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_binary_op, build_chill_unary_op): - handle reference types. - * ch-decl.c (push_newmode, push_synmode): rewritten - * ch-process.c (make_process_struct): new push_newmode interface. - * ch-typeck.c (build_chill_cast): change interface, error checks. - -Wed Feb 17 09:50:37 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c, ch-parse.y, ch-tree.h: delete old INOUT, OUT parameter - code. - * ch-typeck.c (valid_array_index): new function. - -Tue Feb 16 22:36:34 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-convert.c (convert): Slightly more correct conversion - for ARRAY_TYPEs (return as OK if CH_COMPATIBLE). - * ch-expr.c (chill_expand_array_assignment): Invoke - __builtin_memcpy using build_function_call, not directly at - the rtx level (which doesn't work). - * ch-typeck.c (build_chill_slice): First attempt at slices. - * ch-tree.h, ch-typeck.c (build_chill_slice_with_range, - build_chill_slice_with_length): New functions. - * ch-parse.y: Use new slice-building functions. - * expr.c (get_inner_reference): Subtract low bound of - array when doing an ARRAY_REF. - -Tue Feb 16 14:17:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): better comments. - * ch-decl.c (push_parms): encode OUT, INOUT parms in additional way. - * ch-parse.y: indentation cleanup - -Tue Feb 16 12:03:53 1993 Michael Tiemann (tiemann@cygnus.com) - - * ch-decl.c (grok_chill_variantdefs): Really implement variant - records for CHILL. - * ch-grant.c (get_tag_value): New function. - * ch-grant.c (decode_mode): Grant variant records. - - * ch-grant.c (chill_seize): If we seize a set, seize the set - values. - - * ch-lex.l (RETURN_TOKEN): Make this safe to use in if/else - constructs. - - * ch-parse.y (EMPTY): New pseudo-token to disambiguate - variant_alternatives. - (current_fieldlist): New variable to help processing tag - declarations in variant records. - (fields): Renamed from structdef. - (field): Renamed from fields. - (varianthack): New non-terminal to handle parsing ambiguity - for variant records. - (optlabellist): Changed to preserve CONST_DECLs when they are - parsed. - - * ch-tree.h (TYPE_TAGFIELD): New macro. - (TYPE_TAG_VALUES): Ditto. - -Mon Feb 15 00:49:34 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-grant.c (decode_mode): Fix output for powerset modes. - * ch-grant.c (decode_constant): Support grant output of - powerset literals. - * ch-actions.c (build_chill_binary_op): IN_EXPR fix. - * expr.c (expand_expr): Add Chill-specific kludge for - BIT_FIELD_REF if operand is SET_TYPE to call runtime function. - * ch-expr.c (chill_expand_assignment): Remove no-longer-needed - special-case support for a BIT_FIELD_REF in right-hand-side. - * ch-lang.c (finish_chill_enum): Patch up enum elements to - have the correct type (instead of integers, as in C). - - * ch-lex.l, ch-parse.y: Add disgusting hack (involving - context-dependent look-ahead) so we can parse exception - handlers correctly. - * c-typeck.c (digest_init): Set output type for SET_TYPEs. - * varasm.c (unpack_set_constructor): Add support for - (power-)set ranges (i.e. low_element:high_element). - -Sun Feb 14 13:37:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-inout.c: delete unused #include - * ch-typeck.c (build_chill_slice): turn abort call into error msg. - -Sat Feb 13 13:13:31 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: Add cc1chill to STAGESTUFF per Eichin's suggestion. - -Sat Feb 13 12:17:41 1993 Bill Cox (bill@rtl.cygnus.com) - - * Makefile.in: add lots of header files to the CHILL dependencies - -Fri Feb 12 15:48:27 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): Don't return - error_mark_node on empty parameter-list. - -Fri Feb 12 12:54:52 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): fix start_decl parms. - * ch-parse.y (PUSH_ACTION): guarantee to generate an insn! - -Fri Feb 12 10:32:37 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): create temps, do - assignments to handle INOUT and OUT parameters. - * ch-decl.c (build_chill_function_type): better parameter name. - * ch-parse.y (action): keep rules in alpha order. - (pmodearg): turn INOUT, OUT parameter types into reference types. - * ch-typeck.c (build_tree_slice): indentation change. - -Thu Feb 11 23:16:34 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-lex.l (convert_bitstring), Changed SET_TYPE_CONSTRUCTOR to - take a list of elements which are in the set. This corresponds - better to the tuple input form in Chill (and Pascal). - * varasm.c (unpack_set_constructor, pack_set_constructor): - New functions, to expand SET_TYPE CONSTRUCTORs. - * varasm.c (output_constructor): Use pack_set_constructor - to assemble a SET_TYPE constant from a CONSTRUCTOR. - - * ch-grant.c (decode_constant): Better grant for strings, - enumeral, and bitstring constants. - * ch-grant.c: Fixes in seize to avoid duplicates, and emit - things in the correct order. - * c-typeck.c (chill_initializer_constant_valid_p): Kludge - needed to export a static function. - * ch-typeck.c (convert): Avoid needlessly (and lossingly) calling - chill_expand_tuple to convert fix string to varying. - * ch-actions.c (build_chill_binary_op): Promote short - integer operands if needed (otherwise emit routines barf). - * ch-tree.h (SET_WORD_SIZE): New macro. - * ch-parse.y: Fix syntax for RECEIVE CASE. - * ch-parse.y (location): If IDENTIFIER is a CONST_DECL - return its value instead. - -Thu Feb 11 07:41:45 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_max, build_chill_min): clean up - * ch-typeck.c (chill_expand_tuple): correct set initialization from - an enumeration tuple. Add sort_constructor function. - -Thu Feb 11 07:41:45 1993 Bill Cox (bill@rtl.cygnus.com) - - * config/sparc.c (sparc_type_code): handle CHAR_TYPE and - BOOLEAN_TYPE w/out an abort. - -Wed Feb 10 14:59:53 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: change most integer_type_node references to - chill_integer_type_node. Rewrite _max and _min routines, - redefine the signatures for those runtime routines. Move - empty-set check into runtime. - * ch-expr.c, ch-loop.c, ch-process.c, ch-tree.c, ch-typeck.c: change - most integer_type_node references to chill_integer_type_node. - -Tue Feb 9 16:00:05 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-except.c: New file. Stuff for exception handling. - * ch-parse.y: Add working exception handling support. - * ch-lex.l, ch-parse.y: Prefer standard type terminology - (BOOLS, CHARS) even though non-standard (BITS, CHAR) is ok. - * ch-grant.c: Fix various problems related to granting - types such as bitsets. - * ch-tree.c (build_bitstring_type): Set TYPE_MIN_VALUE - to distinguish bitstrings from powersets (in the same way - we distinguish char strings from char arrays). - * ch-tree.h: New macro CH_BOOL_TYPE_P. - * ch-tree.h, ch-actions.c (lang_init), ch-grant.c (decode_mode): - Undo kludge where integer_type_node was hardwired to 16 bits. - Make integer_type_node etc have the same size as in cc1. - New types chill_integer_type_node and chill_unsigned_type_node - that correspond to the Chill source types INT and UINT. - For now, these match the C 'short' types, but that should - become a configuration option later, - -Tue Feb 9 11:41:25 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_unary_op): allow NOT of a set. - -Tue Feb 9 08:27:18 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_function_call): add test for - too many/few actual parameters (and avoid seg fault). - * ch-decl.c (do_decls): code cleanup for readability. - * ch-loop.c (begin_chill_loop, end_chill_loop): remove - emit_nop() calls - they now (since exceptions) cause seg faults. - Make derogation on poor CHILL compiler non-specific. - * ch-parse.y (mode2): enable VARYING keyword in CHAR(expr). - * ch-tree.h: remove prototypes added to c-tree.h. - * ch-typeck.c (build_chill_array_ref): correct getting domain - subtree for a PARM_DECL. Subscripting a SET_TYPE is turned into - an IN_EXPR. - -Sun Feb 7 18:20:49 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.def: add a new tree type - just for varying array - references. We were using ARRAY_REF, but the underlying C - code also generates that one. - * ch-convert.c, ch-expr.c, ch-typeck.c: use the new tree type. - -Sun Feb 7 17:33:17 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c: test given type against type of expr before - calling chill_expand_tuple. We were getting lots of spurious - calls... - -Fri Feb 5 15:24:01 1993 Per Bothner (bothner@rtl.cygnus.com) - - * cccp.c: Merge in various Chill-specific changes. - * gcc.c (default_compilers array): Pass -lang-chill - to cpp, not -lang-ch. - -Fri Jan 29 17:18:22 1993 Per Bothner (bothner@rtl.cygnus.com) - - * Makefile.in (install-libchill, install-librmt): Removed. - * ch-actions.c (build_chill_exception_decl): Change decl - to initialized char array, rather than unitialized common. - (Simplifies extracting string name of exception.) - * ch-actions.c: Adjust interface to cause_exception accordingly. - * ch-typeck.c (build_chill_array_ref): Cause rangefail if - index > limit, not >= limit. - - * ch-actions.c (build_chill_function_call): Rename misleading - formal parameter. - * ch-decl.c (do_decls): Allow (again) general initializer exprs. - * ch-parse.y (call): Test for function call needs to test for - FUNCTION_TYPE, not FUNCTION_DECL. - nreverse arg list to build_chill_array_ref. - * ch-typeck.c (build_chill_array_ref): Do recursive call at end - and only if multiple indexes. - * ch-typeck.c: Cleanups. - -Fri Jan 29 11:05:58 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_decls): handle set initializations better, more to do. - * ch-loop.c (begin_for_range): correct interface to expand_start_cond - and build_binary_op. - * ch-tree.h: lots more prototypes - * ch-typeck.c (build_array_from_set): added function. - * ch-typeck.c (chill_expand_tuple): handle set initializations better. - -Thu Jan 28 17:41:58 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-grant.c (set_default_grant_file): Change default. - Normally, grant file should end up in cwd. - * ch-lang.c (build_chill_struct_type): Call pushtag, - for the sake of debugging. - * ch-lex.l: Improve comment parsing. - * ch-lex.l (readstring): Some improvements. - Initial support for control sequences in string literals.a - -Thu Jan 28 16:16:00 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-convert.c (convert): correct fixed->varying conversion. - * ch-parse.y (mode2): delete unesthetic newline. - -Thu Jan 28 10:32:55 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: delete maybe_array_ref() - * ch-expr.c (chill_expand_assignment): handle RHS array_ref, delay - calling convert(). - * ch-lex.l, ch-parse.y, chill.gperf: add keywords, syntax for time - supervision actions & builtins - * ch-parse.y (call): eliminate optlocarrayidx, call build_chill_slice, - smaller actions directly (maybe_array_ref() used to call them). - * ch-tree.h: add build_chill_function_call, build_chill_slice - * ch-typeck.c: add build_chill_slice() - -Thu Jan 28 08:44:28 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.h: bring up to date with ch-actions.c changes. - -Wed Jan 27 23:45:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_assignment): handle an RHS varying array - reference. - -Wed Jan 27 22:28:36 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-grant.c (decode_constant): Add REAL_TYPE support. - * ch-actions.c (build_chill_exception_decl): New function. - * ch-actions (build_chill_cause_exception, cond_exceptions): - Convert to take a (char*) parameter (the exception name). - * ch-actions.c, ch-expr.c, ch-typeck.c: Convert calls to - cond_exception. - * ch-parse.y (check_end_label): New function, to check if - and end label matches start label. - * ch-parse.y: Fix syntax to properly recognize and - test optional end labels (using check_end_label). - * ch-decl.c (finish_chill_function): Simplify, since - we assume check_end_label has already been called. - * ch-parse.y: Put in infrastructure for exception handling. - -Wed Jan 27 15:45:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c: delete convert_chill_parameter, replace call with - call to convert(). - * ch-convert.c (convert): combine chill_give_type_to_expr in here. - * ch-decl.c: call convert rather than chill_give_type_to_expr. - * ch-expr.c: delete chill_expand_array_assignment, move code to convert. - * ch-expr.c (chill_expand_assignment): just call convert. - * ch-loop.c (end_chill_loop): expand the end of the loop for a - do while. - * ch-parse.y: call convert rather than chill_give_type_to_expr. - * ch-process.c: checkpoint. - * ch-typeck.c: delete chill_give_type_to_expr, call convert instead. - -Wed Jan 27 15:45:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-grant.c (grant_array_type): new function to allow handling of - VARYING array types. - -Wed Jan 27 15:45:20 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-typeck.c (chill_give_type_to_expr): fix typo. Reorder to - avoid checking types on CONSTRUCTORs. Correct typo. - * ch-expr.c (expand_assignment_to_varying_array): use proper - expansion function expand_expr_stmt. - * ch-expr.c (expand_chill_assignment): only convert VARYING - array refs or RHS. - -Wed Jan 27 15:32:21 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_length, build_chill_lower, - build_chill_upper): accept parameters, too. - * ch-expr.c (chill_expand_assignment): decipher ARRAY_REF on RHS. - * ch-typeck.c (chill_give_type_to_expr, build_chill_array_ref): - assign proper type to ARRAY_REF expression. - -Wed Jan 27 09:51:46 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c (build_chill_binary_op): delete unused variable, - get set's base type from TYPE_DOMAIN rather than TREE_TYPE. - * ch-actions.c (build_chill_repetition_op): handle differently-built - declaration trees. - * ch-loop.c (begin_for_set): adapt to new powerset declaration tree. - * ch-typeck.c (chill_give_type_to_expr): give type to constructor - -Tue Jan 26 11:32:38 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (ifaction): re-add lost call to expand_end_code(). - * ch-parse.y (siezelist, grantlist): use 'name' rather than - 'checked_name'. It makes no sense to check sieze/grant names - for WITH expansion. - * ch-expr.c (chill_expand_expr): delete unnecessary (and - seg-fault-causing) code. - * ch-expr.c (chill_expand_assignment): make test for varying array - on the LHS more specific. - * ch-actions.c (invalid_left_operand, invalid_right_operand): error - for use of MOD, REM operators. - * ch-actions.c (build_chill_repetition_op): error for bit-field - initializers (which will get handled in the lexer). - -Mon Jan 25 17:26:47 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-typeck.c (build_chill_array_ref), - * ch-expr.c (chill_expand_expr, chill_expand_assignment): - translate varying array ref into ARRAY_REF, defer processing - until chill_expand_expr. Update array's length field in - new function expand_assignment_to_varying_array. - -Mon Jan 25 14:57:24 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (mode2): eliminate old method to mark varying arrays. - * ch-expr.c (expand_varying_length_assignment): repair scaling of - RHS expression. - -Mon Jan 25 11:44:21 1993 Per Bothner (bothner@cygnus.com) - - * ch-parse.y: Allow character and bitstring literals - in string repetition operator. - -Sat Jan 23 14:18:11 1993 Per Bothner (bothner@cygnus.com) - - * ch-parse.y (primval): Re-recognize '(' expr ')'. - * ch-parse.y (name): Remove call to check_identifier - - this is not appropriate in certain contexts. - * ch-parse.y (checked_name): Same as <name>, but *with* the - call to check_identifier. Use where appropriate. - * ch-parse.y (operand5): Only allow string repetition of - string literals, because otherwise you get a conflict. - -Thu Jan 21 16:32:39 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-actions.c, ch-parse.y, ch-process.c, ch-tree.h: sync modules, - continue start_process development. - -Thu Jan 21 13:51:06 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_decl): fix handling of multi-char initializer. - -Thu Jan 21 13:14:00 1993 Bill Cox (bill@rtl.cygnus.com) - - * .cvsignore: add CHILL files to be ignored - -Thu Jan 21 07:38:57 1993 Bill Cox (bill@cygnus.com) - - * ch-parse.y: rough draft of start_process handling. - -Wed Jan 20 17:11:05 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-inout.c: fix mismatch with readtext proto in ch-tree.h. - -Wed Jan 20 16:48:13 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.h, ch-process.c, ch-inout.c, Makefile.in: - create new modules for I/O and process-related stuff. - * ch-actions.c: move routines to new modules. - call xmalloc, not malloc. - * ch-lang.c (build_chill_struct_type): add parameter checking. - * ch-lex.l (init_lex): remove redundant cast. - -Tue Jan 19 16:33:56 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y (operand5): delete unnecessary argument to - build_chill_unary_op. Add rule for string repetition. - * ch-parse.y (primval): delete string repetition attempt. - * ch-parse.y (start_process): rough draft of action. - * ch-actions.c (build_repetition_op): add it - * ch-actions.c (build_chill_binary_op): handle constant arguments - of CONCAT_EXPR, combine into a single string if possible. - * ch-actions.c (invalid_left_operand, invalid_right_operand): - allow single character arguments to CONCAT_EXPR. - * ch-tree.h: add prototype for build_repetition_op - -Tue Jan 19 15:03:29 1993 Fred Fish (fnf@cygnus.com) - - * dwarfout.c (output_type): Add hack that matches the one in the - chill front end to distinquish between true string types and - arrays of char, since it uses ARRAY_TYPE for both, rather than - trying to use the existing support for STRING_TYPE. - -Tue Jan 19 13:54:27 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-tree.h: added prototypes for all non-static CHILL functions. - * ch-actions.c (lang_init): declare builtin type for start_process - * ch-actions.c (build_chill_binary_op): combine string literals when - concatenated. - * ch-actions.c (formpars2struct): added for later start_process - implementation. - * ch-actions.h: remove un-needed function declarations. - * ch-decl.c: extern cleanup. - * ch-expr.c (chill_expand_array_assignment): add missing first - parameter to cond_exception call. - * ch-lex.l: make build_chill_string non-static. - -Mon Jan 18 19:15:08 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_decls): get varying array length initialized. - -Mon Jan 18 09:51:43 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c (chill_expand_array_assignment): fix the copy length - in the memcpy call (it was just 4 bytes always). Simplify some - code, also. - -Mon Jan 18 08:24:21 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c (do_decls): change CH_VARYING_TYPE_P to function. - -Mon Jan 18 08:00:11 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-lex.l, ch-parse.y: make BOOLS synonymous with BIT and - CHARS synonymous with CHAR, in the lexer. Delete unnecessary - 'bools' non-terminal. - * ch-parse.y (assignaction): add lhs version of length() function - * ch-actions.c: add builtin_concat function, lots of support for - CONCAT_EXPR. - * ch-actions.c, ch-tree.h: make a function out of former - macro CH_VARYING_TYPE_P - * ch-expr.c: add expand_varying_length_assignment (). - * ch-expr.c (chill_expand_expr): add CONCAT_EXPR support. - * ch-expr.c (chill_expand_array_assignment): call emit_library_call - rather than build_rts_call, to eliminate a recursion problem. - * ch-lang.c: eliminate 'sorry' about varying arrays. - * ch-typeck.c (validate_varying_array_ref): re-enable constant - index validation. - -Sun Jan 17 18:20:04 1993 Per Bothner (bothner@cygnus.com) - - * ch-grant.c, ch-lex.l: Major simplification of how - seizes are done and how seizefiles are read. - * ch-actions.h: Remove declaration of check_seize(). - * ch-decl.c (do_decls): Handle READONLY types. - * ch-parse.y (mode2): Allow REF to be followed by any mode. - * ch-parse.y (mode2): Allow literal expressions in string length. - * ch-parse.y (tupleelement): Allow elemenst to be untyped_expr. - * ch-parse.y (seizestatement, etc): Call chill_seize each - time something is seized, rather than building a list first. - -Sat Jan 16 12:24:44 1993 Bill Cox (bill@rtl.cygnus.com) - - * chill.gperf, ch-hash.h: add Wilfried's tokens - * ch-lex.l: fold in Wilfried's changes. Some tokens - weren't getting recognized, and INSTANCE wasn't correctly - reported to ch-parse.y as a PREDEF_MODEDCL. - -Thu Jan 14 15:02:39 1993 Per Bothner (bothner@cygnus.com) - - * ch-tree.h (CH_CHARS_TYPE_P): New macro. Add comment - explaining difference between char strings and char arrays. - * ch-tree.h (CH_STRING_TYPE_P): Add FIXME re bitstrings. - * ch-tree.c (build_string_type): Add comment. - -Wed Jan 13 15:19:15 1993 Per Bothner (bothner@cygnus.com) - - * calls.c, expr.c, function.c, stmt.c, varasm.c: Set - MEM_IN_STRUCT_P for SET_TYPE where it is set for other aggregates - * expmed.c (store_bit_field, extract_field_field): Undo - yesterday's removal of MEM_IN_STRUCT_P "sanity test". - - * ch-decl.c (do_decls): Put back support for initializing. - (Was accidentally removed in Jan 8 change.) - -Wed Jan 13 14:13:11 1993 Jim Wilson (wilson@sphagnum.cygnus.com) - - * ch-lex.l (convert_bitstring): Correct typo in cast. - -Tue Jan 12 20:29:08 1993 Per Bothner (bothner@cygnus.com) - - * ch-lex.l (convert_bitstring): Change to pack bits - within words, not bytes, and to use machine bit-order - (not always little-endian). - * ch-parse.y: Allow BOOLS(n) as well as BITS(n). - Use build_bitstring_type, not build_string_type. - * expmed.c (store_bit_field, extract_field_field): Remove - "sanity test" that prevents use with SET_TYPE. - * tree.c (build_bitstring_type, build_powerset_type, - build_string_type): Move (so far) Chill-specific functions to ... - * ch-tree.c: ... new file. - * ch-tree.c (build_powerset_type, build_bitstring_type): Re-write. - * ch-typeck.c (build_chill_array_ref): Handle bit strings better. - * ch-typeck.c (chill_expand_tuple): Kludge to handle SET_TYPE. - * Makefile.in (CHILL_OBJS): Add ch-tree.o. - * ch-decl.c (do_decls): Call expand_decl. - * stor-layout.c (layout_type): Handle SET_TYPE. - * expr.c (expand_expr): Add FIXMEs about IN_EXPR. - * ch-actions.c (lang_init): Add type and decl for new - function __builtin_setbitinstring. - * ch-expr.c (chill_expand_assignmment): Special-case handling - for BIT_FIELD_REF with non-constant bit position (which is - not yet handled by expand_expr). - * ch-convert.c (convert): Handle SET_TYPE. - -Tue Jan 12 12:49:13 1993 Fred Fish (fnf@cygnus.com) - - * chill: If -B arg is given, use to find gcc. - -Fri Jan 8 20:21:43 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c: revert to avoid seg fault - -Fri Jan 8 14:20:42 1993 Bill Cox (bill@rtl.cygnus.com) - - * ch-decl.c: fix storage into correct offset in varying array. - * ch-actions.c: define sizetype for everyone, use it to build - varying structure. - * ch-parse.y: tiny cleanup. - -Wed Jan 6 13:25:33 1993 Bill Cox (bill@cygnus.com) - - * modules: use gdb rather than naked-gdb, to get opcodes - in chill definition. - -Wed Jan 6 09:48:35 1993 Bill Cox (bill@cygnus.com) - - * ch-typeck.c: add code to handle references to elements of VARYING - arrays. Simplify chill_give_type_to_expr. Add rough draft of run- - time index checking for VARYING arrays (under #if 0). - * ch-actions.c: new function cond_type_range_exception & calls. - New function cond_range_exception, for more general range-checking. - New function build_varying_struct, to do just that. Use the macros - for the special varying field names. - * ch-tree.h: define macros for varying field names. - * ch-expr.c: use macros for varying struct names. Simplify - chill_expand_array_assignment. - * ch-parse.y: assure that build_varying_struct is called everywhere - that it applies. Add a line-number note before the body of a DO - loop. - * ch-loop.c: #ifdef out creation of new scope for DO loop body. - -Tue Jan 5 17:26:14 1993 Bill Cox (bill@cygnus.com) - - * c-decl.c: correct order of declaration of start_decl params, - for readability. - -Tue Jan 5 15:59:36 1993 Per Bothner (bothner@cygnus.com) - - * ch-grant.c (still_start_module_code), ch-parse.y (procedure): - Move shared code into ... - * ch-decl.c (start_chill_function): ... here. - * ch-decl.c (start_chill_function): Add missing call to - expand_start_bindings. - * ch-decl.c (finish_chill_function): Add missing call to - expand_end_bindings. - -Tue Jan 5 01:00:47 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) - - * Makefile.in: took out the rest of the runtime support - -Mon Jan 4 18:02:06 1993 Bill Cox (bill@cygnus.com) - - * ch-expr.c: make chill_expand_array_assignment not static. - -Mon Jan 4 17:57:48 1993 Per Bothner (bothner@cygnus.com) - - * ch-grant.c, ch-parse.y: Remove all code for explicitly - calling initializer functions. This is not needed, since we - use the same mechanism used for C++ static constructors. - * ch-grant.c (chill_start_module_code): Make sure the - init_name starts with the magic string also used for C++ - initializers. Also, don't embed the file name in the name, - just use the module name. - * ch-grant.c (chill_finish_module_code): Now that the - initializer name follows the standard 'collect' convention, - don't need to call assembler_constructor_alias, but can - use the standard assemble_constructor instead. - * varasm.c (assemble_constructor_alias): Remove no-longer- - needed function. - * ch-parse.y: Move code that is common to the beginning of - all functions to a new macro INIT_ACTION. - Make sure INIT_ACTION is also done for callaction, fixing a bug. - * ch-parse.y (INIT_ACTION): Do chill_start_module_code() - before emit_line_note(), not after. - -Mon Jan 4 11:43:12 1993 Bill Cox (bill@cygnus.com) - - * ch-parse.y: restore requirement for :upper-bound in array decl. - * ch-actions.c: enhance upper, lower, length functions for VARYING. - -Mon Jan 4 09:28:44 1993 Bill Cox (bill@cygnus.com) - - * ch-actions.c: fix NOT of boolean expr. - -Mon Jan 4 08:42:57 1993 Bill Cox (bill@cygnus.com) - - * ch-actions.c: provide range-checking function - * ch-lex.l: better compiler-directive error messages, - allow underscores in exponents - * ch-loop.c: prevent passing NULL ptr to printf - -Sun Jan 3 11:57:13 1993 Bill Cox (bill@cygnus.com) - - * ch-typeck.c: correct & enable array index range-checking - -Sun Jan 3 11:36:39 1993 Bill Cox (bill@cygnus.com) - - * ch-parse.y: define IGNORED_DIRECTIVE - * ch-typeck.c: subtract array's lower domain value, even if - index expression is constant. - -Sat Jan 2 23:05:14 1993 Fred Fish (fnf@cygnus.com) - - * ch-lex.l (convert_float): Fix misspelling in error message. - -Sat Jan 2 16:02:16 1993 Per Bothner (bothner@rtl.cygnus.com) - - * Makefile.in: Took out chill-runtime support. - Chill run times are now in ../chillrt, not ./chillrt.p - -Sat Jan 2 15:04:13 1993 Bill Cox (bill@cygnus.com) - - * ch-hash.h, chill.gperf: cleanup. fewer keywords seen by ch-parse.y. - -Sat Jan 2 13:27:49 1993 Per Bothner (bothner@rtl.cygnus.com) - - * ch-lex.l (check_newline): Use the orginal versions (derived - from the C code, not the simplified, special-case version). - Also, fix that version of check_newline to not call yylex() - recursively. - * ch-lex.l (yy_input): Call check_newline to handle - newlines and check for # directives. - * ch-lex.l (syntax): Don't recognize #-directives; these - are now handled by check_newline. - * ch-actions.c (lang_init): Call the modified version of - check_newline(). Do this at the *after* we've initialized - standard types, so this can be done while lineno is still 0. - -Sat Jan 2 10:57:20 1993 Bill Cox (bill@cygnus.com) - - * ch-hash.h, chill.gperf: add remaining reserved words. - -Sat Jan 2 09:59:55 1993 Bill Cox (bill@cygnus.com) - - * ch-tree.h, ch-parse.y, ch-lex.l: add remaining reserved words, - names for exceptions - -Fri Jan 1 12:30:31 1993 Fred Fish (fnf@cygnus.com) - - * ch-tree.h (JOINER): Define joiner character the same way - C++ defines it. - * ch-grant.c (chill_start_module_code): Use JOINER character - to implement name mangling for the initializer function name. - Algorithm is designed to be simple, distinct from C++ mangled - symbols, and easy to convert to demangled form. - -Thu Dec 31 10:30:51 1992 Bill Cox (bill@rtl.cygnus.com) - - * ch-expr.c: make array assignments work with indirect refs. - * ch-actions.c: prepare for array parameter handling. - * ch-loop.c, ch-parse.y, ch-tree.def, ch-typeck.c: clean up. - -Thu Dec 31 15:29:20 1992 Per Bothner (bothner@rtl.cygnus.com) - - * ch-lex.l (yy_input): Re-write to return more than one - character at a time (execpt when reading seize-files). - Don't increment lineno until we start reading the next line. - This fixes some off-by-one errors in lineno. - -Wed Dec 30 16:15:23 1992 Per Bothner (bothner@rtl.cygnus.com) - - * ch-convert.c: Assume use of new common.c. - * ch-convert.c (convert_to_reference, convert_from_reference): - New routines, to handle loc-identity declared variables and - LOC parameters (both of which are implemented as references). - * ch-lang.c (convert_to_boolean, convert_to_char): Move to - ch-convert.c, where they would seem to belong. - * ch-convert.c (convert): New function, since we no longer - link in c-convert.c. - * ch-expr.c (chill_expand_assignment): Handle by calling - convert() instead of chill_comptypes(). - Also handle the LHS being a reference. - * ch-parse.y: Add a procedure call as an action. - * ch-parse.y (locdec, optlocinit): Move handling of - loc-identity declarations from optlocinit to locdec - - and add working semantics for it. - * ch-parse.y (seizestatement, visibilty_stmt): Simplify. - * ch-parse.y (grantstatement etc): Don't bother making list. - * ch-lex.l: #include <sys/types.h> before <sys/stat.h>. - -Wed Dec 30 16:06:55 1992 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y, ch-expr.c: add support for declaring & assigning - VARYING arrays. - * ch-typeck.c: allow VARYING structures in assign_type_to_expr. - -Tue Dec 29 15:28:48 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: implement expressions of arrays of char, - ( concatenation, relationals ), correct type of code parameters - * ch-expr.c: correct type of code parameters - -Tue Dec 29 11:16:19 1992 Bill Cox (bill@cygnus.com) - - * ch-decl.c: cleanup. - * ch-parse.y: put emit_line_note() calls in lotsa places, - per Fred's request; be sure that statements get counted also. - * ch-lex.l: standardize function headers. - -Tue Dec 29 10:41:56 1992 Fred Fish (fnf@cygnus.com) - - * ch-decl.c (start_chill_function): Always return 1, rather - than a random value. - * ch-lex.l (check_newline): Add a version for chill that - just snarfs the right value for main_input_filename out of - the first line of the input file, without disturbing the - lexer state or requiring it's assistance. - * ch-actions.c (lang_init): Call check_newline, like the - other language frontends, to get main_input_filename set - from first line of input file. - -Mon Dec 28 18:49:01 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y: clean up conflicts. The remaining one is - harmless. - -Mon Dec 28 17:28:40 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-lex.l, ch-actions.c: add stubs for I/O, - clean up some parser conflicts. - -Mon Dec 28 15:00:20 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-lex.l: add keywords and parsing for most of - CHILL I/O - -Sat Dec 26 20:48:23 1992 Fred Fish (fnf@cygnus.com) - - * chillrt/chillrt0.c: Oops, SVR4 doesn't need leading '_' - on build_exceptions. - -Sat Dec 26 11:00:36 1992 Fred Fish (fnf@cygnus.com) - - * ch-grant.c (chill_finish_module_code): Call - assemble_constructor_alias rather than assemble_constructor. - * varasm.c (assemble_constructor_alias): New function, - like assemble_constructor, but also handles the case where - ASM_OUTPUT_CONSTRUCTOR is not defined and GNU ld is not - being used. Emits a symbol table alias name with the correct - prefix for collect to find and add to the __CTOR_LIST__. - * chillrt/chillrt0.c: Build on previous hack that gets - _build_exceptions into the __CTOR_LIST__, to make it work - for both the non GNU-ld case and for the SVR4 case. - -Tue Dec 22 18:24:55 1992 Bill Cox (bill@cygnus.com) - - * ch-loop.c: clean up location enumeration - one more - pass to do. - -Tue Dec 22 16:31:48 1992 Bill Cox (bill@cygnus.com) - - * ch-loop.c: Working version of location enumeration loop - -Tue Dec 22 14:42:14 1992 Bill Cox (bill@cygnus.com) - - * ch-lex.l: readability cleanup - -Mon Dec 21 14:58:39 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, c-decl.c: Add Jukka's Pascal WITH code. - ch-loop.c: rough draft of location enumeration - ch-lex.l, ch-expr.c, ch-decl.c: minor cleanup - ch-actions.c: finish making pred() and succ() work. - -Mon Dec 21 10:04:35 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: allow pred(char) and succ(char). - -Sun Dec 20 16:04:28 1992 Bill Cox (bill@cygnus.com) - - * ch-expr.c, ch-actions.c, ch-parse.y, ch-loop.c, - c-expr.c: make DO WITH work. - -Sun Dec 20 12:22:53 1992 Bill Cox (bill@cygnus.com) - - * ch-loop.c, ch-actions.c, ch-typeck.c: powerset loops - now work - -Sat Dec 19 14:20:23 1992 Per Bothner (bothner@cygnus.com) - - * c-typeck.c (process_init_constructor): Add warning if - there is a duplicate default initializer element. - * ch-typeck.c (chill_give_type_to_expr): New function, - to handle coercion of an expression to context-given type, - Takes care of untyped tuples, and case expressions. - * ch-decl.c (do_decls), ch-typeck.c (chill_expand_return, - chill_expand_result), ch-parse.y <assignaction>: - Use chill_give_type_to_expr(). - * ch-typeck.c (chill_handle_case_label): New parameter list, - to handle the (new) conventions for <case_label>, including - default elements and ranges. - * ch-parse.y <expanded_case_label>, ch-typeck.c - (expand_case_expr): Use new version of chill_handle_case_label. - * ch-decl.c (push_syndecls): Change parameters: Instead of - TREE_LIST representing a compete <synonym definition statement>, - just pass the parts of a single <synonym definition> as 3 - different parameters. Also, use chill_give_type_to_expr(), - to handle untyped tuples in the RHS. - * ch-parse.y <syndeclist, syndef>: Don't bother trying to construct - a tree - just call push_syndecls() on each <synonum_definition> - as we see it. - * ch-parse.y (exprlist_get_single): Remove; no longer needed. - * ch-parse.y: Handle <tuple> without mode name diferently from - <tuple> with mode name. The latter is a <primval> that can be - in most contexts, but if the <mode name> is missing, the <tuple> - is only allowed in certain contexts. Use the new non-terminal - <untyped_expr> to indicate those contexts where untyped tuples - (and case expressions) are valid because the expression gets a - type from its context (such as the RHS of an assignment). - Use chill_give_type_to_expr in those contexts. - -Sat Dec 19 14:01:26 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c, ch-loop.c, Makefile.in: looping stuff. - -Sat Dec 19 10:16:20 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y: clean up warning messages from byacc. bison - still complains thrice. - -Fri Dec 18 12:33:29 1992 Michael Tiemann (tiemann@rtl.cygnus.com) - - * ch-actions.c (maybe_chill_comptypes): Delete unused - function. - (chill_comptypes): Add new parameter ERRSTR. All callers - changed. - (build_chill_binary_op): Fix indentation to match GNU coding - style. - -Fri Dec 18 08:18:13 1992 Bill Cox (bill@rtl.cygnus.com) - - * ch-parse.y, ch-expr.c, ch-actions.c, expr.c: major - cleanup of expression and assignment handling. - -Thu Dec 17 10:16:32 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y: standardize indentation after c-parse.y - -Wed Dec 16 15:22:12 1992 Per Bothner (bothner@cygnus.com) - - * c-typeck.c (process_init_constructor): Add support for - a default initializer element. - * ch-parse.y: Implement default elements for tuples - (as in '(else):' and '(*):' ). - - * ch-parse.y: Previous change to dis-ambiguate case-labels - seems to have allowed getting rid of all of the expr_or_list hair. - * ch-decl.c (do_decls): Undo Tiemann's change to "Handle - initialization of multiple variables by a tuple" - the - idea is bogus. - -Wed Dec 16 11:17:53 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y: complete re-write of DO statement handling. - now operational, except WITH is stubbed out. Improved - syntax error message. - * ch-actions.c: DO support: high_domain_value(), low_domain_value (). - * ch-expr.c: fixes to IN_EXPR handling. - -Tue Dec 15 17:15:13 1992 Jim Wilson (wilson@sphagnum.cygnus.com) - - * ch-grant.c: Add casts to alloca return to avoid compiler warning. - * ch-lex.c: Likewise. - - * Makefile.in (ch-lex.c): Delete incorrect free declaration added - by flex to avoid compiler error. - -Tue Dec 15 08:41:08 1992 Michael Tiemann (tiemann@rtl.cygnus.com) - - * ch-decl.c (do_decls): Handle initialization of multiple - variables by a tuple. - - * ch-decl.c (do_decls,start_chill_function): Make DECL public - if we're doing a GRANT ALL at top level. - - * ch-lang.c (build_range_type): Deal with typecast to CHAR in - range expression. - - * c-typeck.c (digest_init): SET_TYPE is not a scalar type. - BOOLEAN_TYPE and CHAR_TYPE are scalar types. - -Mon Dec 14 14:58:32 1992 Michael Tiemann (tiemann@rtl.cygnus.com) - - * ch-lex.l (get_chill_{linenumber,filename}): New functions. - (convert_number): Use LONG_TYPE_NODE instead of INTEGER_TYPE_NODE. - -Mon Dec 14 13:36:44 1992 Bill Cox (bill@cygnus.com) - - * expr.c: install and test newer Pascal IN_EXPR code, - but don't activate it - it's very verbose. - -Mon Dec 14 00:22:49 1992 Fred Fish (fnf@cygnus.com) - - * Makefile.in (LANGUAGES): Add chill. - * Makefile.in (CHILL_INSTALL_NAME, CHILL_CROSS_NAME): - New macros for chill native and cross installation names. - * Makefile.in (COMPILERS): Add cc1chill. - * Makefile.in (CHILL_OBJS): New macro, chill objects. - * Makefile.in (CHILL_TREE_H): New macro, chill headers. - * Makefile.in (CHILL, chill, cc1chill, chill-runtime, libchill.a, - sublibchill.a, ch-parse.o, ch-parse.c ch-*.o, install-libchill, - install-librmt): New targets. - * Makefile.in (install-native): Add install-libchill, - install-librmt. - -Sun Dec 13 15:21:06 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c, ch-expr.c: Fix the pop-count in library calls. - -Sun Dec 13 14:07:32 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: fix unary operations, modulus ops, - (discovered after extending regression tests). - -Sun Dec 13 12:16:32 1992 Bill Cox (bill@cygnus.com) - - * resync with Michael and Wilfried - -Sun Dec 13 09:11:25 1992 Michael Tiemann (tiemann@rtl.cygnus.com) - - * ch-parse.y (output_constant): Fixed some whitespace - problems. - * ch-tree.h: Add declarations for new chill functions that - have been implemented but not (yet) declared. - -Sat Dec 12 00:17:23 1992 Per Bothner (bothner@cygnus.com) - - * c-typeck.c (process_init_constructor): Warn about duplicate - labels for labelled initializer elements. - * ch-lex.l (various operator tokens, such as "+"): Don't - set yylval.code to a TREE_CODE; this is better done in parser. - * ch-parse.y: Some work with case labels and tuples. - Get literal range as tuple (and case) labels working. - Fix some problems introduced by recent grammar overhaul. - -Fri Dec 11 13:28:48 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c, ch-parse.y ch-tree.h ch-expr.c, ch-typeck.c: - got long, real expressions working. We can also call a func- - tion and use its return value. - -Thu Dec 10 14:45:17 1992 Per Bothner (bothner@cygnus.com) - - * ch-parse.y: Major change to remove or at least identify - parser ambiguities. One result: We now allow actions that - start with '(', as required by teh Blue Book. This does break - some things; look for FIXME for things that need work. - * ch-typeck.c (chill_expand_case_expr): We need an extra - level of looping to (in the future) support <case label - specification>s with more than one <case label list>. - -Thu Dec 10 09:21:41 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c, ch-expr.c: Implement string assignments - and relationals. - -Thu Dec 10 07:17:35 1992 Bill Cox (bill@cygnus.com) - - * ch-decl.c, ch-typeck.c: rest of previous commit. - -Wed Dec 9 18:26:29 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-actions.c, ch-expr.c: redo type checking. - regression test and fix bit arrays and set ops. - -Mon Dec 7 14:57:46 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: implement crude relationals between - non-exotic operands, such as integers. - -Mon Dec 7 10:42:35 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: implement relational, logic operations - on arrays of BOOLs. - -Mon Dec 7 08:55:20 1992 Michael Tiemann (tiemann@rtl.cygnus.com) - - * ch-actions.c (lang_init): Set LINENO to 1 at beginning to - indicate we are done with initialization. - - * ch-decl.c (do_decls): Set TREE_PUBLIC if we are doing a - `grant all'. - (start_chill_function): Ditto. - - * ch-lex.c (convert_bitstring): Set TREE_CONSTANT. - (compiler_directive): Don't confuse compiler directives with - equality comparison operators. - - * ch-parse.y: Clear CURRENT_LOCNAMELIST after calling do_decls. - -Sun Dec 6 13:12:32 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: repair set inequality code. - -Sun Dec 6 11:15:59 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-actions.c, ch-expr.c: Implement set-oriented - relational expressions, including (<, <=, =, /=, >, >=, IN). - -Fri Dec 4 13:54:58 1992 Brendan Kehoe (brendan@lisa.cygnus.com) - - * tree.def: Move CARD_EXPR and SET_LE_EXPR back down with the other - Pascal-required ones, since C++ no longer needs them. When - Chill's public, a comment can be added to the effect that - SET_LE_EXPR is also used by Chill. - -Fri Dec 4 12:05:01 1992 Bill Cox (bill@cygnus.com) - - * Restore CARD_EXPR and SET_LE_EXPR to tree.def. - -Fri Dec 4 10:23:10 1992 Bill Cox (bill@cygnus.com) - * Get *.def and *.c in sync. - -Fri Dec 4 06:48:41 1992 Fred Fish (fnf@cygnus.com) - - * ch-actions.c (lang_init): Change types "long" and - "ulong" from 16 bits to 32. - * dwarfout.c (fundamental_type_code): Use FT_signed_char - for type "byte" and FT_unsigned_char for type "ubyte". - -Thu Dec 3 15:13:24 1992 Bill Cox (bill@cygnus.com) - * ch-actions.c, ch-tree.def, ch-parse.y: preparation - for powerset expressions. - -Tue Dec 2 17:02:30 1992 Bill Cox (bill@cygnus.com) - * ch-actions.c: sketch code for exceptions generated - by builtin routines. - -Tue Dec 2 12:49:50 1992 Bill Cox (bill@cygnus.com) - * ch-actions.c, ch-parse.y: add support for lower() - upper() builtin functions. - -Wed Dec 2 12:03:30 1992 Fred Fish (fnf@cygnus.com) - - * Makefile.in (chillrt0.o, install-chillrt0): Remove. - * chill (library): Remove chillrt0.o. - * chillrt/Makefile: Remove maintenance of chillrt0.o as a - separate file. Now gets put in libchill.a. - -Tue Dec 2 10:100:20 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-actions.c: add support for num() - builtin function. - -Wed Dec 2 09:52:06 1992 Michael Tiemann (tiemann@rtl.cygnus.com) - - * ch-decl.c (fixup_unknown_type): New function. - (push_newmode,push_synmode): Call `fixup_unknown_type' when we - see a declaration that uses `unknown_type_node'. FIXME. - - * ch-grant.c (decode_constant): New function. - (decode_decl): Call `decode_constant' for CONST_DECLs. - - * ch-lex.l (char action): Use ridpointers instead of - lookup_name to get "char"'s declaration. - - * ch-parse.y: Call `build_lang_decl' instead of `build_decl' - when we need to build a TYPE_DECL. - -Tue Dec 2 09:44:05 1992 Bill Cox (bill@cygnus.com) - - * ch-typeck.c: clean up a gcc warning with a forward - declaration of build_string_type. - -Tue Dec 1 16:51:05 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: completely remove those builtin calls - that are duplicated in c-decl.c - -Tue Dec 1 16:38:51 1992 Fred Fish (fnf@cygnus.com) - - * ch-actions.c (lang_init): Ifdef out initializations for - __builtin_abs and __builtin_fabs, since they are duplicates of - initializations in c-decl.c, and trigger spurious warnings. - -Tue Dec 1 16:35:18 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y: make size() work with a typename argument. - -Tue Dec 1 16:15:56 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-lex.l, ch-actions.c: add builtin - functions min, max, card. - -Tue Dec 1 12:35:56 1992 Bill Cox (bill@cygnus.com) - - * ch-lex.l: fix char-type - -Tue Dec 1 11:10:56 1992 Bill Cox (bill@cygnus.com) - - * ch-parse.y, ch-actions: added parsing and processing - for upper, lower, and length built-ins. - -Tue Dec 1 09:40:49 1992 Fred Fish (fnf@cygnus.com) - - * dwarf.h (LANG_CHILL): Add as GNU extension. - * dwarfout.c (output_compile_unit_die): Test language_string and - set LANG_CHILL if appropriate. - * ch-parse.y (language_string): New for chill. - * chillrt: Renamed directory chill to chillrt. - * chill: Renamed chillsh to chill. - * Makefile.in: Adjust for renamings. - * chillrt/Makefile: Adjust for directory renaming. - -Mon Nov 30 17:35:33 1992 Fred Fish (fnf@cygnus.com) - - * chillsh: New script frontend (ala g++), installed as "chill". - Can't be called "chill.sh" because make tries to cat it into the - "chill" directory. Can't be called just "chill" cause that's - already there as a directory. - * Makefile.in: Add rules to install chillsh as "chill". - * chill/libchill.c: Temporarily ifdef out stuff that wants - to conflict with i486/SVR4 runtime or wants to pull in librmt.a, - which itself causes linkage to fail. - -Mon Nov 30 16:28:19 1992 Bill Cox (bill@cygnus.com) - - * ch-lex.l: added keywords for TRUNC, ROUND, FLOAT, LFLOAT - conversion routines. - * ch-parse.y: added %tokens for TRUNC, ROUND, FLOAT, LFLOAT. - Added production for SIZE(expr). - * ch-actions.c: Add semantic routine chill_sizeof (). - -Mon Nov 30 16:20:40 1992 Per Bothner (bothner@cygnus.com) - - * ch-lex.l, ch-parse.y: Translate token PFEIL into English ARROW. - * ch-parse.y (op6): Remove handling of string repetition operator, - until we can figure out a way to parse it correctly. - * ch-parse.y (optmodename): New non-terminal. - * ch-parse.y (tuple): Merge the two variants using optmodename. - * ch-parse.y (location): Add semantic actions for - dereferencing operator ->. - -Mon Nov 30 08:01:29 1992 Bill Cox (bill@cygnus.com) - - * ch-actions.c: removed compile warning, better code for abs. - - * ch-parse.y: add productions for builtin functions succ, pred, - abs, and size. Add %tokens also. Sort %tokens alphabetically. - - * ch-lex.l: add parsing for builtin function names, such as abs, - pred, succ, etc. Put flex -a option into Makefile.in, so we can - clean up the lexer soon. - -Tue Nov 24 14:18:48 1992 Per Bothner (bothner@rtl.cygnus.com) - - * ch-typeck.c (chill_handle_case_label, chill_handle_case_default): - New functions, for code common to CASE actions and expressions. - * chill.y: Replace some code by calls to chill_handle_case_label - and chill_handle_case_default. - * ch-typeck.c (chill_expand_case_expr): Add semantics. - - * tree.c: Change doing_chill_thang from extern to common. - -Mon Nov 23 18:34:22 1992 Per Bothner (bothner@rtl.cygnus.com) - - * ch-tree.def: New CASE_EXPR type, for case expressions. - * ch-expr.c (chill_expand_expr): Hook for CASE_EXPR. - * ch-typeck.c (chill_expand_case_expr): New function. - Placeholder to implement case expressions. - * ch-typeck.c (chill_expand_result, chill_expand_return): - Handle mode-unspecified tuples and case expressions in - the context of RETURN and RESULT actions. - * chill.y (assignaction): Handle case expressions in the - context of the RHS of an assignment action. - * chill.y (caseaction): Remove spurious duplicate OF in grammar. - * chill.y: Handle labeled structure tuples. - * chill.y: New rules to parse CASE expressions. - * tree.c (build_function_types): Allow Chill functions - to return arrays and functions. - -Wed Nov 18 13:50:28 1992 Per Bothner (bothner@rtl.cygnus.com) - - * ch-typeck.c (chill_expand_tuple): New function. Expand a - tuple (constructor) given an expected (context) type. - * chill.y: Implement 'LHS := TUPLE' using expand_chill_tuple, - using the mode of the LHS and the expected type of the TUPLE. - * chill.y: Implement initialization. - * chill.y: Fix some syntax bugs (forbidlist must be surrounded - by parentheses), and remove or note ambiguities. - * chill.y: Started converting layout style to be like c-parse.in. - * chill.y: Implement IF expressions. - * chill.y: Added syntax rules for tuples. Labelled and unlabelled - array tuples should now work (in some contexts). - * ch-actions.c: Initialize doing_chill_thang to 1. - * ch-decl.c (do_decls): Set DECL_INITIAL if there is an - initializer, to make pushdecl and finish_decl work. - * c-decl.c (convert_for_assignment): If Chill, don't convert - function and arrays into pointers. (Maybe functions should - still be converted?) - * c-typeck.c (grokdeclarator): Allow functions in Chill - to return arrays and functions. - -Mon Nov 16 15:40:47 1992 Per Bothner (bothner@rtl.cygnus.com) - - * chill.y (exprlist_get_single): New function, used when - parsing tuples. - * chill.y: Re-did parsing of tuples to remove ambiguities. - This was a bitch. - -Tue Nov 10 16:30:55 1992 Per Bothner (bothner@rtl.cygnus.com) - - * ch-typeck.c (chill_expand_result); Set TREE_SIDE_EFEFCTS - flags on assignment to result. - * ch-typeck.c (build_chill_array_ref): Subtract lower - bound of domain if non-zero. Preliminary hook for range checking. - * ch-tree.h, chill.l: Combine variables range_check and - range_check_disabled into global variable range_checking. - * ch-tree.h: Better definitions of CH_CLASS_IS_VALUE - CH_CLASS_IS_DERIVED. - diff --git a/gcc/ch/Make-lang.in b/gcc/ch/Make-lang.in deleted file mode 100644 index 6c8154f003e..00000000000 --- a/gcc/ch/Make-lang.in +++ /dev/null @@ -1,186 +0,0 @@ -# Top level Makefile fragment for GNU CHILL. -# Copyright (C) 1994, 1998, 2000 Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. */ - -# This file provides the language dependent support in the main Makefile. -# Each language makefile fragment must provide the following targets: -# -# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap, -# foo.info, foo.dvi, -# foo.install-normal, foo.install-common, foo.install-info, foo.install-man, -# foo.uninstall, -# foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean, -# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 -# -# where `foo' is the name of the language. -# -# It should also provide rules for: -# -# - making any compiler driver (eg: g++) -# - the compiler proper (eg: cc1plus) -# - define the names for selecting the language in LANGUAGES. -# -# define version of GNUCHILL compiler. Note: maybe we have to change the -# mechanism -GNUCHILL_VERSION = 1.5.2 - -# Actual names to use when installing a native compiler. -# (Cygnus configure overrides these when using -program-transform-name). -CHILL_INSTALL_NAME = chill - -# Actual names to use when installing a cross-compiler. -# (Cygnus configure overrides these when using -program-transform-name). -CHILL_CROSS_NAME = $(target_alias)-chill - -CHILL_SRCS = $(srcdir)/ch/actions.c $(srcdir)/ch/convert.c \ - $(srcdir)/ch/decl.c $(srcdir)/ch/except.c $(srcdir)/ch/expr.c \ - $(srcdir)/ch/grant.c $(srcdir)/ch/inout.c $(srcdir)/ch/lang.c \ - $(srcdir)/ch/lex.c $(srcdir)/ch/loop.c \ - $(srcdir)/ch/parse.c $(srcdir)/ch/satisfy.c \ - $(srcdir)/ch/tasking.c $(srcdir)/ch/timing.c $(srcdir)/ch/tree.c \ - $(srcdir)/ch/typeck.c - -# Extra flags to pass to recursive makes. -CHILL_FLAGS_TO_PASS = \ - "CHILLFLAGS=$(CHILLFLAGS)" \ - "CHILL_FOR_TARGET=$(CHILL_FOR_TARGET)" \ - "CHILL_LIB=$(CHILL_LIB)" \ - "GNUCHILL_VERSION=$(GNUCHILL_VERSION)" -# -# Define the names for selecting languages in LANGUAGES. -CHILL: chill cc1chill$(exeext) - -# handle startfile in chill script and build script to install -chill: $(srcdir)/ch/chill.in Makefile - thisdir=`pwd` ; \ - sed -e "s:startfile=chillrt0:startfile=$${thisdir}/ch/runtime/chillrt0.o:" \ - -e "s:libpath=chillrt:libpath=-L$${thisdir}/ch/runtime/:" \ - -e "s:whatgcc=gcc:whatgcc=\"$${thisdir}/xgcc$(exeext) -B$${thisdir}/\":" \ - -e "s:gnuchill_version=unknown:gnuchill_version=$(GNUCHILL_VERSION):" \ - -e "s:gnuchill_script_flags=:gnuchill_script_flags=\"$(GNUCHILL_SCRIPT_FLAGS)\":" $(srcdir)/ch/chill.in > chill ; \ - chmod a+x chill ; \ - if [ -f ../gcc-cross$(exeext) ]; then \ - whatgcc=$(GCC_CROSS_NAME) ; \ - else \ - whatgcc=$(GCC_INSTALL_NAME) ; \ - fi; \ - sed -e "s:startfile=chillrt0:startfile=$(libsubdir)/chillrt0.o:" \ - -e "s:whatgcc=gcc:whatgcc=$(bindir)/$${whatgcc}:" \ - -e "s:gnuchill_version=unknown:gnuchill_version=$(GNUCHILL_VERSION):" \ - -e "s:libpath=chillrt:libpath=:" \ - -e "s:gnuchill_script_flags=:gnuchill_script_flags=\"$(GNUCHILL_SCRIPT_FLAGS)\":" $(srcdir)/ch/chill.in > chill.install ; \ - chmod a+x chill.install - -# Don't depend on cc1chill$(exeext), because chill-cross is always built for cross, -# and thus a cc1chill$(exeext) dependence would force cc1chill$(exeext) to always be built. -# Note that gcc-cross and g++-cross do not have cc1 or cc1plus dependencies. -chill-cross: $(srcdir)/ch/chill.in - touch $@ - -cc1chill$(exeext): $(P) $(CHILL_SRCS) $(LIBDEPS) $(BACKEND) \ - insn-config.h insn-flags.h insn-attr.h insn-codes.h \ - c-typeck.o c-aux-info.o c-common.o \ - ggc-callbacks.o - cd ch; $(MAKE) $(LANG_FLAGS_TO_PASS) $(CHILL_FLAGS_TO_PASS) ../cc1chill$(exeext) - -# -# Build hooks: - -CHILL.all.build: chill -CHILL.all.cross: chill-cross -CHILL.start.encap: chill -CHILL.rest.encap: -CHILL.dvi: chill.dvi - -CHILL.info: $(srcdir)/ch/chill.info - -$(srcdir)/ch/chill.info: $(srcdir)/ch/chill.texi - cd $(srcdir)/ch && $(MAKEINFO) -o chill.info chill.texi - -chill.dvi: $(srcdir)/ch/chill.texi $(srcdir)/extend.texi $(srcdir)/invoke.texi $(srcdir)/md.texi $(srcdir)/rtl.texi $(srcdir)/tm.texi - cd ch ; \ - TEXINPUTS=${texidir}:$(srcdir):$$TEXINPUTS tex chill.texi ; \ - texindex chill.?? ; \ - TEXINPUTS=${texidir}:$(srcdir):$$TEXINPUTS tex chill.texi -# FIXME: Not sure languages should do this. - cp ch/chill.dvi chill.dvi -# -# Install hooks: -# cc1chill is installed elsewhere as part of $(COMPILERS). - -CHILL.install-normal: - -# Install the driver program -CHILL.install-common: - -if [ -f cc1chill$(exeext) ] ; then \ - if [ -f chill.install ] ; then \ - if [ -f gcc-cross$(exeext) ]; then \ - rm -f $(bindir)/$(CHILL_CROSS_NAME); \ - $(INSTALL_SCRIPT) chill.install $(bindir)/$(CHILL_CROSS_NAME); \ - chmod a+x $(bindir)/$(CHILL_CROSS_NAME); \ - else \ - rm -f $(bindir)/$(CHILL_INSTALL_NAME); \ - $(INSTALL_SCRIPT) chill.install $(bindir)/$(CHILL_INSTALL_NAME); \ - chmod a+x $(bindir)/$(CHILL_INSTALL_NAME); \ - fi ; \ - fi ; \ - fi - -# Don't delete $(infodir)/ch.info* unless there's actually new -# docs to install (in case LANGUAGES didn't contain chill earlier). -CHILL.install-info: - -cd $(srcdir)/ch; for i in chill.info*; do \ - rm -f $(infodir)/chill.info*; \ - realfile=`echo $$i | sed -e 's|.*/\([^/]*\)$$|\1|'`; \ - $(INSTALL_DATA) $$i $(infodir)/$$realfile; \ - done - -CHILL.install-man: - -CHILL.uninstall: - -rm -rf $(bindir)/$(CHILL_INSTALL_NAME) - -rm -rf $(bindir)/$(CHILL_CROSS_NAME) -# -# Clean hooks: -# A lot of the ancillary files are deleted by the main makefile. -# We just have to delete files specific to us. - -CHILL.mostlyclean: - -rm -f chill.install ch/*.o ch/ch-version.c -CHILL.clean: -CHILL.distclean: - -rm -f ch/config.status ch/Makefile -CHILL.extraclean: -CHILL.maintainer-clean: - -rm -f ch/TAGS - -rm -f $(srcdir)/ch/chill.info* ch/chill.dvi ch/chill.??s ch/chill.*aux -# Delete locally created file. - -rm -f ch/hash.h -# -# Stage hooks: -# The main makefile has already created stage?/ch. - -CHILL.stage1: stage1-start - -mv ch/*.o stage1/ch -CHILL.stage2: stage2-start - -mv ch/*.o stage2/ch -CHILL.stage3: stage3-start - -mv ch/*.o stage3/ch -CHILL.stage4: stage4-start - -mv ch/*.o stage4/ch diff --git a/gcc/ch/Makefile.in b/gcc/ch/Makefile.in deleted file mode 100644 index a15c1ce7506..00000000000 --- a/gcc/ch/Makefile.in +++ /dev/null @@ -1,330 +0,0 @@ -# Makefile for GNU CHILL compiler. -# Copyright (C) 1987, 1988, 1990, 1991, 1992, 1993, 1994, 1998, -# 1999, 2000, 2001 Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. */ - -# The makefile built from this file lives in the language subdirectory. -# It's purpose is to provide support for: -# -# 1) recursion where necessary, and only then (building .o's), and -# 2) building and debugging cc1 from the language subdirectory, and -# 3) nothing else. -# -# The parent makefile handles all other chores, with help from the -# language makefile fragment, of course. -# -# The targets for external use are: -# all, TAGS, ???mostlyclean, ???clean. - -# Suppress smart makes who think they know how to automake Yacc files -.y.c: - - -# Variables that exist for you to override. -# See below for how to change them for certain systems. - -# Various ways of specifying flags for compilations: -# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. -# BOOT_CFLAGS is the value of CFLAGS to pass -# to the stage2 and stage3 compilations -# XCFLAGS is used for most compilations but not when using the GCC just built. -XCFLAGS = -CFLAGS = -g -BOOT_CFLAGS = -O $(CFLAGS) -# These exists to be overridden by the x-* and t-* files, respectively. -X_CFLAGS = -T_CFLAGS = - -X_CPPFLAGS = -T_CPPFLAGS = - -CC = @CC@ -AR = ar -AR_FLAGS = rc -SHELL = /bin/sh -MAKEINFO = makeinfo -TEXI2DVI = texi2dvi - -# Define this as & to perform parallel make on a Sequent. -# Note that this has some bugs, and it seems currently necessary -# to compile all the gen* files first by hand to avoid erroneous results. -P = - -# This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. -# It omits XCFLAGS, and specifies -B./. -# It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. -GCC_CFLAGS=$(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) - -# Tools to use when building a cross-compiler. -# These are used because `configure' appends `cross-make' -# to the makefile when making a cross-compiler. - -# We don't use cross-make. Instead we use the tools -# from the build tree, if they are available. -# program_transform_name and objdir are set by configure.in. -program_transform_name = -objdir = . - -target=@target@ -xmake_file=@dep_host_xmake_file@ -tmake_file=@dep_tmake_file@ -#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` -#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` - -# Directory where sources are, from where we are. -srcdir = @srcdir@ -VPATH = @srcdir@ - -# Directory where texinfo.tex lives -# texidir = $(srcdir)/../../texinfo - -# Top build directory, relative to here. -top_builddir = .. - -# Internationalization library. -INTLLIBS = @INTLLIBS@ - -# Additional system libraries to link with. -CLIB= - -# Choose the real default target. -ALL=all - -# End of variables for you to override. - -# Definition of `all' is here so that new rules inserted by sed -# do not specify the default target. -all: all.indirect - -# This tells GNU Make version 3 not to put all variables in the environment. -.NOEXPORT: - -# sed inserts variable overrides after the following line. -####target overrides -@target_overrides@ -####host overrides -@host_overrides@ -####cross overrides -@cross_defines@ -@cross_overrides@ -####build overrides -@build_overrides@ -####site overrides -# @site_overrides@ -# -# Now figure out from those variables how to compile and link. - -all.indirect: Makefile ../chill ../cc1chill$(exeext) - -# IN_GCC tells obstack.h that we are using gcc's <stddef.h> file. -INTERNAL_CFLAGS = $(CROSS) -DIN_GCC @extra_c_flags@ - -# This is the variable actually used when we compile. -ALL_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) $(XCFLAGS) - -# Likewise. -ALL_CPPFLAGS = $(CPPFLAGS) $(X_CPPFLAGS) $(T_CPPFLAGS) - -# This is where we get libiberty.a from. -LIBIBERTY = ../../libiberty/libiberty.a - -# How to link with both our special library facilities -# and the system's installed libraries. -LIBS = $(LIBIBERTY) $(CLIB) $(INTLLIBS) -LIBDEPS = $(INTLLIBS) $(LIBIBERTY) - -# Specify the directories to be searched for header files. -# Both . and srcdir are used, in that order, -# so that tm.h and config.h will be found in the compilation -# subdirectory rather than in the source directory. -INCLUDES = -I. -I.. -I$(srcdir) -I$(srcdir)/.. -I$(srcdir)/../config -I$(srcdir)/../../include - -# Flags to pass to recursive makes. -# ??? $(CC) may need some work to handle stage[123]. -# ??? The choices here will need some experimenting with. -FLAGS_TO_PASS = \ - "AR_FLAGS=$(AR_FLAGS)" \ - "AR_FOR_TARGET=$(AR_FOR_TARGET)" \ - "BISON=$(BISON)" \ - "BISONFLAGS=$(BISONFLAGS)" \ - "CC=$(CC)" \ - "CFLAGS=$(CFLAGS)" \ - "GCC_FOR_TARGET=$(CC_FOR_TARGET)" \ - "LDFLAGS=$(LDFLAGS)" \ - "LEX=$(LEX)" \ - "LEXFLAGS=$(LEXFLAGS)" \ - "MAKEINFO=$(MAKEINFO)" \ - "MAKEINFOFLAGS=$(MAKEINFOFLAGS)" \ - "RANLIB_FOR_TARGET=$(RANLIB_FOR_TARGET)" \ - "RANLIB_TEST_FOR_TARGET=$(RANLIB_TEST_FOR_TARGET)" \ - "SHELL=$(SHELL)" \ - "exec_prefix=$(exec_prefix)" \ - "prefix=$(prefix)" \ - "tooldir=$(tooldir)" \ - "bindir=$(bindir)" \ - "libsubdir=$(libsubdir)" - -# Always use -I$(srcdir)/config when compiling. -.c.o: - $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< - -# This tells GNU make version 3 not to export all the variables -# defined in this file into the environment. -.NOEXPORT: -# -# Lists of files for various purposes. - -# Language-specific object files for CHILL - -CHILL_OBJS = parse.o actions.o except.o grant.o lang.o \ - tree.o lex.o decl.o typeck.o convert.o expr.o loop.o \ - tasking.o timing.o inout.o satisfy.o ch-version.o \ - ../ggc-callbacks.o - -BACKEND = ../toplev.o ../libbackend.a - -../cc1chill$(exeext): $(P) $(CHILL_OBJS) $(BACKEND) $(LIBDEPS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(CHILL_OBJS) \ - $(BACKEND) $(LIBS) - -# This executable is used in the CHILL regression -# test script -utils/printf : $(srcdir)/utils/printf.c - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $< - -# -# This is the top-level trigger for a CHILL regression test. -# It also builds those tools needed for CHILL regression testing. -# -check: ../cc1chill$(exeext) utils/printf - cd ..; $(MAKE) $(FLAGS_TO_PASS) xgcc gcov cpp cc1 ld - $(srcdir)/regression.sh -d -p - -clean-tests: - cd testsuite/execute; $(MAKE) clean - cd testsuite/execute/oe; $(MAKE) clean - cd testsuite/compile/elektra; $(MAKE) clean - cd testsuite/compile/votrics; $(MAKE) clean - cd testsuite/compile; $(MAKE) clean - cd testsuite/noncompile; $(MAKE) clean - cd testsuite/examples; $(MAKE) clean - -mostlyclean: - test -d testsuite && $(MAKE) clean-tests - rm -f *.o - -clean: mostlyclean - -# -Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure - cd ..; $(SHELL) config.status - -native: config.status ../cc1chill$(exeext) ../chill -# -# Compiling object files from source files. - -# Note that dependencies on obstack.h are not written -# because that file is not part of GCC. - -# CHILL language specific files. - -EXPR_H = $(srcdir)/../expr.h ../insn-codes.h -RTL_H = $(srcdir)/../rtl.h $(srcdir)/../rtl.def \ - $(srcdir)/../machmode.h $(srcdir)/../machmode.def -TREE_H = $(srcdir)/../tree.h $(srcdir)/../real.h $(srcdir)/../tree.def \ - $(srcdir)/../machmode.h $(srcdir)/../machmode.def -CHILL_TREE_H = $(TREE_H) ch-tree.h ch-tree.def - -# hash.h really depends on $(srcdir)/gperf. -# But this would screw things for people that don't have gperf, -# if gperf got touched, say. -# Thus you have to remove hash.h to force it to be re-made. -# Note: CHILL requires two sets of keywords, one all uppercase and -# one all lowercase. The hash table ends up with both sets in it. -$(srcdir)/hash.h: - sed -e '1,/^%%/d' < $(srcdir)/gperf | \ - sed '/^[^a-zA-Z]/d' | tr "[a-z]" "[A-Z]" > gperf.tmp2 - cat $(srcdir)/gperf gperf.tmp2 > gperf.tmp - gperf -L C -F ', 0, 0, 0' -D -E -S1 -p -j1 -i 1 -g -o -t -k'*' \ - gperf.tmp > $(srcdir)/hash.h || ( \ - echo "Please update your 'gperf' from ftp://ftp.gnu.org/pub/gnu/gperf/" >&2 ; \ - exit 1 ) - $(RM) gperf.tmp gperf.tmp2 - -actions.o : actions.c $(CONFIG_H) $(CHILL_TREE_H) actions.h $(RTL_H) \ - lex.h $(srcdir)/../flags.h $(srcdir)/../input.h \ - $(EXPR_H) $(srcdir)/../system.h $(srcdir)/../toplev.h -convert.o : convert.c $(CONFIG_H) $(CHILL_TREE_H) $(srcdir)/../flags.h \ - $(srcdir)/../tree.h $(srcdir)/../system.h $(srcdir)/../toplev.h \ - $(srcdir)/../convert.h -decl.o : decl.c $(CONFIG_H) $(CHILL_TREE_H) $(srcdir)/../flags.h lex.h \ - $(srcdir)/../system.h $(srcdir)/../toplev.h -except.o : except.c $(CONFIG_H) $(srcdir)/../tree.h $(RTL_H) $(CHILL_TREE_H) \ - $(srcdir)/../system.h $(srcdir)/../toplev.h -expr.o : expr.c $(CONFIG_H) $(RTL_H) $(CHILL_TREE_H) $(srcdir)/../flags.h \ - $(EXPR_H) $(srcdir)/../tree.h lex.h $(srcdir)/../system.h \ - $(srcdir)/../toplev.h -grant.o: grant.c $(CONFIG_H) $(CHILL_TREE_H) $(RTL_H) $(srcdir)/../flags.h \ - $(srcdir)/../input.h lex.h actions.h $(srcdir)/../system.h \ - $(srcdir)/../toplev.h $(srcdir)/../output.h -inout.o : inout.c $(CONFIG_H) $(CHILL_TREE_H) $(srcdir)/../flags.h \ - $(srcdir)/../input.h $(srcdir)/../system.h $(srcdir)/../toplev.h -lang.o : lang.c $(CONFIG_H) $(CHILL_TREE_H) $(srcdir)/../input.h lex.h \ - $(srcdir)/../system.h $(srcdir)/../toplev.h $(EXPR_H) $(RTL_H) -lex.o : lex.c $(CONFIG_H) $(CHILL_TREE_H) $(RTL_H) $(srcdir)/../flags.h \ - $(srcdir)/../input.h $(srcdir)/parse.h $(srcdir)/../system.h \ - $(srcdir)/../toplev.h lex.h $(srcdir)/../dwarfout.h hash.h -loop.o : loop.c $(CONFIG_H) $(RTL_H) $(CHILL_TREE_H) lex.h \ - $(srcdir)/../flags.h $(srcdir)/../input.h \ - $(srcdir)/../tree.h $(srcdir)/../system.h $(srcdir)/../toplev.h -parse.o : parse.c $(CONFIG_H) $(CHILL_TREE_H) parse.h \ - lex.h actions.h tasking.h $(srcdir)/../system.h $(srcdir)/../toplev.h -satisfy.o : satisfy.c $(CONFIG_H) $(CHILL_TREE_H) $(srcdir)/../tree.h \ - $(srcdir)/../flags.h lex.h $(srcdir)/../system.h $(srcdir)/../toplev.h -timing.o : timing.c $(CONFIG_H) $(CHILL_TREE_H) $(RTL_H) $(srcdir)/../flags.h \ - $(srcdir)/../input.h lex.h $(srcdir)/../system.h $(srcdir)/../toplev.h - -tasking.o : tasking.c $(CONFIG_H) $(CHILL_TREE_H) $(RTL_H) \ - $(srcdir)/../flags.h $(srcdir)/../input.h \ - lex.h $(srcdir)/../system.h $(srcdir)/../toplev.h -tree.o : tree.c $(CONFIG_H) $(CHILL_TREE_H) $(srcdir)/../system.h \ - $(srcdir)/../toplev.h -typeck.o : typeck.c $(CONFIG_H) $(CHILL_TREE_H) ../insn-codes.h \ - $(srcdir)/../expr.h ../insn-codes.h $(srcdir)/../flags.h lex.h \ - $(srcdir)/../system.h $(srcdir)/../toplev.h $(srcdir)/../output.h -ch-version.o : ch-version.c -ch-version.c : Makefile - echo 'const char * const gnuchill_version = "$(GNUCHILL_VERSION)";' > $@ - -## This is ugly, but I don't want GNU make to put these variables in -## the environment. Older makes will see this as a set of targets -## with no dependencies and no actions. -unexport CHILLFLAGS CHILL_LIB CHILL_FOR_TARGET : - -# -# These exist for maintenance purposes. - -# Update the tags table. -TAGS: force - cd $(srcdir); \ - etags *.y *.h *.c *.l ../*.h ../*.c; \ - -.PHONY: TAGS - -force: diff --git a/gcc/ch/README b/gcc/ch/README deleted file mode 100644 index ef835446604..00000000000 --- a/gcc/ch/README +++ /dev/null @@ -1,43 +0,0 @@ -This directory contains the GNU front-end for the Chill language, -contributed by Cygnus Solutions. - -Chill is the "CCITT High-Level Language", where CCITT is the old -name for what is now ITU, the International Telecommunications Union. -It is is language in the Modula2 family, and targets many of the -same applications as Ada (especially large embedded systems). -Chill was never used much in the United States, but is still -being used in Europe, Brazil, Korea, and other places. - -Chill has been standardized by a series of reports/standards. -The GNU implementation mostly follows the 1988 version of -the language, with some backwards compatibility options for -the 1984 version, and some other extensions. However, it -does not implement all of the features of any standard. -The most recent standard is Z.200 (11/93), available from -http://www.itu.int/itudoc/itu-t/rec/z.html. - -The GNU Chill implementation is not being actively developed. -Cygnus has one customer we are maintaining Chill for, -but we are not planning on putting major work into Chill. -This Net release is for educational purposes (as an example -of a different Gcc front-end), and for those who find it useful. -It is an unsupported hacker release. Bug reports without -patches are likely to get ignored. Questions may get answered or -ignored depending on our mood! If you want to try your luck, -you can send a note to David Brolley <brolley@cygnus.com> or -Per Bothner <bothner@cygnus.com>. - -One known problem is that we only support native builds of GNU Chill. -If you need a cross-compiler, you will find various problems, -including the directory structure, and the setjmp-based exception -handling mechanism. - -The Chill run-time system is in the runtime sub-directory. -Notice rts.c contains a poor main's implementation of Chill -"processes" (threads). It is not added to libchill.a. -We only use it for testing. (Our customer uses a different -implementation for production work.) - -The GNU Chill implementation was primarily written by -Per Bothner, along with Bill Cox, Wilfried Moser, Michael -Tiemann, and David Brolley. diff --git a/gcc/ch/actions.c b/gcc/ch/actions.c deleted file mode 100644 index 09c8a5a23f7..00000000000 --- a/gcc/ch/actions.c +++ /dev/null @@ -1,1836 +0,0 @@ -/* Implement actions for CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - Free Software Foundation, Inc. - Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "rtl.h" -#include "expr.h" -#include "ch-tree.h" -#include "lex.h" -#include "flags.h" -#include "actions.h" -#include "obstack.h" -#include "assert.h" -#include "toplev.h" - -static int id_cmp PARAMS ((tree *, tree *)); -static void warn_unhandled PARAMS ((const char *)); -static tree adjust_return_value PARAMS ((tree, const char *)); -static tree update_else_range_for_int_const PARAMS ((tree, tree)); -static tree update_else_range_for_range PARAMS ((tree, tree, tree)); -static tree update_else_range_for_range_expr PARAMS ((tree, tree)); -static tree update_else_range_for_type PARAMS ((tree, tree)); -static tree compute_else_range PARAMS ((tree, tree, int)); -static tree check_case_value PARAMS ((tree, tree)); -static void chill_handle_case_label_range PARAMS ((tree, tree, tree)); -static tree chill_handle_multi_case_label_range PARAMS ((tree, tree, tree)); -static tree chill_handle_multi_case_else_label PARAMS ((tree)); -static tree chill_handle_multi_case_label PARAMS ((tree, tree)); -static tree chill_handle_multi_case_label_list PARAMS ((tree, tree)); -static void print_missing_cases PARAMS ((tree, const unsigned char *, long)); - -#define obstack_chunk_alloc xmalloc -#define obstack_chunk_free free - -/* reserved tag definitions */ - -#define TYPE_ID "id" -#define TAG_OBJECT "chill_object" -#define TAG_CLASS "chill_class" - -extern int flag_short_enums; -extern int current_nesting_level; - -extern struct obstack *expression_obstack, permanent_obstack; -extern struct obstack *current_obstack, *saveable_obstack; - -/* This flag is checked throughout the non-CHILL-specific - in the front end. */ -tree chill_integer_type_node; -tree chill_unsigned_type_node; - -/* Never used. Referenced from c-typeck.c, which we use. */ -int current_function_returns_value = 0; -int current_function_returns_null = 0; - -/* data imported from toplev.c */ - -extern char *dump_base_name; - -/* set from command line parameter, to exit after - grant file written, generating no code. */ -int grant_only_flag = 0; - -const char * -lang_identify () -{ - return "chill"; -} - - -void -init_chill () -{ -} - -void -print_lang_statistics () -{ -} - - -void -lang_finish () -{ -#if 0 - extern int errorcount, sorrycount; - - /* this should be the last action in compiling a module. - If there are other actions to be performed at lang_finish - please insert before this */ - - /* FIXME: in case of a syntax error, this leaves the grant file incomplete */ - /* for the moment we print a warning in case of errors and - continue granting */ - if ((errorcount || sorrycount) && grant_count) - { - warning ("%d errors, %d sorries, do granting", errorcount, sorrycount); - errorcount = sorrycount = 0; - } -#endif -} - -void -chill_check_decl (decl) - tree decl; -{ - tree type = TREE_TYPE (decl); - static int alreadyWarned = 0; - - if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */ - { - if (!alreadyWarned) - { - error ("GNU compiler does not support statically allocated objects"); - alreadyWarned = 1; - } - error_with_decl (decl, "`%s' cannot be statically allocated"); - } -} - -/* Comparison function for sorting identifiers in RAISES lists. - Note that because IDENTIFIER_NODEs are unique, we can sort - them by address, saving an indirection. */ -static int -id_cmp (p1, p2) - tree *p1, *p2; -{ - long diff = (long)TREE_VALUE (*p1) - (long)TREE_VALUE (*p2); - - return (diff < 0) ? -1 : (diff > 0); -} - -/* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions - listed in RAISES. */ -tree -build_exception_variant (type, raises) - tree type, raises; -{ - int i; - tree v = TYPE_MAIN_VARIANT (type); - tree t, t2; - int constp = TYPE_READONLY (type); - int volatilep = TYPE_VOLATILE (type); - - if (!raises) - return build_type_variant (v, constp, volatilep); - - if (TREE_CHAIN (raises)) - { /* Sort the list */ - tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree)); - for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++) - a[i] = t; - /* NULL terminator for list. */ - a[i] = NULL_TREE; - qsort (a, i, sizeof (tree), - (int (*) PARAMS ((const void*, const void*))) id_cmp); - while (i--) - TREE_CHAIN (a[i]) = a[i+1]; - raises = a[0]; - } - - for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v)) - { - if (TYPE_READONLY (v) != constp - || TYPE_VOLATILE (v) != volatilep) - continue; - - t = raises; - t2 = TYPE_RAISES_EXCEPTIONS (v); - while (t && t2) - { - if (TREE_TYPE (t) == TREE_TYPE (t2)) - { - t = TREE_CHAIN (t); - t2 = TREE_CHAIN (t2); - } - else break; - } - if (t || t2) - continue; - /* List of exceptions raised matches previously found list. - - @@ Nice to free up storage used in consing up the - @@ list of exceptions raised. */ - return v; - } - - /* Need to build a new variant. */ - if (TREE_PERMANENT (type)) - { - push_obstacks_nochange (); - end_temporary_allocation (); - v = copy_node (type); - pop_obstacks (); - } - else - v = copy_node (type); - - TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type); - TYPE_NEXT_VARIANT (type) = v; - if (raises && ! TREE_PERMANENT (raises)) - { - push_obstacks_nochange (); - end_temporary_allocation (); - raises = copy_list (raises); - pop_obstacks (); - } - TYPE_RAISES_EXCEPTIONS (v) = raises; - return v; -} -#if 0 - -tree -build_rts_call (name, type, args) - const char *name; - tree type, args; -{ - tree decl = lookup_name (get_identifier (name)); - tree converted_args = NULL_TREE; - tree result, length = NULL_TREE; - - assert (decl != NULL_TREE); - while (args) - { - tree arg = TREE_VALUE (args); - if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE - || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE) - { - length = size_in_bytes (TREE_TYPE (arg)); - arg = build_chill_addr_expr (arg, (char *)0); - } - converted_args = tree_cons (NULL_TREE, arg, converted_args); - args = TREE_CHAIN (args); - } - if (length != NULL_TREE) - converted_args = tree_cons (NULL_TREE, length, converted_args); - converted_args = nreverse (converted_args); - result = build_chill_function_call (decl, converted_args); - if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE) - result = build1 (INDIRECT_REF, type, result); - else - result = convert (type, result); - return result; -} -#endif - -/* - * queue name of unhandled exception - * to avoid multiple unhandled warnings - * in one compilation module - */ - -struct already_type -{ - struct already_type *next; - char *name; -}; - -static struct already_type *already_warned = 0; - -static void -warn_unhandled (ex) - const char *ex; -{ - struct already_type *p = already_warned; - - while (p) - { - if (!strcmp (p->name, ex)) - return; - p = p->next; - } - - /* not yet warned */ - p = (struct already_type *)xmalloc (sizeof (struct already_type)); - p->next = already_warned; - p->name = xstrdup (ex); - already_warned = p; - pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex); -} - -/* - * build a call to the following function: - * void __cause_ex1 (char* ex, const char *file, - * const unsigned lineno); - * if the exception is handled or - * void __unhandled_ex (char *ex, char *file, unsigned lineno) - * if the exception is not handled. - */ -tree -build_cause_exception (exp_name, warn_if_unhandled) - tree exp_name; - int warn_if_unhandled; -{ - /* We don't use build_rts_call() here, because the string (array of char) - would be followed by its length in the parameter list built by - build_rts_call, and the runtime routine doesn't want a length parameter.*/ - tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name)); - tree function, fname, lineno, result; - int handled = is_handled (exp_name); - - switch (handled) - { - case 0: - /* no handler */ - if (warn_if_unhandled) - warn_unhandled (IDENTIFIER_POINTER (exp_name)); - function = lookup_name (get_identifier ("__unhandled_ex")); - fname = force_addr_of (get_chill_filename ()); - lineno = get_chill_linenumber (); - break; - case 1: - /* local handler */ - function = lookup_name (get_identifier ("__cause_ex1")); - fname = force_addr_of (get_chill_filename ()); - lineno = get_chill_linenumber (); - break; - case 2: - /* function may propagate this exception */ - function = lookup_name (get_identifier ("__cause_ex1")); - fname = lookup_name (get_identifier (CALLER_FILE)); - if (fname == NULL_TREE) - fname = error_mark_node; - lineno = lookup_name (get_identifier (CALLER_LINE)); - if (lineno == NULL_TREE) - lineno = error_mark_node; - break; - default: - abort(); - } - result = - build_chill_function_call (function, - tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0), - tree_cons (NULL_TREE, fname, - tree_cons (NULL_TREE, lineno, NULL_TREE)))); - return result; -} - -void -expand_cause_exception (exp_name) - tree exp_name; -{ - expand_expr_stmt (build_cause_exception (exp_name, 1)); -} - -/* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE); - otherwise return EXPR. */ - -tree -check_expression (expr, condition, exception) - tree expr, condition, exception; -{ - if (integer_zerop (condition)) - return expr; - else - return build (COMPOUND_EXPR, TREE_TYPE (expr), - fold (build (TRUTH_ANDIF_EXPR, boolean_type_node, - condition, build_cause_exception (exception, 0))), - expr); -} - -/* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT, - somewhat optimized and with some warnings suppressed. - If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes. */ - -tree -test_range (value, lo_limit, hi_limit) - tree value, lo_limit, hi_limit; -{ - if (lo_limit || hi_limit) - { - int old_inhibit_warnings = inhibit_warnings; - tree lo_check, hi_check, check; - - /* This is a hack so that `shorten_compare' doesn't warn the - user about useless range checks that are too much work to - optimize away here. */ - inhibit_warnings = 1; - - lo_check = lo_limit ? - fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) : - boolean_false_node; /* fake passing the check */ - - hi_check = hi_limit ? - fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) : - boolean_false_node; /* fake passing the check */ - - if (lo_check == boolean_false_node) - check = hi_check; - else if (hi_check == boolean_false_node) - check = lo_check; - else - check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, - lo_check, hi_check)); - - inhibit_warnings = old_inhibit_warnings; - return check; - } - else - return boolean_false_node; -} - -/* Return EXPR, except if range_checking is on, return an expression - that also checks that value >= low_limit && value <= hi_limit. - If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes. */ - -tree -check_range (expr, value, lo_limit, hi_limit) - tree expr, value, lo_limit, hi_limit; -{ - tree check = test_range (value, lo_limit, hi_limit); - if (!integer_zerop (check)) - { - if (current_function_decl == NULL_TREE) - { - if (TREE_CODE (check) == INTEGER_CST) - error ("range failure (not inside function)"); - else - warning ("possible range failure (not inside function)"); - } - else - { - if (TREE_CODE (check) == INTEGER_CST) - warning ("expression will always cause RANGEFAIL"); - if (range_checking) - expr = check_expression (expr, check, - ridpointers[(int) RID_RANGEFAIL]); - } - } - return expr; -} - -/* Same as EXPR, except raise EMPTY if EXPR is NULL. */ - -tree -check_non_null (expr) - tree expr; -{ - if (empty_checking) - { - expr = save_if_needed (expr); - return check_expression (expr, - build_compare_expr (EQ_EXPR, - expr, null_pointer_node), - ridpointers[(int) RID_EMPTY]); - } - return expr; -} - -/* There are four conditions to generate a runtime check: - 1) assigning a longer INT to a shorter (signs irrelevant) - 2) assigning a signed to an unsigned - 3) assigning an unsigned to a signed of the same size. - 4) TYPE is a discrete subrange */ - -tree -chill_convert_for_assignment (type, expr, place) - tree type, expr; - const char *place; /* location description for error messages */ -{ - tree ttype = type; - tree etype = TREE_TYPE (expr); - tree result; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return expr; - if (TREE_CODE (expr) == TYPE_DECL) - { - error ("right hand side of assignment is a mode"); - return error_mark_node; - } - - if (! CH_COMPATIBLE (expr, type)) - { - error ("incompatible modes in %s", place); - return error_mark_node; - } - - if (TREE_CODE (type) == REFERENCE_TYPE) - ttype = TREE_TYPE (ttype); - if (etype && TREE_CODE (etype) == REFERENCE_TYPE) - etype = TREE_TYPE (etype); - - if (etype - && (CH_STRING_TYPE_P (ttype) - || (chill_varying_type_p (ttype) - && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype)))) - && (CH_STRING_TYPE_P (etype) - || (chill_varying_type_p (etype) - && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype))))) - { - tree cond; - if (range_checking) - expr = save_if_needed (expr); - cond = string_assignment_condition (ttype, expr); - if (TREE_CODE (cond) == INTEGER_CST) - { - if (integer_zerop (cond)) - { - error ("bad string length in %s", place); - return error_mark_node; - } - /* Otherwise, the condition is always true, so no runtime test. */ - } - else if (range_checking) - expr = check_expression (expr, - invert_truthvalue (cond), - ridpointers[(int) RID_RANGEFAIL]); - } - - if (range_checking - && discrete_type_p (ttype) - && etype != NULL_TREE - && discrete_type_p (etype)) - { - int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype), - TYPE_SIZE (etype)); - int cond2 = TREE_UNSIGNED (ttype) - && (! TREE_UNSIGNED (etype)); - int cond3 = (! TREE_UNSIGNED (type)) - && TREE_UNSIGNED (etype) - && tree_int_cst_equal (TYPE_SIZE (ttype), - TYPE_SIZE (etype)); - int cond4 = TREE_TYPE (ttype) - && discrete_type_p (TREE_TYPE (ttype)); - - if (cond1 || cond2 || cond3 || cond4) - { - tree type_min = TYPE_MIN_VALUE (ttype); - tree type_max = TYPE_MAX_VALUE (ttype); - - expr = save_if_needed (expr); - if (expr && type_min && type_max) - expr = check_range (expr, expr, type_min, type_max); - } - } - result = convert (type, expr); - - /* If the type is a array of PACK bits and the expression is an array - constructor, then build a CONSTRUCTOR for a bitstring. Bitstrings are - zero based, so decrement the value of each CONSTRUCTOR element by the - amount of the lower bound of the array. */ - if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type) - && TREE_CODE (result) == CONSTRUCTOR) - { - tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); - tree new_list = NULL_TREE; - unsigned HOST_WIDE_INT index; - tree element; - - for (element = TREE_OPERAND (result, 1); - element != NULL_TREE; - element = TREE_CHAIN (element)) - { - if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node)) - { - tree purpose = TREE_PURPOSE (element); - switch (TREE_CODE (purpose)) - { - case INTEGER_CST: - new_list - = tree_cons (NULL_TREE, - fold (build (MINUS_EXPR, TREE_TYPE (purpose), - purpose, domain_min)), - new_list); - break; - case RANGE_EXPR: - for (index = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0)); - index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1)); - index++) - new_list = tree_cons (NULL_TREE, - fold (build (MINUS_EXPR, - integer_type_node, - build_int_2 (index, 0), - domain_min)), - new_list); - break; - default: - abort (); - } - } - } - result = copy_node (result); - TREE_OPERAND (result, 1) = nreverse (new_list); - TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type)); - } - - return result; -} - -/* Check that EXPR has valid type for a RETURN or RESULT expression, - converting to the right type. ACTION is "RESULT" or "RETURN". */ - -static tree -adjust_return_value (expr, action) - tree expr; - const char *action; -{ - tree type = TREE_TYPE (TREE_TYPE (current_function_decl)); - - if (TREE_CODE (type) == REFERENCE_TYPE) - { - if (CH_LOCATION_P (expr)) - { - if (! CH_READ_COMPATIBLE (TREE_TYPE (type), - TREE_TYPE (expr))) - { - error ("mode mismatch in %s expression", action); - return error_mark_node; - } - return convert (type, expr); - } - else - { - error ("%s expression must be referable", action); - return error_mark_node; - } - } - else if (! CH_COMPATIBLE (expr, type)) - { - error ("mode mismatch in %s expression", action); - return error_mark_node; - } - return convert (type, expr); -} - -void -chill_expand_result (expr, result_or_return) - tree expr; - int result_or_return; -{ - tree type; - const char *action_name = result_or_return ? "RESULT" : "RETURN"; - - if (pass == 1) - return; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return; - - CH_FUNCTION_SETS_RESULT (current_function_decl) = 1; - - if (chill_at_module_level || global_bindings_p ()) - error ("%s not allowed outside a PROC", action_name); - - result_never_set = 0; - - if (chill_result_decl == NULL_TREE) - { - error ("%s action in PROC with no declared RESULTS", action_name); - return; - } - type = TREE_TYPE (chill_result_decl); - - if (TREE_CODE (type) == ERROR_MARK) - return; - - expr = adjust_return_value (expr, action_name); - - expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr)); -} - -/* - * error if EXPR not NULL and procedure doesn't - * have a return type; - * warning if EXPR NULL, - * procedure *has* a return type, and a previous - * RESULT actions hasn't saved a return value. - */ -void -chill_expand_return (expr, implicit) - tree expr; - int implicit; /* 1 if an implicit return at end of function. */ -{ - tree valtype; - - if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK) - return; - if (chill_at_module_level || global_bindings_p ()) - { - error ("RETURN not allowed outside PROC"); - return; - } - - if (pass == 1) - return; - - result_never_set = 0; - - valtype = TREE_TYPE (TREE_TYPE (current_function_decl)); - if (TREE_CODE (valtype) == VOID_TYPE) - { - if (expr != NULL_TREE) - error ("RETURN with a value, in PROC returning void"); - expand_null_return (); - } - else if (TREE_CODE (valtype) != ERROR_MARK) - { - if (expr == NULL_TREE) - { - if (!CH_FUNCTION_SETS_RESULT (current_function_decl) - && !implicit) - warning ("RETURN with no value and no RESULT action in procedure"); - expr = chill_result_decl; - } - else - expr = adjust_return_value (expr, "RETURN"); - expr = build (MODIFY_EXPR, valtype, - DECL_RESULT (current_function_decl), - expr); - TREE_SIDE_EFFECTS (expr) = 1; - expand_return (expr); - } -} - -void -lookup_and_expand_goto (name) - tree name; -{ - if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK) - return; - if (!ignoring) - { - tree decl = lookup_name (name); - if (decl == NULL || TREE_CODE (decl) != LABEL_DECL) - error ("no label named `%s'", IDENTIFIER_POINTER (name)); - else if (DECL_CONTEXT (decl) != current_function_decl) - error ("cannot GOTO label `%s' outside current function", - IDENTIFIER_POINTER (name)); - else - { - TREE_USED (decl) = 1; - expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl)); - expand_goto (decl); - } - } -} - -void -lookup_and_handle_exit (name) - tree name; -{ - if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK) - return; - if (!ignoring) - { - tree label = munge_exit_label (name); - tree decl = lookup_name (label); - if (decl == NULL || TREE_CODE (decl) != LABEL_DECL) - error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name)); - else if (DECL_CONTEXT (decl) != current_function_decl) - error ("cannot EXIT label `%s' outside current function", - IDENTIFIER_POINTER (name)); - else - { - TREE_USED (decl) = 1; - expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl)); - expand_goto (decl); - } - } -} - -/* ELSE-range handling: The else-range is a chain of trees which collectively - represent the ranges to be tested for the (ELSE) case label. Each element in - the chain represents a range to be tested. The boundaries of the range are - represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */ - -/* This function updates the else-range by removing the given integer constant. */ -static tree -update_else_range_for_int_const (else_range, label) - tree else_range, label; -{ - int lowval = 0, highval = 0; - int label_value = TREE_INT_CST_LOW (label); - tree this_range, prev_range, new_range; - - /* First, find the range element containing the integer, if it exists. */ - prev_range = NULL_TREE; - for (this_range = else_range ; - this_range != NULL_TREE; - this_range = TREE_CHAIN (this_range)) - { - lowval = TREE_INT_CST_LOW (TREE_PURPOSE (this_range)); - highval = TREE_INT_CST_LOW (TREE_VALUE (this_range)); - if (label_value >= lowval && label_value <= highval) - break; - prev_range = this_range; - } - - /* If a range element containing the integer was found, then update the range. */ - if (this_range != NULL_TREE) - { - tree next = TREE_CHAIN (this_range); - if (label_value == lowval) - { - /* The integer is the lower bound of the range element. If it is also the - upper bound, then remove this range element, otherwise update it. */ - if (label_value == highval) - { - if (prev_range == NULL_TREE) - else_range = next; - else - TREE_CHAIN (prev_range) = next; - } - else - TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0); - } - else if (label_value == highval) - { - /* The integer is the upper bound of the range element, so ajust it. */ - TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0); - } - else - { - /* The integer is in the middle of the range element, so split it. */ - new_range = tree_cons ( - build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next); - TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0); - TREE_CHAIN (this_range) = new_range; - } - } - return else_range; -} - -/* Update the else-range to remove a range of values/ */ -static tree -update_else_range_for_range (else_range, low_target, high_target) - tree else_range, low_target, high_target; -{ - tree this_range, prev_range, new_range, next_range; - int low_range_val = 0, high_range_val = 0; - int low_target_val = TREE_INT_CST_LOW (low_target); - int high_target_val = TREE_INT_CST_LOW (high_target); - - /* find the first else-range element which overlaps the target range. */ - prev_range = NULL_TREE; - for (this_range = else_range ; - this_range != NULL_TREE; - this_range = TREE_CHAIN (this_range)) - { - low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range)); - high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range)); - if ((low_target_val >= low_range_val && low_target_val <= high_range_val) - || (high_target_val >= low_range_val && high_target_val <= high_range_val)) - break; - prev_range = this_range; - } - if (this_range == NULL_TREE) - return else_range; - - /* This first else-range element might be truncated at the top or completely - contain the target range. */ - if (low_range_val < low_target_val) - { - next_range = TREE_CHAIN (this_range); - if (high_range_val > high_target_val) - { - new_range = tree_cons ( - build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range); - TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0); - TREE_CHAIN (this_range) = new_range; - return else_range; - } - - TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0); - if (next_range == NULL_TREE) - return else_range; - - prev_range = this_range; - this_range = next_range; - high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range)); - } - - /* There may then follow zero or more else-range elements which are completely - contained in the target range. */ - while (high_range_val <= high_target_val) - { - this_range = TREE_CHAIN (this_range); - if (prev_range == NULL_TREE) - else_range = this_range; - else - TREE_CHAIN (prev_range) = this_range; - - if (this_range == NULL_TREE) - return else_range; - high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range)); - } - - /* Finally, there may be a else-range element which is truncated at the bottom. */ - low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range)); - if (low_range_val <= high_target_val) - TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0); - - return else_range; -} - -static tree -update_else_range_for_range_expr (else_range, label) - tree else_range, label; -{ - if (TREE_OPERAND (label, 0) == NULL_TREE) - { - if (TREE_OPERAND (label, 1) == NULL_TREE) - else_range = NULL_TREE; /* (*) -- matches everything */ - } - else - else_range = update_else_range_for_range ( - else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1)); - - return else_range; -} - -static tree -update_else_range_for_type (else_range, label) - tree else_range, label; -{ - tree type = TREE_TYPE (label); - else_range = update_else_range_for_range ( - else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type)); - return else_range; -} - -static tree -compute_else_range (selector, alternatives, selector_no) - tree selector, alternatives; - int selector_no; -{ - /* Start with an else-range that spans the entire range of the selector type. */ - tree type = TREE_TYPE (TREE_VALUE (selector)); - tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE); - - /* Now remove the values represented by each case lebel specified for that - selector. The remaining range is the else-range. */ - for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives)) - { - tree label; - tree label_list = TREE_PURPOSE (alternatives); - int this_selector; - for (this_selector = 0; this_selector < selector_no ; ++this_selector) - label_list = TREE_CHAIN (label_list); - - for (label = TREE_VALUE (label_list); - label != NULL_TREE; - label = TREE_CHAIN (label)) - { - tree label_value = TREE_VALUE (label); - if (TREE_CODE (label_value) == INTEGER_CST) - range = update_else_range_for_int_const (range, label_value); - else if (TREE_CODE (label_value) == RANGE_EXPR) - range = update_else_range_for_range_expr (range, label_value); - else if (TREE_CODE (label_value) == TYPE_DECL) - range = update_else_range_for_type (range, label_value); - - if (range == NULL_TREE) - break; - } - } - - return range; -} - -void -compute_else_ranges (selectors, alternatives) - tree selectors, alternatives; -{ - tree selector; - int selector_no = 0; - - for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector)) - { - if (ELSE_LABEL_SPECIFIED (selector)) - TREE_PURPOSE (selector) = - compute_else_range (selector, alternatives, selector_no); - selector_no++; - } -} - -static tree -check_case_value (label_value, selector) - tree label_value, selector; -{ - if (TREE_CODE (label_value) == ERROR_MARK) - return label_value; - if (TREE_CODE (selector) == ERROR_MARK) - return selector; - - /* Z.200 (6.4 Case action) says: "The class of any discrete expression - in the case selector list must be compatible with the corresponding - (by position) class of the resulting list of classes of the case label - list occurrences ...". We don't actually construct the resulting - list of classes, but this test should be more-or-less equivalent. - I think... */ - if (!CH_COMPATIBLE_CLASSES (selector, label_value)) - { - error ("case selector not compatible with label"); - return error_mark_node; - } - - /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */ - STRIP_TYPE_NOPS (label_value); - - if (TREE_CODE (label_value) != INTEGER_CST) - { - error ("case label does not reduce to an integer constant"); - return error_mark_node; - } - - constant_expression_warning (label_value); - return label_value; -} - -void -chill_handle_case_default () -{ - tree duplicate; - register tree label = build_decl (LABEL_DECL, NULL_TREE, - NULL_TREE); - int success = pushcase (NULL_TREE, 0, label, &duplicate); - - if (success == 1) - error ("ELSE label not within a CASE statement"); -#if 0 - else if (success == 2) - { - error ("multiple default labels found in a CASE statement"); - error_with_decl (duplicate, "this is the first ELSE label"); - } -#endif -} - -/* Handle cases label such as (I:J): or (modename): */ - -static void -chill_handle_case_label_range (min_value, max_value, selector) - tree min_value, max_value, selector; -{ - register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); - min_value = check_case_value (min_value, selector); - max_value = check_case_value (max_value, selector); - if (TREE_CODE (min_value) != ERROR_MARK - && TREE_CODE (max_value) != ERROR_MARK) - { - tree duplicate; - int success = pushcase_range (min_value, max_value, - convert, label, &duplicate); - if (success == 1) - error ("label found outside of CASE statement"); - else if (success == 2) - { - error ("duplicate CASE value"); - error_with_decl (duplicate, "this is the first entry for that value"); - } - else if (success == 3) - error ("CASE value out of range"); - else if (success == 4) - error ("empty range"); - else if (success == 5) - error ("label within scope of cleanup or variable array"); - } -} - -void -chill_handle_case_label (label_value, selector) - tree label_value, selector; -{ - if (label_value == NULL_TREE - || TREE_CODE (label_value) == ERROR_MARK) - return; - if (TREE_CODE (label_value) == RANGE_EXPR) - { - if (TREE_OPERAND (label_value, 0) == NULL_TREE) - chill_handle_case_default (); /* i.e. (ELSE): or (*): */ - else - chill_handle_case_label_range (TREE_OPERAND (label_value, 0), - TREE_OPERAND (label_value, 1), - selector); - } - else if (TREE_CODE (label_value) == TYPE_DECL) - { - tree type = TREE_TYPE (label_value); - if (! discrete_type_p (type)) - error ("mode in label is not discrete"); - else - chill_handle_case_label_range (TYPE_MIN_VALUE (type), - TYPE_MAX_VALUE (type), - selector); - } - else - { - register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); - - label_value = check_case_value (label_value, selector); - - if (TREE_CODE (label_value) != ERROR_MARK) - { - tree duplicate; - int success = pushcase (label_value, convert, label, &duplicate); - if (success == 1) - error ("label not within a CASE statement"); - else if (success == 2) - { - error ("duplicate case value"); - error_with_decl (duplicate, - "this is the first entry for that value"); - } - else if (success == 3) - error ("CASE value out of range"); - else if (success == 4) - error ("empty range"); - else if (success == 5) - error ("label within scope of cleanup or variable array"); - } - } -} - -int -chill_handle_single_dimension_case_label ( - selector, label_spec, expand_exit_needed, caseaction_flag -) - tree selector, label_spec; - int *expand_exit_needed, *caseaction_flag; -{ - tree labels, one_label; - int no_completeness_check = 0; - - if (*expand_exit_needed || *caseaction_flag == 1) - { - expand_exit_something (); - *expand_exit_needed = 0; - } - - for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels)) - for (one_label = TREE_VALUE (labels); one_label != NULL_TREE; - one_label = TREE_CHAIN (one_label)) - { - if (TREE_VALUE (one_label) == case_else_node) - no_completeness_check = 1; - - chill_handle_case_label (TREE_VALUE (one_label), selector); - } - - *caseaction_flag = 1; - - return no_completeness_check; -} - -static tree -chill_handle_multi_case_label_range (low, high, selector) - tree low, high, selector; -{ - tree low_expr, high_expr, and_expr; - tree selector_type; - int low_target_val, high_target_val; - int low_type_val, high_type_val; - - /* we can eliminate some tests is the low and/or high value in the given range - are outside the range of the selector type. */ - low_target_val = TREE_INT_CST_LOW (low); - high_target_val = TREE_INT_CST_LOW (high); - selector_type = TREE_TYPE (selector); - low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type)); - high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type)); - - if (low_target_val > high_type_val || high_target_val < low_type_val) - return boolean_false_node; /* selector never in range */ - - if (low_type_val >= low_target_val) - { - if (high_type_val <= high_target_val) - return boolean_true_node; /* always in the range */ - return build_compare_expr (LE_EXPR, selector, high); - } - - if (high_type_val <= high_target_val) - return build_compare_expr (GE_EXPR, selector, low); - - /* The target range in completely within the range of the selector, but we - might be able to save a test if the upper bound is the same as the lower - bound. */ - if (low_target_val == high_target_val) - return build_compare_expr (EQ_EXPR, selector, low); - - /* No optimizations possible. Just generate tests against the upper and lower - bound of the target */ - low_expr = build_compare_expr (GE_EXPR, selector, low); - high_expr = build_compare_expr (LE_EXPR, selector, high); - and_expr = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr); - - return and_expr; -} - -static tree -chill_handle_multi_case_else_label (selector) - tree selector; -{ - tree else_range, selector_value, selector_type; - tree low, high, larg; - - else_range = TREE_PURPOSE (selector); - if (else_range == NULL_TREE) - return boolean_false_node; /* no values in ELSE range */ - - /* Test each of the ranges in the else-range chain */ - selector_value = TREE_VALUE (selector); - selector_type = TREE_TYPE (selector_value); - low = convert (selector_type, TREE_PURPOSE (else_range)); - high = convert (selector_type, TREE_VALUE (else_range)); - larg = chill_handle_multi_case_label_range (low, high, selector_value); - - for (else_range = TREE_CHAIN (else_range); - else_range != NULL_TREE; - else_range = TREE_CHAIN (else_range)) - { - tree rarg; - low = convert (selector_type, TREE_PURPOSE (else_range)); - high = convert (selector_type, TREE_VALUE (else_range)); - rarg = chill_handle_multi_case_label_range (low, high, selector_value); - larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg); - } - - return larg; -} - -static tree -chill_handle_multi_case_label (selector, label) - tree selector, label; -{ - tree expr = NULL_TREE; - - if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK) - return NULL_TREE; - - if (TREE_CODE (label) == INTEGER_CST) - { - int target_val = TREE_INT_CST_LOW (label); - tree selector_type = TREE_TYPE (TREE_VALUE (selector)); - int low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type)); - int high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type)); - if (target_val < low_type_val || target_val > high_type_val) - expr = boolean_false_node; - else - expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label); - } - else if (TREE_CODE (label) == RANGE_EXPR) - { - if (TREE_OPERAND (label, 0) == NULL_TREE) - { - if (TREE_OPERAND (label, 1) == NULL_TREE) - expr = boolean_true_node; /* (*) -- matches everything */ - else - expr = chill_handle_multi_case_else_label (selector); - } - else - { - tree low = TREE_OPERAND (label, 0); - tree high = TREE_OPERAND (label, 1); - if (TREE_CODE (low) != INTEGER_CST) - { - error ("Lower bound of range must be a discrete literal expression"); - expr = error_mark_node; - } - if (TREE_CODE (high) != INTEGER_CST) - { - error ("Upper bound of range must be a discrete literal expression"); - expr = error_mark_node; - } - if (expr != error_mark_node) - { - expr = chill_handle_multi_case_label_range ( - low, high, TREE_VALUE (selector)); - } - } - } - else if (TREE_CODE (label) == TYPE_DECL) - { - tree type = TREE_TYPE (label); - if (! discrete_type_p (type)) - { - error ("mode in label is not discrete"); - expr = error_mark_node; - } - else - expr = chill_handle_multi_case_label_range ( - TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector)); - } - else - { - error ("The CASE label is not valid"); - expr = error_mark_node; - } - - return expr; -} - -static tree -chill_handle_multi_case_label_list (selector, labels) - tree selector, labels; -{ - tree one_label, larg, rarg; - - one_label = TREE_VALUE (labels); - larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label)); - - for (one_label = TREE_CHAIN (one_label); - one_label != NULL_TREE; - one_label = TREE_CHAIN (one_label)) - { - rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label)); - larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg); - } - - return larg; -} - -tree -build_multi_case_selector_expression (selector_list, label_spec) - tree selector_list, label_spec; -{ - tree labels, selector, larg, rarg; - - labels = label_spec; - selector = selector_list; - larg = chill_handle_multi_case_label_list(selector, labels); - - for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector); - labels != NULL_TREE && selector != NULL_TREE; - labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector)) - { - rarg = chill_handle_multi_case_label_list(selector, labels); - larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg); - } - - if (labels != NULL_TREE || selector != NULL_TREE) - error ("The number of CASE selectors does not match the number of CASE label lists"); - - return larg; -} - -#define BITARRAY_TEST(ARRAY, INDEX) \ - ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\ - & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))) -#define BITARRAY_SET(ARRAY, INDEX) \ - ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\ - |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)) - -/* CASES_SEEN is a set (bitarray) of length COUNT. - For each element that is zero, print an error message, - assume the element have the given TYPE. */ - -static void -print_missing_cases (type, cases_seen, count) - tree type; - const unsigned char *cases_seen; - long count; -{ - long i; - for (i = 0; i < count; i++) - { - if (BITARRAY_TEST(cases_seen, i) == 0) - { - char buf[20]; - long x = i; - long j; - tree t = type; - const char *err_val_name = "???"; - if (TYPE_MIN_VALUE (t) - && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST) - x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t)); - while (TREE_TYPE (t) != NULL_TREE) - t = TREE_TYPE (t); - switch (TREE_CODE (t)) - { - tree v; - case BOOLEAN_TYPE: - err_val_name = x ? "TRUE" : "FALSE"; - break; - case CHAR_TYPE: - { - char *bufptr; - if ((x >= ' ' && x < 127) && x != '\'' && x != '^') - sprintf (buf, "'%c'", (char)x); - else - sprintf (buf, "'^(%ld)'", x); - bufptr = buf; - j = i; - while (j < count && !BITARRAY_TEST(cases_seen, j)) - j++; - if (j > i + 1) - { - long y = x+j-i-1; - bufptr += strlen (bufptr); - if ((y >= ' ' && y < 127) && y != '\'' && y != '^') - sprintf (bufptr, "%s:'%c'", buf, (char)y); - else - sprintf (bufptr, "%s:'^(%ld)'", buf, y); - i = j - 1; - } - err_val_name = bufptr; - } - break; - case ENUMERAL_TYPE: - for (v = TYPE_VALUES (t); v && x; v = TREE_CHAIN (v)) - x--; - if (v) - err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v)); - break; - default: - j = i; - while (j < count && !BITARRAY_TEST(cases_seen, j)) - j++; - if (j == i + 1) - sprintf (buf, "%ld", x); - else - sprintf (buf, "%ld:%ld", x, x+j-i-1); - i = j - 1; - err_val_name = buf; - break; - } - error ("incomplete CASE - %s not handled", err_val_name); - } - } -} - -void -check_missing_cases (type) - tree type; -{ - int is_sparse; - /* For each possible selector value. a one iff it has been matched - by a case value alternative. */ - unsigned char *cases_seen; - /* The number of possible selector values. */ - HOST_WIDE_INT size = all_cases_count (type, &is_sparse); - HOST_WIDE_INT bytes_needed - = (size + HOST_BITS_PER_CHAR) / HOST_BITS_PER_CHAR; - - if (size == -1) - warning ("CASE selector with variable range"); - else if (size < 0 || size > 600000 - /* We deliberately use malloc here - not xmalloc. */ - || (cases_seen = (char*) malloc (bytes_needed)) == NULL) - warning ("too many cases to do CASE completeness testing"); - else - { - memset (cases_seen, 0, bytes_needed); - mark_seen_cases (type, cases_seen, size, is_sparse); - print_missing_cases (type, cases_seen, size); - free (cases_seen); - } -} - -/* - * We build an expression tree here because, in many contexts, - * we don't know the type of result that's desired. By the - * time we get to expanding the tree, we do know. - */ -tree -build_chill_case_expr (exprlist, casealtlist_expr, - optelsecase_expr) - tree exprlist, casealtlist_expr, optelsecase_expr; -{ - return build (CASE_EXPR, NULL_TREE, exprlist, - optelsecase_expr ? - tree_cons (NULL_TREE, - optelsecase_expr, - casealtlist_expr) : - casealtlist_expr); -} - -/* This function transforms the selector_list and alternatives into a COND_EXPR. */ -tree -build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr) - tree selector_list, alternatives, else_expr; -{ - tree expr; - - selector_list = check_case_selector_list (selector_list); - - if (alternatives == NULL_TREE) - return NULL_TREE; - - alternatives = nreverse (alternatives); - /* alternatives represents the CASE label specifications and resulting values in - the reverse order in which they appeared. - If there is an ELSE expression, then use it. If there is no - ELSE expression, make the last alternative (which is the first in the list) - into the ELSE expression. This is safe because, if the CASE is complete - (as required), then the last condition need not be checked anyway. */ - if (else_expr != NULL_TREE) - expr = else_expr; - else - { - expr = TREE_VALUE (alternatives); - alternatives = TREE_CHAIN (alternatives); - } - - for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives)) - { - tree value = TREE_VALUE (alternatives); - tree labels = TREE_PURPOSE (alternatives); - tree cond = build_multi_case_selector_expression(selector_list, labels); - expr = build_nt (COND_EXPR, cond, value, expr); - } - - return expr; -} - - -/* This is called with the assumption that RHS has been stabilized. - It has one purpose: to iterate through the CHILL list of LHS's */ -void -expand_assignment_action (loclist, modifycode, rhs) - tree loclist; - enum chill_tree_code modifycode; - tree rhs; -{ - if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK - || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK) - return; - - if (TREE_CHAIN (loclist) != NULL_TREE) - { /* Multiple assignment */ - tree target; - if (TREE_TYPE (rhs) != NULL_TREE) - rhs = save_expr (rhs); - else if (TREE_CODE (rhs) == CONSTRUCTOR) - error ("type of tuple cannot be implicit in multiple assignent"); - else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR) - error ("conditional expression cannot be used in multiple assignent"); - else - error ("internal error - unknown type in multiple assignment"); - - if (modifycode != NOP_EXPR) - { - error ("no operator allowed in multiple assignment,"); - modifycode = NOP_EXPR; - } - - for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target)) - { - if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)), - TREE_TYPE (TREE_VALUE (loclist)))) - { - error - ("location modes in multiple assignment are not equivalent"); - break; - } - } - } - for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist)) - chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs); -} - -void -chill_expand_assignment (lhs, modifycode, rhs) - tree lhs; - enum chill_tree_code modifycode; - tree rhs; -{ - tree loc; - - while (TREE_CODE (lhs) == COMPOUND_EXPR) - { - expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0); - emit_queue (); - lhs = TREE_OPERAND (lhs, 1); - } - - if (TREE_CODE (lhs) == ERROR_MARK) - return; - - /* errors for assignment to BUFFER, EVENT locations. - what about SIGNALs? FIXME: Need similar test in - build_chill_function_call. */ - if (TREE_CODE (lhs) == IDENTIFIER_NODE) - { - tree decl = lookup_name (lhs); - if (decl) - { - tree type = TREE_TYPE (decl); - if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) - { - error ("You may not assign a value to a BUFFER or EVENT location"); - return; - } - } - } - - if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs)) - { - error ("can't assign value to READonly location"); - return; - } - if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs))) - { - error ("cannot assign to location with non-value property"); - return; - } - - if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE) - lhs = convert_from_reference (lhs); - - /* check for lhs is a location */ - loc = lhs; - while (1) - { - if (TREE_CODE (loc) == SLICE_EXPR) - loc = TREE_OPERAND (loc, 0); - else if (TREE_CODE (loc) == SET_IN_EXPR) - loc = TREE_OPERAND (loc, 1); - else - break; - } - if (! CH_LOCATION_P (loc)) - { - error ("lefthand side of assignment is not a location"); - return; - } - - /* If a binary op has been requested, combine the old LHS value with - the RHS producing the value we should actually store into the LHS. */ - - if (modifycode != NOP_EXPR) - { - lhs = stabilize_reference (lhs); - /* This is to handle border-line cases such - as: LHS OR := [I]. This seems to be permitted - by the letter of Z.200, though it violates - its spirit, since LHS:=LHS OR [I] is - *not* legal. */ - if (TREE_TYPE (rhs) == NULL_TREE) - rhs = convert (TREE_TYPE (lhs), rhs); - rhs = build_chill_binary_op (modifycode, lhs, rhs); - } - - rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment"); - - /* handle the LENGTH (vary_array) := expr action */ - loc = lhs; - if (TREE_CODE (loc) == NOP_EXPR) - loc = TREE_OPERAND (loc, 0); - if (TREE_CODE (loc) == COMPONENT_REF - && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0))) - && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id) - { - expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs); - } - else if (TREE_CODE (lhs) == SLICE_EXPR) - { - tree func = lookup_name (get_identifier ("__pscpy")); - tree dst = TREE_OPERAND (lhs, 0); - tree dst_offset = TREE_OPERAND (lhs, 1); - tree length = TREE_OPERAND (lhs, 2); - tree src, src_offset; - if (TREE_CODE (rhs) == SLICE_EXPR) - { - src = TREE_OPERAND (rhs, 0); - /* Should check that the TREE_OPERAND (src, 0) is - the same as length and powerserlen (src). FIXME */ - src_offset = TREE_OPERAND (rhs, 1); - } - else - { - src = rhs; - src_offset = integer_zero_node; - } - expand_expr_stmt (build_chill_function_call (func, - tree_cons (NULL_TREE, force_addr_of (dst), - tree_cons (NULL_TREE, powersetlen (dst), - tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset), - tree_cons (NULL_TREE, force_addr_of (src), - tree_cons (NULL_TREE, powersetlen (src), - tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset), - tree_cons (NULL_TREE, convert (long_unsigned_type_node, length), - NULL_TREE))))))))); - } - - else if (TREE_CODE (lhs) == SET_IN_EXPR) - { - tree from_pos = save_expr (TREE_OPERAND (lhs, 0)); - tree set = TREE_OPERAND (lhs, 1); - tree domain = TYPE_DOMAIN (TREE_TYPE (set)); - tree set_length - = fold (build (PLUS_EXPR, integer_type_node, - fold (build (MINUS_EXPR, integer_type_node, - TYPE_MAX_VALUE (domain), - TYPE_MIN_VALUE (domain))), - integer_one_node)); - tree filename = force_addr_of (get_chill_filename()); - - if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE) - sorry("bitstring slice"); - expand_expr_stmt ( - build_chill_function_call (lookup_name ( - get_identifier ("__setbitpowerset")), - tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"), - tree_cons (NULL_TREE, set_length, - tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain), - tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos), - tree_cons (NULL_TREE, rhs, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, get_chill_linenumber(), - NULL_TREE))))))))); - } - - /* Handle arrays of packed bitfields. Currently, this is limited to bitfields - which are 1 bit wide, so use the powerset runtime function. */ - else if (TREE_CODE (lhs) == PACKED_ARRAY_REF) - { - tree from_pos = save_expr (TREE_OPERAND (lhs, 1)); - tree array = TREE_OPERAND (lhs, 0); - tree domain = TYPE_DOMAIN (TREE_TYPE (array)); - tree array_length = powersetlen (array); - tree filename = force_addr_of (get_chill_filename()); - expand_expr_stmt ( - build_chill_function_call (lookup_name ( - get_identifier ("__setbitpowerset")), - tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"), - tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length), - tree_cons (NULL_TREE, convert (long_integer_type_node, - TYPE_MIN_VALUE (domain)), - tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos), - tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs), - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, get_chill_linenumber(), - NULL_TREE))))))))); - } - - /* The following is probably superceded by the - above code for SET_IN_EXPR. FIXME! */ - else if (TREE_CODE (lhs) == BIT_FIELD_REF) - { - tree set = TREE_OPERAND (lhs, 0); - tree numbits = TREE_OPERAND (lhs, 1); - tree from_pos = save_expr (TREE_OPERAND (lhs, 2)); - tree domain = TYPE_DOMAIN (TREE_TYPE (set)); - tree set_length - = fold (build (PLUS_EXPR, integer_type_node, - fold (build (MINUS_EXPR, integer_type_node, - TYPE_MAX_VALUE (domain), - TYPE_MIN_VALUE (domain))), - integer_one_node)); - tree filename = force_addr_of (get_chill_filename()); - tree to_pos; - - switch (TREE_CODE (TREE_TYPE (rhs))) - { - case SET_TYPE: - to_pos = fold (build (MINUS_EXPR, integer_type_node, - fold (build (PLUS_EXPR, integer_type_node, - from_pos, numbits)), - integer_one_node)); - break; - case BOOLEAN_TYPE: - to_pos = from_pos; - break; - default: - abort (); - } - - if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE) - sorry("bitstring slice"); - expand_expr_stmt ( - build_chill_function_call( lookup_name ( - get_identifier ("__setbitpowerset")), - tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"), - tree_cons (NULL_TREE, set_length, - tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain), - tree_cons (NULL_TREE, from_pos, - tree_cons (NULL_TREE, rhs, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, get_chill_linenumber(), - NULL_TREE))))))))); - } - - else - expand_expr_stmt (build_chill_modify_expr (lhs, rhs)); -} - -/* Also assumes that rhs has been stabilized */ -void -expand_varying_length_assignment (lhs, rhs) - tree lhs, rhs; -{ - tree base_array, min_domain_val; - - pedwarn ("LENGTH on left-hand-side is non-portable"); - - if (! CH_LOCATION_P (lhs)) - { - error ("Can only set LENGTH of array location"); - return; - } - - /* cause a RANGE exception if rhs would cause a 'hole' in the array. */ - rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1); - - base_array = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)); - min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array)); - - lhs = build_component_ref (lhs, var_length_id); - rhs = fold (build (MINUS_EXPR, TREE_TYPE (rhs), rhs, min_domain_val)); - - expand_expr_stmt (build_chill_modify_expr (lhs, rhs)); -} - -void -push_action () -{ - push_handler (); - if (ignoring) - return; - emit_line_note (input_filename, lineno); -} diff --git a/gcc/ch/actions.h b/gcc/ch/actions.h deleted file mode 100644 index acffa4bfd06..00000000000 --- a/gcc/ch/actions.h +++ /dev/null @@ -1,34 +0,0 @@ -/* Declarations for ch-actions.c. - Copyright (C) 1992, 1993, 1994, 1998, 2000 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* used by compile_file */ - -void init_chill PARAMS ((void)); - -extern int grant_count; - -extern void push_handler PARAMS ((void)); -extern void pop_handler PARAMS ((int)); -extern void push_action PARAMS ((void)); - -extern int chill_handle_single_dimension_case_label PARAMS ((tree, tree, int *, int *)); -extern tree build_chill_multi_dimension_case_expr PARAMS ((tree, tree, tree)); -extern tree build_multi_case_selector_expression PARAMS ((tree, tree)); -extern void compute_else_ranges PARAMS ((tree, tree)); diff --git a/gcc/ch/ch-tree.def b/gcc/ch/ch-tree.def deleted file mode 100644 index a47e014744c..00000000000 --- a/gcc/ch/ch-tree.def +++ /dev/null @@ -1,114 +0,0 @@ -/* This file contains the definitions and documentation for the - additional tree codes used in the CHILL front end (see tree.def - for the standard codes). - Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -/* - * CHILL types. - */ -DEFTREECODE (GRANT_TYPE, "grant_type", 't', 0) -DEFTREECODE (SEIZE_TYPE, "seize_type", 't', 0) -/* - * CHILL decls. - */ -DEFTREECODE (KEYWORD_DECL, "keyword_decl", 'd', 0) -DEFTREECODE (INSTANCE_METHOD_DECL, "instance_method_decl", 'd', 0) -DEFTREECODE (CLASS_METHOD_DECL, "class_method_decl", 'd', 0) - -/* A 'SEIZE (OLD->NEW)!POSTFIX' or 'GRANT (OLD->NEW)!POSTFIX' is - represented as an ALIAS_DECL where DECL_OLD_PREFIX, DECL_NEW_PREFIX, - and DECL_POSTFIX points to OLD, NEW, and POSTFIX, repectively. - These are IDENTIFIER_NODEs, or NULL if empty. - DECL_NAME is NEW!POSTFIX. After binding, DECL_ABSTRACT_ORIGIN - (if not an error_mark) points to a decl whose DECL_NAME is OLD!POSTFIX. - and which this name is linked to. - For SEIZE, DECL_SEIZEFILE names the most recent use_seize_file directive. - For GRANT, DECL_SEIZEFILE names the seizefile doing the granting. */ -DEFTREECODE (ALIAS_DECL, "alias_decl", 'd', 0) - -/* A variable, which is BASED on a pointer variable in DECL_ABSTRACT_ORIGIN. */ -DEFTREECODE (BASED_DECL, "based_decl", 'd', 0) - -/* A pseudo-variable declared by a DO WITH. */ -DEFTREECODE (WITH_DECL, "with_decl", 'd', 0) - -/* - * CHILL exprs. - */ -DEFTREECODE (CONCAT_EXPR, "concat_expr", '2', 2) - -/* A slice (sub-array or sub-string) of operand 0, where - operand 1 is the start of the slice, and operand 2 is its length. - Currently, only used for bitstring sclices. */ -DEFTREECODE (SLICE_EXPR, "slice_expr", 'e', 3) - -/* Later, SET_IN_EXPR might be replaced by BIT_FIELD_REF or IN_EXPR. */ -DEFTREECODE (SET_IN_EXPR, "set_in_expr", '2', 2) - -/* A CASE_EXPR EX implements Chill CASE expression. - TREE_OPERAND (EX, 0) is a TREE_LIST representing the <case selector list>, - with one node for each expression. (Only one is supported by the - current implementation.) - TREE_OPERAND (EX, 1) is also a TREE_LIST, with one node for each - <value case alternative>. The TREE_VALUE of these node is the - <sub expression> (case element body); the TREE_PURPOSE contains - the <case label specification>. (The TREE_PURPOSE for the - optional ELSE (default) branch is NULL_TREE.) Each <case label - specification> is also represented as a list with one TREE_LIST - node for each <case label list> (though only length==1 is currently - supported). And finally: each <case label list> is again a list - with one TREE_LIST node for each <case label>. */ -DEFTREECODE (CASE_EXPR, "case_expr", 'e', 2) - -/* Powerset and static bit array operations. - Operands have same mode as result. */ -DEFTREECODE (SET_NOT_EXPR, "set_not_expr", '1', 1) -DEFTREECODE (SET_IOR_EXPR, "set_ior_expr", '2', 2) -DEFTREECODE (SET_XOR_EXPR, "set_xor_expr", '2', 2) -DEFTREECODE (SET_AND_EXPR, "set_and_expr", '2', 2) -DEFTREECODE (SET_DIFF_EXPR, "set_diff_expr", '2', 2) -DEFTREECODE (PAREN_EXPR, "paren_expr", '1', 1) - -DEFTREECODE (STRING_EQ_EXPR, "string_eq_expr", '2', 2) -DEFTREECODE (STRING_LT_EXPR, "string_lt_expr", '2', 2) - -/* Used to represent a string repetition expression, until - we have a type for it; a SET_TYPE replicator needs a - TYPE_DOMAIN even if it represents the empty set */ -DEFTREECODE (REPLICATE_EXPR, "replicate_expr", 'e', 2) - -/* An undefined value. Used for the Chill operator '*', - and sometimes for padding. */ -DEFTREECODE (UNDEFINED_EXPR, "undefined_expr", 'e', 0) - -/* Used to represent a process instance */ -DEFTREECODE (INSTANCE_TYPE, "instance_type", 't', 0) - -/* Used to represent a reference to an array of bitfields. Currently restricted - to fields which are 1 bit wide. */ -DEFTREECODE (PACKED_ARRAY_REF, "packed_array_ref", 'r', 2) - -/* ALSO NOTE: LANG_TYPE is used for two things during pass 1; - such a node is converted to some other type node during satisfy. - If CH_NOVELTY_FLAG is set, then this node is a logical copy of - its TREE_TYPE, but with a different novelty. - If TYPE_READONLY is set, then the node stands for 'READ M' - where M is the TREE_TYPE. */ diff --git a/gcc/ch/ch-tree.h b/gcc/ch/ch-tree.h deleted file mode 100644 index 4d652b1eb2b..00000000000 --- a/gcc/ch/ch-tree.h +++ /dev/null @@ -1,1157 +0,0 @@ -/* Definitions for CHILL parsing and type checking. - Copyright (C) 1992, 1993, 1994, 1998, - 1999, 2000 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#ifndef _CH_TREE_H -#define _CH_TREE_H - -/* Usage of TREE_LANG_FLAG_?: - 1: TUPLE_NAMED_FIELD - " TYPE_FIELDS_READONLY (in ARRAY_TYPE, RECORD_TYPE or UNION_TYPE) - " C_DECLARED_LABEL_FLAG - " C_TYPE_VARIABLE_SIZE - 2: C_TYPE_FIELDS_VOLATILE (in RECORD_TYPE or UNION_TYPE) - " ELSE_LABEL_SPECIFIED (in CASE selector expression) - 3: UNSATISFIED_FLAG - 4: CH_USE_SEIZEFILE_RESTRICTED - " CH_ALREADY_GRANTED - 5: CH_DERIVED_FLAG (in EXPR or DECL) -*/ - -/* Usage of TYPE_LANG_FLAG_?: - 0: CH_TYPE_NONVALUE_P - 1: C_TYPE_VARIABLE_SIZE - 2: CH_IS_ACCESS_MODE - 3: CH_IS_BUFFER_MODE - 4: CH_IS_EVENT_MODE - 5: CH_ENUM_IS_NUMBERED - 6: CH_IS_TEXT_MODE -*/ - -/* Language-dependent contents of an identifier. */ - -struct lang_identifier -{ - /* These match the fields in c-tree.h. */ - struct tree_identifier ignore; - tree outer_value, local_value, implicit_decl; - tree error_locus, limbo_value; - - /* These are Chill-specific. */ - tree forbid; - tree signal_dest; - int signal_data; -}; - -/* Macros for access to language-specific slots in an identifier. */ - -/* The outer_value is a chain of decls (normally a single decl), - that have been granted into the scope surrounding all modules. */ -#define IDENTIFIER_OUTER_VALUE(NODE) \ - (((struct lang_identifier *)(NODE))->outer_value) -#define IDENTIFIER_LOCAL_VALUE(NODE) \ - (((struct lang_identifier *)(NODE))->local_value) -#define IDENTIFIER_IMPLICIT_DECL(NODE) \ - (((struct lang_identifier *)(NODE))->implicit_decl) -#define IDENTIFIER_ERROR_LOCUS(NODE) \ - (((struct lang_identifier *)(NODE))->error_locus) -#define IDENTIFIER_FORBID(NODE) \ - (((struct lang_identifier *)(NODE))->forbid) - -/* The nesting level increates by one for every nested 'group'. - Predefined declarations have level -1; the global scope is level 0. - */ -#define DECL_NESTING_LEVEL(DECL) \ - ((DECL)->decl.vindex ? TREE_INT_CST_HIGH((DECL)->decl.vindex) : -1) - -/* Nesting of things that can have an ON-unit attached. */ -extern int action_nesting_level; - -/* The DECL_NAME of a FIELD_DECL that represents the ELSE part of a variant. */ -#define ELSE_VARIANT_NAME ridpointers[(int) RID_ELSE] - -/* For a LABEL_DECL: action_nesting_level of its target. */ -#define DECL_ACTION_NESTING_LEVEL(NODE) ((NODE)->decl.u2.i) - -#define DECL_OLD_PREFIX(DECL) ((DECL)->decl.initial) -#define DECL_NEW_PREFIX(DECL) ((DECL)->decl.result) -#define DECL_POSTFIX(DECL) ((DECL)->decl.arguments) -extern tree ALL_POSTFIX; -#define DECL_SEIZEFILE(DECL) ((DECL)->decl.size) -#define DECL_POSTFIX_ALL(DECL) (DECL_POSTFIX(DECL) == ALL_POSTFIX) -#define DECL_OLD_NAME(DECL) decl_old_name(DECL) -/* For a siezefile name this means restricted usage of this file. - In this case, the USE_SEIZE_FILE directive will not be copied - into the grant file */ -#define CH_USE_SEIZEFILE_RESTRICTED(NODE) TREE_LANG_FLAG_4(NODE) -extern tree decl_old_name PARAMS ((tree)); - -/* for selective granting, mark as already granted */ -#define CH_ALREADY_GRANTED(NODE) TREE_LANG_FLAG_4(NODE) - -/* to store the receiving process of that signal - at definition time */ -#define IDENTIFIER_SIGNAL_DEST(NODE) \ - (((struct lang_identifier *)(NODE))->signal_dest) - -/* indicates a signal with no data */ -#define IDENTIFIER_SIGNAL_DATA(NODE) \ - (((struct lang_identifier *)(NODE))->signal_data) - -/* In identifiers, C uses the following fields in a special way: - TREE_PUBLIC to record that there was a previous local extern decl. - TREE_USED to record that such a decl was used. - TREE_ADDRESSABLE to record that the address of such a decl was used. */ - -/* Nonzero means reject anything that Z.200 Recommendation forbids. */ -extern int pedantic; - -/* the prototypical CHILL INSTANCE type */ -extern tree instance_type_node; - -/* Non-zero if type or expr depends on non-resolved identifier. */ -#define UNSATISFIED(expr) \ - (UNSATISFIED_FLAG (expr) || TREE_CODE (expr) == IDENTIFIER_NODE) -#define UNSATISFIED_FLAG(expr) TREE_LANG_FLAG_3 (expr) - -/* Non-zero in a TREE_LIST if part of a labelled structure tuple. */ -#define TUPLE_NAMED_FIELD(LIST) TREE_LANG_FLAG_1(LIST) - -/* In an ARRAY_TYPE, RECORD_TYPE or UNION_TYPE, nonzero if any component - is read-only. */ -#define TYPE_FIELDS_READONLY(type) TREE_LANG_FLAG_1 (type) - -/* True if TYPE has the "read-only property." */ -#define TYPE_READONLY_PROPERTY(TYPE) \ - (TYPE_READONLY (TYPE) || TYPE_FIELDS_READONLY (TYPE)) - -/* In a RECORD_TYPE or UNION_TYPE, nonzero if any component is volatile. */ -#define C_TYPE_FIELDS_VOLATILE(type) TREE_LANG_FLAG_2 (type) - -/* In a CASE selector expression, nonzero if any alternative specifies (ELSE) for - that selector. */ -#define ELSE_LABEL_SPECIFIED(expr) TREE_LANG_FLAG_2 (expr) - -/* CH_CHARS_TYPE_P(TYPE) is true iff TYPE is a character string type. - - There is no essential difference between a string and a (one-dimensional) - character array, at least for non-varying types. I don't know where - the Chill designers got the idea that it was useful to make a distinction. - (I suspect packing might be involved, but on a byte-adressable machine - we don't care.) Since we want the same code to be generated for - char arrays as for char strings, we use the same representation for - both. But we still need to distinguish them for the sake a Chill - type checking. We do that using TYPE_STRING_FLAG. */ - -#define MARK_AS_STRING_TYPE(TYPE) (TYPE_STRING_FLAG (TYPE) = 1) - -#define CH_CHARS_TYPE_P(type) \ - (TREE_CODE (type) == ARRAY_TYPE && TREE_CODE(TREE_TYPE(type)) == CHAR_TYPE \ - && TYPE_STRING_FLAG (type)) - -/* True if TYPE is CHARS(1). */ -#define CH_CHARS_ONE_P(TYPE) (CH_CHARS_TYPE_P(TYPE) \ - && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (TYPE)))) - -/* True if TYPE is a bitstring (BOOLS or BIT) type. - The TYPE_STRING_FLAG is used to distinguish a bitstring from a powerset. */ - -#define CH_BOOLS_TYPE_P(type) \ - (TREE_CODE (type) == SET_TYPE && TYPE_STRING_FLAG (type)) - -/* True if TYPE is BOOLS(1). */ -#define CH_BOOLS_ONE_P(TYPE) (CH_BOOLS_TYPE_P(TYPE) \ - && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (TYPE)))) - -/* Value is nonzero if TYPE is a CHILL string type. - See CH_CHARS_TYPE_P and CH_BOOLS_TYPE_P above. */ - -#define CH_STRING_TYPE_P(type) \ - ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == SET_TYPE) \ - && TYPE_STRING_FLAG (type)) - -/* In a RECORD_TYPE, a sorted array of the fields of the type. */ -struct lang_type_record -{ - int len; - tree tasking_code_decl; - tree elts[1]; -}; - -struct lang_type -{ - union - { - struct lang_type_record rec; - } foo; -}; - -struct lang_decl -{ - union - { - tree stuff; - } foo; -}; -/* A tasking type's corresponding tasking_code_variable has its - decl pointer in here. */ -#define DECL_TASKING_CODE_DECL(DECL) (DECL_LANG_SPECIFIC(DECL)) - -/* A pointer to an as-yet undefined type. */ -extern tree unknown_type_node; - -/* The CHILL type INT (either integer_type_node or - short_integer_type_node). */ -extern tree chill_integer_type_node; -extern tree chill_unsigned_type_node; - -/* Nonzero for FIELD_DECL node means that this FIELD_DECL is - a member of a union construct. */ -#define TREE_UNION_ELEM(NODE) ((NODE)->decl.regdecl_flag) /* overloaded! */ - -/* Mark which labels are explicitly declared. - These may be shadowed, and may be referenced from nested functions. */ -#define C_DECLARED_LABEL_FLAG(label) TREE_LANG_FLAG_1 (label) - -/* Record whether a type was written with nonconstant size. - Note that TYPE_SIZE may have simplified to a constant. */ -#define C_TYPE_VARIABLE_SIZE(type) TYPE_LANG_FLAG_1 (type) - -#define DECL_WEAK_NAME(DECL) DECL_LANG_FLAG_0(DECL) - -/* These are for FUNCTION_DECLs. */ -#define CH_DECL_GENERAL(DECL) DECL_LANG_FLAG_1(DECL) -#define CH_DECL_SIMPLE(DECL) DECL_LANG_FLAG_2(DECL) -#define CH_DECL_RECURSIVE(DECL) DECL_LANG_FLAG_3(DECL) -#define CH_FUNCTION_SETS_RESULT(DECL) DECL_LANG_FLAG_6(DECL) - -/* For a CONST_DECL, indicates that it was implicitly declared - in a SET mode declaration, and it should not be explicitly granted. */ -#define CH_DECL_ENUM(DECL) DECL_LANG_FLAG_3(DECL) - -/* in a FIELD_DECL use DECL_LANG_FLAG_4 to mark FORBID in a grant-statement */ -#define CH_DECL_FORBID(DECL) DECL_LANG_FLAG_4(DECL) - -/* in an ALIAS_DECL use DECL_LANG_FLAG_4 to mark decl was granted */ -#define CH_DECL_GRANTED(DECL) DECL_LANG_FLAG_4(DECL) - -/* (in a non-FIELD_DECL) note that this decl was hidden by push_module(). */ -#define DECL_HIDDEN_BY_MODULE(decl) DECL_LANG_FLAG_4 (decl) - -/* Record in each node resulting from a binary operator - what operator was specified for it. */ -#define C_EXP_ORIGINAL_CODE(exp) ((enum tree_code) TREE_COMPLEXITY (exp)) - -/* Store a value in that field. */ -#define C_SET_EXP_ORIGINAL_CODE(exp, code) \ - (TREE_COMPLEXITY (exp) = (int)(code)) - -/* Record whether a typedef for type `int' was actually `signed int'. */ -#define C_TYPEDEF_EXPLICITLY_SIGNED(exp) DECL_LANG_FLAG_1 ((exp)) - -/* For FUNCTION_TYPE, a hidden list of types of arguments. The same as - TYPE_ARG_TYPES for functions with prototypes, but created for functions - without prototypes. */ -#define TYPE_ACTUAL_ARG_TYPES(NODE) TYPE_NONCOPIED_PARTS (NODE) - -/* For FUNCTION_TYPE or METHOD_TYPE, a list of the - (names of) exceptions that this type can raise. */ -#define TYPE_RAISES_EXCEPTIONS(NODE) ((NODE)->type.minval) - -/* For UNION_TYPE, the list of tag fields that distinguishes the members. */ -#define TYPE_TAGFIELDS(NODE) ((NODE)->type.minval) - -/* For RECORD_TYPE, the tag values that select it. */ -#define TYPE_TAG_VALUES(NODE) TYPE_BINFO(NODE) - -/* For VAR_DECL, TYPE_DECL, FUNCTION_DECL, indicates that - the DECL was read from a seizefile but not seized */ -#define CH_DECL_NOTDECLARED(DECL) DECL_LANG_FLAG_5(DECL) - -/* For FUNCTION_DECL's, mark as PROCESSEs. */ -#define CH_DECL_PROCESS(DECL) DECL_LANG_FLAG_7(DECL) - -/* For TYPE_DECL's, mark as SIGNALs. */ -#define CH_DECL_SIGNAL(DECL) DECL_LANG_FLAG_7(DECL) - -/* Macros using terminology of the CHILL Blue Book. */ - -/* A class is either Null, All, M-value, M-derived, or M-reference, - where M is some mode (type). */ - -enum ch_class_kind { - CH_ALL_CLASS, CH_NULL_CLASS, - CH_VALUE_CLASS, CH_DERIVED_CLASS, CH_REFERENCE_CLASS -}; - -typedef struct ch_class { - enum ch_class_kind kind; - tree mode; /* The 'M' in M-value, M-derived, or M-reference. */ -} ch_class; - -struct mode_chain; /* Forward reference */ - -#define CH_IS_REFERENCE_MODE(MODE) (TREE_CODE (MODE) == POINTER_TYPE) -#define CH_IS_BOUND_REFERENCE_MODE(MODE) \ - (TREE_CODE (MODE) == POINTER_TYPE && TREE_TYPE(MODE) != void_type_node) -#define CH_IS_PROCEDURE_MODE(MODE) (TREE_CODE (MODE) == FUNCTION_TYPE) -#define CH_IS_INSTANCE_MODE(MODE) (CH_SIMILAR (MODE, instance_type_node)) -#define CH_IS_BUFFER_MODE(MODE) (TYPE_LANG_FLAG_3(MODE)) -#define CH_IS_EVENT_MODE(MODE) (TYPE_LANG_FLAG_4(MODE)) -/* This is TRUE if the set is numbered, which makes pred/succ - unusable */ -#define CH_ENUM_IS_NUMBERED(MODE) (TYPE_LANG_FLAG_5(MODE)) - -/* for ACCESS, and TEXT mode */ -#define CH_IS_ACCESS_MODE(MODE) (TYPE_LANG_FLAG_2(MODE)) -#define CH_IS_TEXT_MODE(MODE) (TYPE_LANG_FLAG_6(MODE)) -#define CH_IS_ASSOCIATION_MODE(MODE) (CH_SIMILAR (MODE, association_type_node)) -#define CH_IS_USAGE_MODE(MODE) (CH_SIMILAR (MODE, usage_type_node)) -#define CH_IS_WHERE_MODE(MODE) (CH_SIMILAR (MODE, where_type_node)) - -/* for RECORD or ARRAY type */ -#define CH_TYPE_NONVALUE_P(MODE) (TYPE_LANG_FLAG_0(MODE)) - -/* CH_NOVELTY is the novelty of a mode: NULL_TREE means the novelty is nil; - otherwise a TYPE_DECL matching the defining occurrence of a newmode. */ -#define CH_NOVELTY(MODE) TYPE_CONTEXT(MODE) - -/* Set the novelty of MODE to NOVELTY (which is assumed to be non-nil). */ -#define SET_CH_NOVELTY(MODE, NOVELTY) (CH_NOVELTY (MODE) = (NOVELTY)) -#define SET_CH_NOVELTY_NONNIL(MODE, NOVELTY) (CH_NOVELTY (MODE) = (NOVELTY)) - -/* CH_DERIVED_FLAG is true the class of EXPR is X-derived for some X. */ -#define CH_DERIVED_FLAG(EXPR) TREE_LANG_FLAG_5(EXPR) - -#define CH_HAS_REFERENCING_PROPERTY(MODE) \ - (TREE_CODE (MODE) == POINTER_TYPE) /* incomplete FIXME! */ - -/* CH_COMPATIBLE(EXPR, MODE) is true if the class of EXPR is - "compatible" with the type MODE. */ -#define CH_COMPATIBLE(EXPR, MODE) chill_compatible(EXPR, MODE) -#define CH_COMPATIBLE_CLASSES(EXPR1, EXPR2) chill_compatible_classes(EXPR1, EXPR2) -#define CH_STATIC_MODE(MODE) 1 /* for now */ -#define CH_SIMILAR(MODE1, MODE2) chill_similar(MODE1, MODE2, 0) -#define CH_ROOT_MODE(MODE) chill_root_mode(MODE) -#define CH_RESULTING_CLASS(C1, C2) chill_resulting_class(C1, C2) -#define CH_ROOT_RESULTING_CLASS(E1, E2) \ - CH_RESULTING_CLASS (chill_expr_class(E1), chill_expr_class(E2)) -#define CH_RESULTING_MODE(MODE1, MODE2) chill_resulting_mode(MODE1, MODE2) -#define CH_V_EQUIVALENT(MODE1, MODE2) (CH_SIMILAR(MODE1, MODE2) \ - && CH_NOVELTY(MODE1) == CH_NOVELTY(MODE2)) -#define CH_EQUIVALENT(MODE1, MODE2) \ - (!integer_zerop (chill_equivalent (MODE1, MODE2, 0))) -#define CH_RESTRICTABLE_TO(MODE1, MODE2) \ - CH_EQUIVALENT(MODE1, MODE2) /* && some more stuff FIXME! */ - -/* pass an OFFSET_TYPE or REFERENCE_TYPE's underlying type to SCALAR_P */ -#define CH_READ_COMPATIBLE(modeM, modeN) chill_read_compatible(modeM, modeN) - -#define SCALAR_P(TYPE) (TYPE != NULL_TREE \ - && (TREE_CODE (TYPE) == INTEGER_TYPE \ - || TREE_CODE (TYPE) == REAL_TYPE \ - || TREE_CODE (TYPE) == ENUMERAL_TYPE \ - || TREE_CODE (TYPE) == BOOLEAN_TYPE \ - || TREE_CODE (TYPE) == CHAR_TYPE \ - || TREE_CODE (TYPE) == POINTER_TYPE \ - || TREE_CODE (TYPE) == INSTANCE_TYPE)) -#define CH_REFERABLE(EXPR) chill_referable(EXPR) -#define CH_LOCATION_P(EXPR) chill_location (EXPR) - -/* Standard named or nameless data types of the C compiler. */ - -/* Nonzero means `$' can be in an identifier. */ - -extern int dollars_in_ident; - -/* Nonzero means allow type mismatches in conditional expressions; - just make their values `void'. */ - -extern int flag_cond_mismatch; - -/* Nonzero means don't recognize the keyword `asm'. */ - -extern int flag_no_asm; - -/* Nonzero means warn about implicit declarations. */ - -extern int warn_implicit; - -/* Nonzero means give string constants the type `const char *' - to get extra warnings from them. These warnings will be too numerous - to be useful, except in thoroughly ANSIfied programs. */ - -extern int warn_write_strings; - -/* Nonzero means warn about sizeof (function) or addition/subtraction - of function pointers. */ - -extern int warn_pointer_arith; - -/* Nonzero means warn for all old-style non-prototype function decls. */ - -extern int warn_strict_prototypes; - -/* Nonzero means warn about multiple (redundant) decls for the same single - variable or function. */ - -extern int warn_redundant_decls; - -/* Nonzero means warn about extern declarations of objects not at - file-scope level and about *all* declarations of functions (whether - extern or static) not at file-scope level. Note that we exclude - implicit function declarations. To get warnings about those, use - -Wimplicit. */ - -extern int warn_nested_externs; - -/* Nonzero means warn about pointer casts that can drop a type qualifier - from the pointer target type. */ - -extern int warn_cast_qual; - -/* Warn about traditional constructs whose meanings changed in ANSI C. */ - -extern int warn_traditional; - -/* Warn about *printf or *scanf format/argument anomalies. */ - -extern int warn_format; - -/* Warn about a subscript that has type char. */ - -extern int warn_char_subscripts; - -/* Warn if a type conversion is done that might have confusing results. */ - -extern int warn_conversion; - -/* Warn if switch labels aren't complete, or are duplicated */ - -extern int warn_switch; - -/* Nonzero means do some things the same way PCC does. */ - -extern int flag_traditional; - -/* Nonzero means warn about suggesting putting in ()'s. */ - -extern int warn_parentheses; - -/* Nonzero means we are reading code that came from a system header file. */ -extern int system_header_p; - -/* One means range checking is on; <= 0 off; -1 permanently off. */ -extern int range_checking; - -/* 0 means empty checking is off, else it is on */ -extern int empty_checking; - -/* 1 means -fruntime-checking specified (default), o means -fno-runtime-checking */ -extern int runtime_checking_flag; - -/* Type node for boolean types. */ - -extern tree boolean_type_node; -extern tree signed_boolean_type_node; - -extern tree string_one_type_node; -extern tree bitstring_one_type_node, bit_zero_node, bit_one_node; - -/* a VOID_TYPE node, packaged in a TREE_LIST. */ - -extern tree void_list_node; - -/* Chill language-specific tree codes. */ -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) SYM, -enum chill_tree_code { - __DUMMY = LAST_AND_UNUSED_TREE_CODE, -#include "ch-tree.def" - LAST_CHILL_TREE_CODE -}; -#undef DEFTREECODE - -enum chill_built_in_function -{ - DUMMY_FIRST_CHILL_BUILT_IN = END_BUILTINS, - - BUILT_IN_CH_ABS, - BUILT_IN_ABSTIME, - BUILT_IN_ADDR, - BUILT_IN_ALLOCATE, - BUILT_IN_ALLOCATE_GLOBAL_MEMORY, - BUILT_IN_ALLOCATE_MEMORY, - BUILT_IN_ARCCOS, - BUILT_IN_ARCSIN, - BUILT_IN_ARCTAN, - BUILT_IN_ASSOCIATE, - BUILT_IN_CARD, - BUILT_IN_CONNECT, - BUILT_IN_COPY_NUMBER, - BUILT_IN_CH_COS, - BUILT_IN_CREATE, - BUILT_IN_DAYS, - BUILT_IN_CH_DELETE, - BUILT_IN_DESCR, - BUILT_IN_DISCONNECT, - BUILT_IN_DISSOCIATE, - BUILT_IN_EOLN, - BUILT_IN_EXP, - BUILT_IN_EXPIRED, - BUILT_IN_EXISTING, - BUILT_IN_GEN_CODE, - BUILT_IN_GEN_INST, - BUILT_IN_GEN_PTYPE, - BUILT_IN_GETASSOCIATION, - BUILT_IN_GETSTACK, - BUILT_IN_GETTEXTACCESS, - BUILT_IN_GETTEXTINDEX, - BUILT_IN_GETTEXTRECORD, - BUILT_IN_GETUSAGE, - BUILT_IN_HOURS, - BUILT_IN_INDEXABLE, - BUILT_IN_INTTIME, - BUILT_IN_ISASSOCIATED, - BUILT_IN_LENGTH, - BUILT_IN_LOG, - BUILT_IN_LOWER, - BUILT_IN_LN, - BUILT_IN_MAX, - BUILT_IN_MILLISECS, - BUILT_IN_MIN, - BUILT_IN_MINUTES, - BUILT_IN_MODIFY, - BUILT_IN_NUM, - BUILT_IN_OUTOFFILE, - BUILT_IN_PRED, - BUILT_IN_PROC_TYPE, - BUILT_IN_QUEUE_LENGTH, - BUILT_IN_READABLE, - BUILT_IN_READRECORD, - BUILT_IN_READTEXT, - BUILT_IN_RETURN_MEMORY, - BUILT_IN_SECS, - BUILT_IN_SETTEXTACCESS, - BUILT_IN_SETTEXTINDEX, - BUILT_IN_SETTEXTRECORD, - BUILT_IN_SEQUENCIBLE, - BUILT_IN_SIZE, - BUILT_IN_SQRT, - BUILT_IN_SUCC, - BUILT_IN_CH_SIN, - BUILT_IN_TAN, - BUILT_IN_TRUNC, - BUILT_IN_TERMINATE, - BUILT_IN_UPPER, - BUILT_IN_VARIABLE, - BUILT_IN_WAIT, - BUILT_IN_WRITEABLE, - BUILT_IN_WRITERECORD, - BUILT_IN_WRITETEXT, -}; - -/* name of additional (compiler generated) arguments for - functions which may propagate exceptions. */ -#define CALLER_FILE "__CALLER_FILE__" -#define CALLER_LINE "__CALLER_LINE__" - -/* field-name strings for the fields of the structure which - represents a CHILL VARYING array. The angle brackets assure - that no user-defined structure can match this one. - This field holds, at runtime, the current length of the - array, in UNITS, not including the length itself. It's an - integer_type_node */ -#define VAR_LENGTH "__var_length" - -/* This field is statically allocated to the user-defined - size, but contains valid array entries starting from the - first allocated space, proceeding for VAR_LENGTH bytes. - There are no holes in the data; the user isn't allowed - to store beyond the first available entry. */ - -#define VAR_DATA "__var_data" - -/* This field is the name of the array, encapsulated in the CHILL - structure used to represent an array type parameter. */ -/*#define ARRAY_DATA "__array_data"*/ - -/* The CHILL INSTANCE type is composed of two CHILL integer - fields, the process_type (set by the user with the - process_type compiler directive, and the proc_copy field, - which is set by the start_process call's first parameter. */ -#define INS_PTYPE "__proc_type" -#define INS_COPY "__proc_copy" - -/* This is the actual array type inside the VARYING struct */ -#define CH_VARYING_ARRAY_TYPE(TYPE) TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (TYPE))) - -/* Identifiers which hold the VAR_LENGTH and VAR_DATA strings. */ -extern tree var_length_id; -extern tree var_data_id; - -/* A RANGE_EXPR representing an ELSE in a case label. */ -extern tree case_else_node; - -#if 0 /* changed to function */ -/* return non-zero if type is a compiler-generated VARYING array record */ -#define CH_VARYING_TYPE_P(type) (TREE_CODE (type) == RECORD_TYPE && \ - DECL_NAME (TYPE_FIELDS (type)) == \ - get_identifier (VAR_LENGTH) && \ - DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) == \ - get_identifier (VAR_DATA) && \ - TREE_CHAIN (CH_VARYING_ARRAY_TYPE (type)) == NULL_TREE) - -#endif - -/* in c-aux-info.c */ -extern void gen_aux_info_record PARAMS ((tree, int, int, int)); - -/* in c-common.c */ -extern tree combine_strings PARAMS ((tree)); -extern void constant_expression_warning PARAMS ((tree)); -extern void decl_attributes PARAMS ((tree, tree)); -extern void declare_function_name PARAMS ((void)); -#ifdef BUFSIZ -extern char *get_directive_line PARAMS ((FILE *)); -#endif -extern tree shorten_compare PARAMS ((tree *, tree *, tree *, enum tree_code *)); - -/* in c-decl.c */ -extern tree wchar_type_node, signed_wchar_type_node, unsigned_wchar_type_node; -extern tree default_function_type; -extern tree double_ftype_double, double_ftype_double_double; -extern tree int_ftype_int, long_ftype_long; -extern tree void_ftype_ptr_ptr_int, int_ftype_ptr_ptr_int; -extern tree void_ftype_ptr_int_int, string_ftype_ptr_ptr; -extern tree int_ftype_string_string, int_ftype_cptr_cptr_sizet; -/* Nodes for boolean constants TRUE and FALSE */ -extern tree boolean_true_node, boolean_false_node; - -extern tree global_function_decl; - -/* in except.c */ -extern void except_init_pass_2 PARAMS ((void)); -extern void push_handler PARAMS ((void)); -extern void pop_handler PARAMS ((int)); - -/* in ch-loop.c */ -extern int flag_local_loop_counter; -extern void push_loop_block PARAMS ((void)); -extern void pop_loop_block PARAMS ((void)); -extern void build_loop_start PARAMS ((tree)); -extern void top_loop_end_check PARAMS ((tree)); -extern void build_loop_end PARAMS ((void)); -extern void build_loop_iterator PARAMS ((tree, tree, tree, tree, int, int, int)); -extern void begin_loop_scope PARAMS ((void)); -extern void end_loop_scope PARAMS ((tree)); -extern void nonvalue_begin_loop_scope PARAMS ((void)); -extern void nonvalue_end_loop_scope PARAMS ((void)); - -extern tree build_enumerator PARAMS ((tree, tree)); -extern tree c_build_type_variant PARAMS ((tree, int, int)); -extern int c_decode_option PARAMS ((int, char **)); -extern void c_mark_varargs PARAMS ((void)); -extern void clear_parm_order PARAMS ((void)); -extern tree combine_parm_decls PARAMS ((tree, tree, int)); -extern int complete_array_type PARAMS ((tree, tree, int)); -extern void declare_parm_level PARAMS ((int)); -extern tree define_label PARAMS ((const char *, int, tree)); -extern void delete_block PARAMS ((tree)); -extern void finish_decl PARAMS ((tree)); -extern tree finish_enum PARAMS ((tree, tree)); -extern void finish_function PARAMS ((int)); -extern tree finish_struct PARAMS ((tree, tree)); -extern tree get_parm_decls PARAMS ((void)); -extern tree get_parm_info PARAMS ((int)); -extern tree getdecls PARAMS ((void)); -extern tree gettags PARAMS ((void)); -extern int global_bindings_p PARAMS ((void)); -extern tree grokfield PARAMS ((char *, int, tree, tree, tree)); -extern tree groktypename PARAMS ((tree)); -extern tree groktypename_in_parm_context PARAMS ((tree)); -extern tree implicitly_declare PARAMS ((tree)); -extern void init_decl_processing PARAMS ((void)); -extern void insert_block PARAMS ((tree)); -extern void keep_next_level PARAMS ((void)); -extern int kept_level_p PARAMS ((void)); -extern tree lookup_label PARAMS ((tree)); -extern tree lookup_name PARAMS ((tree)); -extern tree maybe_build_cleanup PARAMS ((tree)); -extern void parmlist_tags_warning PARAMS ((void)); -extern void pending_xref_error PARAMS ((void)); -extern void pop_chill_function_context PARAMS ((void)); -extern tree poplevel PARAMS ((int, int, int)); -#ifdef BUFSIZ -extern void print_lang_decl PARAMS ((FILE *,tree, int)); -extern void print_lang_identifier PARAMS ((FILE *,tree, int)); -extern void print_lang_type PARAMS ((FILE *,tree, int)); -#endif -extern void push_chill_function_context PARAMS ((void)); -extern void push_parm_decl PARAMS ((tree)); -extern tree pushdecl PARAMS ((tree)); -extern tree pushdecl_top_level PARAMS ((tree)); -extern void pushlevel PARAMS ((int)); -extern void set_block PARAMS ((tree)); -extern tree shadow_label PARAMS ((tree)); -extern void shadow_record_fields PARAMS ((tree)); -extern void shadow_tag PARAMS ((tree)); -extern void shadow_tag_warned PARAMS ((tree, int)); -extern tree start_enum PARAMS ((tree)); -extern int start_function PARAMS ((tree, tree, int)); -extern tree start_decl PARAMS ((tree, tree, int)); -extern tree start_struct PARAMS ((enum tree_code, tree)); -extern void store_parm_decls PARAMS ((void)); -extern tree xref_tag PARAMS ((enum tree_code, tree)); - -/* in c-typeck.c */ -extern tree build_array_ref PARAMS ((tree, tree)); -extern tree build_c_cast PARAMS ((tree, tree)); -extern tree build_chill_modify_expr PARAMS ((tree, tree)); -extern tree build_chill_component_ref PARAMS ((tree, tree)); -extern tree build_component_ref PARAMS ((tree, tree)); -extern tree build_compound_expr PARAMS ((tree)); -extern tree build_conditional_expr PARAMS ((tree, tree, tree)); -extern tree build_function_call PARAMS ((tree, tree)); -extern tree build_indirect_ref PARAMS ((tree, char *)); -extern tree build_modify_expr PARAMS ((tree, enum tree_code, tree)); -extern tree build_unary_op PARAMS ((enum tree_code, tree, int)); -extern tree c_alignof PARAMS ((tree)); -extern tree c_alignof_expr PARAMS ((tree)); -extern void c_expand_asm_operands PARAMS ((tree, tree, tree, tree, int, char *, int)); -extern tree c_sizeof PARAMS ((tree)); -extern void c_expand_return PARAMS ((tree)); -extern tree c_expand_start_case PARAMS ((tree)); -extern tree common_type PARAMS ((tree, tree)); -extern tree copy_novelty PARAMS ((tree, tree)); -extern tree default_conversion PARAMS ((tree)); -extern void finish_init PARAMS ((void)); -extern tree parser_build_binary_op PARAMS ((enum tree_code, tree, tree)); -extern tree pop_init_level PARAMS ((int)); -extern void process_init_default PARAMS ((tree)); -extern void process_init_element PARAMS ((tree)); -extern void push_init_level PARAMS ((int)); -extern void really_start_incremental_init PARAMS ((tree)); -extern void set_init_index PARAMS ((tree, tree)); -extern void set_init_label PARAMS ((tree)); -extern void start_init PARAMS ((tree, tree, int)); -extern void store_init_value PARAMS ((tree, tree)); -extern tree valid_array_index_p PARAMS ((tree, tree, const char *, int)); - -/* in ch/actions.c */ -extern int grant_only_flag; -extern void allocate_lang_decl PARAMS ((tree)); -extern tree build_chill_abs PARAMS ((tree)); -extern tree build_chill_array_ref_1 PARAMS ((tree, tree)); -extern tree build_chill_array_ref PARAMS ((tree, tree)); -extern tree build_chill_bin_type PARAMS ((tree)); -extern tree build_chill_binary_op PARAMS ((enum chill_tree_code, tree, tree)); -extern tree build_chill_card PARAMS ((tree)); -extern tree build_chill_case_expr PARAMS ((tree, tree, tree)); -extern tree build_cause_exception PARAMS ((tree, int)); -extern tree build_chill_exception_decl PARAMS ((const char *)); -extern tree build_chill_function_call PARAMS ((tree, tree)); -extern tree build_chill_length PARAMS ((tree)); -extern tree build_chill_indirect_ref PARAMS ((tree, tree, int)); -extern tree build_chill_lower PARAMS ((tree)); -extern tree build_chill_max PARAMS ((tree)); -extern tree build_chill_min PARAMS ((tree)); -extern tree build_chill_num PARAMS ((tree)); -extern tree build_chill_repetition_op PARAMS ((tree, tree)); -extern tree build_chill_sizeof PARAMS ((tree)); -extern tree build_chill_slice PARAMS ((tree, tree, tree)); -extern tree build_chill_slice_with_range PARAMS ((tree, tree, tree)); -extern tree build_chill_slice_with_length PARAMS ((tree, tree, tree)); -extern tree build_chill_struct_type PARAMS ((tree)); -extern tree build_chill_unary_op PARAMS ((enum chill_tree_code, tree)); -extern tree build_chill_upper PARAMS ((tree)); -extern tree build_exception_variant PARAMS ((tree, tree)); -extern tree build_generalized_call PARAMS ((tree, tree)); -extern tree build_lang_decl PARAMS ((enum chill_tree_code, tree, tree)); -extern tree build_rts_call PARAMS ((const char *, tree, tree)); -extern tree build_varying_struct PARAMS ((tree)); -extern void chill_check_decl PARAMS ((tree)); -extern tree chill_convert_for_assignment PARAMS ((tree, tree, const char *)); -extern void chill_expand_return PARAMS ((tree, int)); -extern void chill_expand_result PARAMS ((tree, int)); -extern void chill_handle_case_default PARAMS ((void)); -extern void chill_handle_case_label PARAMS ((tree, tree)); -extern int chill_varying_string_type_p PARAMS ((tree)); -extern int chill_varying_type_p PARAMS ((tree)); -extern int ch_singleton_set PARAMS ((tree)); -extern tree check_expression PARAMS ((tree, tree, tree)); -extern void check_missing_cases PARAMS ((tree)); -extern tree check_non_null PARAMS ((tree)); -extern tree check_range PARAMS ((tree, tree, tree,tree)); -extern void cond_type_range_exception PARAMS ((tree)); -extern void expand_cause_exception PARAMS ((tree)); -extern tree finish_chill_binary_op PARAMS ((tree)); -extern tree finish_chill_unary_op PARAMS ((tree)); -extern tree high_domain_value PARAMS ((tree)); -extern tree low_domain_value PARAMS ((tree)); -extern tree maybe_array_ref PARAMS ((tree, tree)); -extern void maybe_chill_check_decl PARAMS ((tree)); -extern tree powersetlen PARAMS ((tree)); -extern tree test_range PARAMS ((tree, tree, tree)); -/* in ch/convert.c */ -extern tree build_array_type_for_scalar PARAMS ((tree)); -extern tree convert PARAMS ((tree, tree)); -extern tree convert_from_reference PARAMS ((tree)); -extern tree convert_to_class PARAMS ((ch_class, tree)); -extern const char *display_int_cst PARAMS ((tree)); - -/* in ch/decl.c */ -extern tree build_enumerator PARAMS ((tree, tree)); -extern tree chill_munge_params PARAMS ((tree, tree, tree)); -extern tree build_chill_function_type PARAMS ((tree, tree, tree, tree)); -extern tree decl_temp1 PARAMS ((tree, tree, int, tree, int, int)); -extern void do_based_decls PARAMS ((tree, tree, tree)); -extern void do_chill_outparms PARAMS ((void)); -extern tree do_decl PARAMS ((tree, tree, int, int, tree, int)); -extern void do_decls PARAMS ((tree, tree, int, int, tree, int)); -extern void expand_chill_outparms PARAMS ((void)); -extern void find_granted_decls PARAMS ((void)); -extern void finish_chill_function PARAMS ((void)); -extern tree finish_enum PARAMS ((tree, tree)); -extern void fixup_chill_parms PARAMS ((tree)); -extern void finish_outer_function PARAMS ((void)); -extern unsigned get_type_precision PARAMS ((tree, tree)); -extern tree grok_chill_fixedfields PARAMS ((tree, tree, tree)); -extern tree grok_chill_variantdefs PARAMS ((tree, tree, tree)); -extern void layout_enum PARAMS ((tree)); -/* extern tree lookup_remembered_decl PARAMS ((HOST_WIDE_INT, tree)); */ -extern void lookup_and_expand_goto PARAMS ((tree)); -extern tree lookup_tag_fields PARAMS ((tree, tree)); -extern void lookup_and_handle_exit PARAMS ((tree)); -extern tree massage_param_node PARAMS ((tree, tree)); -extern void pop_module PARAMS ((void)); -extern void print_mode PARAMS ((tree)); -extern tree push_extern_function PARAMS ((tree, tree, tree, tree, int)); -extern void push_extern_process PARAMS ((tree, tree, tree, int)); -extern void push_extern_signal PARAMS ((tree, tree, tree)); -extern void push_granted PARAMS ((tree, tree)); -extern tree push_modedef PARAMS ((tree, tree, int)); -extern tree push_module PARAMS ((tree, int)); -extern void push_parms PARAMS ((tree, tree, tree)); -extern void push_syndecl PARAMS ((tree, tree, tree)); -extern int result_never_set; -extern void save_expr_under_name PARAMS ((tree, tree)); -extern tree set_module_name PARAMS ((tree)); -extern int start_chill_function PARAMS ((tree, tree, tree, tree, tree)); -extern void start_outer_function PARAMS ((void)); -extern void switch_to_pass_2 PARAMS ((void)); - -/* in ch/except.c */ -extern void chill_check_no_handlers PARAMS ((void)); -extern void chill_finish_on PARAMS ((void)); -extern void chill_handle_on_labels PARAMS ((tree)); -extern void chill_reraise_exceptions PARAMS ((tree)); -extern void chill_start_default_handler PARAMS ((void)); -extern void chill_start_on PARAMS ((void)); -extern void expand_goto_except_cleanup PARAMS ((int)); -extern int is_handled PARAMS ((tree)); - -/* in ch/expr.c */ -extern tree build_chill_addr_expr PARAMS ((tree, const char *)); -extern tree build_chill_arrow_expr PARAMS ((tree, int)); -extern tree build_component_ref PARAMS ((tree, tree)); -extern tree build_chill_compound_expr PARAMS ((tree)); -extern tree build_chill_descr PARAMS ((tree)); -extern void build_chill_descr_type PARAMS ((void)); -extern void build_chill_inttime_type PARAMS ((void)); -extern tree build_compare_expr PARAMS ((enum tree_code, - tree, tree)); -extern tree build_compare_discrete_expr PARAMS ((enum tree_code, - tree, tree)); -extern tree check_case_selector PARAMS ((tree)); -extern tree check_case_selector_list PARAMS ((tree)); -extern tree check_have_mode PARAMS ((tree, const char *)); -extern void init_chill_expand PARAMS ((void)); -extern void chill_expand_assignment PARAMS ((tree, enum chill_tree_code, tree)); -extern void expand_assignment_action PARAMS ((tree, enum chill_tree_code, tree)); -extern int compare_int_csts PARAMS ((enum chill_tree_code, - tree, tree)); -extern void expand_varying_length_assignment PARAMS ((tree, tree)); -extern tree force_addr_of PARAMS ((tree)); -extern tree resolve_component_ref PARAMS ((tree)); -extern tree truthvalue_conversion PARAMS ((tree)); -extern tree varying_to_slice PARAMS ((tree)); - -/* in ch/grant.c */ -extern void chill_finish_compile PARAMS ((void)); -extern void chill_seize PARAMS ((tree, tree, tree)); -extern void start_outer_function PARAMS ((void)); -extern void finish_chill_seize PARAMS ((tree)); -extern void chill_grant PARAMS ((tree,tree, tree, tree)); -extern void set_default_grant_file PARAMS ((void)); -extern void set_identifier_size PARAMS ((int)); -extern void write_grant_file PARAMS ((void)); -extern void write_spec_module PARAMS ((tree, tree)); - -/* in ch/lang.c */ -extern tree string_index_type_dummy; -extern int flag_old_strings; -extern void GNU_xref_begin PARAMS ((void)); -extern void GNU_xref_end PARAMS ((void)); -extern tree build_chill_array_type PARAMS ((tree, tree, int, tree)); -extern tree build_chill_struct_type PARAMS ((tree)); -extern tree build_chill_pointer_type PARAMS ((tree)); -extern tree build_chill_range_type PARAMS ((tree, tree, tree)); -extern tree build_chill_reference_type PARAMS ((tree)); -extern tree build_simple_array_type PARAMS ((tree, tree, tree)); -extern tree const_expr PARAMS ((tree)); -extern tree get_identifier3 PARAMS ((const char *, const char *, const char *)); -extern tree layout_chill_array_type PARAMS ((tree)); -extern tree layout_chill_range_type PARAMS ((tree, int)); -extern tree layout_chill_pointer_type PARAMS ((tree)); -extern tree layout_chill_struct_type PARAMS ((tree)); -extern tree layout_chill_variants PARAMS ((tree)); -extern tree layout_powerset_type PARAMS ((tree)); -extern tree lookup_interface PARAMS ((tree)); -extern tree maybe_building_objc_message_expr PARAMS ((void)); -extern void maybe_objc_check_decl PARAMS ((tree)); -extern int maybe_objc_comptypes PARAMS ((tree, tree)); -extern int recognize_objc_keyword PARAMS ((void)); - -/* in ch/lex.l */ -extern tree use_seizefile_name; -extern tree current_seizefile_name; -extern tree build_chill_string PARAMS ((int, const char *)); -extern int check_newline PARAMS ((void)); -extern tree get_chill_filename PARAMS ((void)); -extern tree get_chill_linenumber PARAMS ((void)); -extern void register_seize_path PARAMS ((const char *)); -extern void reinit_parse_for_function PARAMS ((void)); -extern void mark_use_seizefile_written PARAMS ((tree)); - -/* in ch/loop.c */ -extern void begin_chill_loop PARAMS ((tree, tree)); -extern tree build_chill_iterator PARAMS ((tree, tree, tree, int, int, int)); -extern void end_chill_loop PARAMS ((void)); -extern tree get_unique_identifier PARAMS ((const char *)); - -/* in ch/inout.c */ -extern tree access_recordmode PARAMS ((tree)); -extern void invalidate_access_recordmode PARAMS ((tree)); -extern tree access_indexmode PARAMS ((tree)); -extern tree access_dynamic PARAMS ((tree)); -extern tree association_init_value; -extern tree association_type_node; -extern tree build_access_mode PARAMS ((tree, tree, int)); -extern tree build_chill_associate PARAMS ((tree, tree, tree)); -extern tree build_chill_connect PARAMS ((tree, tree, tree, tree)); -extern tree build_chill_create PARAMS ((tree)); -extern tree build_chill_delete PARAMS ((tree)); -extern tree build_chill_disconnect PARAMS ((tree)); -extern tree build_chill_dissociate PARAMS ((tree)); -extern tree build_chill_eoln PARAMS ((tree)); -extern tree build_chill_existing PARAMS ((tree)); -extern tree build_chill_gettextaccess PARAMS ((tree)); -extern tree build_chill_getassociation PARAMS ((tree)); -extern tree build_chill_gettextindex PARAMS ((tree)); -extern tree build_chill_gettextrecord PARAMS ((tree)); -extern tree build_chill_getusage PARAMS ((tree)); -extern tree build_chill_indexable PARAMS ((tree)); -extern tree build_chill_isassociated PARAMS ((tree)); -extern tree build_chill_modify PARAMS ((tree, tree)); -extern tree build_chill_outoffile PARAMS ((tree)); -extern tree build_chill_readable PARAMS ((tree)); -extern tree build_chill_readrecord PARAMS ((tree, tree)); -extern tree build_chill_readtext PARAMS ((tree, tree)); -extern tree build_chill_sequencible PARAMS ((tree)); -extern tree build_chill_settextaccess PARAMS ((tree, tree)); -extern tree build_chill_settextindex PARAMS ((tree, tree)); -extern tree build_chill_settextrecord PARAMS ((tree, tree)); -extern tree build_chill_variable PARAMS ((tree)); -extern tree build_chill_writeable PARAMS ((tree)); -extern tree build_chill_writerecord PARAMS ((tree, tree)); -extern tree build_chill_writetext PARAMS ((tree, tree)); -extern void build_enum_tables PARAMS ((void)); -extern tree build_text_mode PARAMS ((tree, tree, int)); -extern tree check_text_length PARAMS ((tree)); -extern void init_access_location PARAMS ((tree, tree)); -extern void init_text_location PARAMS ((tree, tree)); -extern void inout_init PARAMS ((void)); -extern tree text_dynamic PARAMS ((tree)); -extern tree text_indexmode PARAMS ((tree)); -extern tree text_length PARAMS ((tree)); -extern tree usage_type_node; -extern tree where_type_node; - -/* in ch/parse.c */ -extern tree get_type_of PARAMS ((tree)); -extern void set_yydebug PARAMS ((int)); -extern void yyerror PARAMS ((char *)); -extern int pass; -extern int ignoring; -extern int seen_action; -extern int build_constructor; -extern void possibly_define_exit_label PARAMS ((tree)); -extern void to_global_binding_level PARAMS ((void)); - -/* in ch/satisfy.c */ -extern tree satisfy_decl PARAMS ((tree, int)); - -/* in ch/tasking.c */ -extern void add_taskstuff_to_list PARAMS ((tree, const char *, tree, tree, tree)); -extern void process_buffer_decls PARAMS ((tree, tree, int)); -extern tree buffer_element_mode PARAMS ((tree)); -extern void invalidate_buffer_element_mode PARAMS ((tree)); -extern tree build_buffer_descriptor PARAMS ((tree, tree, tree)); -extern tree build_buffer_type PARAMS ((tree, tree)); -extern void build_delay_action PARAMS ((tree, tree)); -extern tree build_delay_case_start PARAMS ((tree, tree)); -extern void build_delay_case_end PARAMS ((tree)); -extern void build_delay_case_label PARAMS ((tree, int)); -extern tree build_event_type PARAMS ((tree)); -extern void build_receive_case_end PARAMS ((tree, tree)); -extern int build_receive_case_if_generated PARAMS ((void)); -extern tree build_receive_case_label PARAMS ((tree, tree)); -extern tree build_receive_case_start PARAMS ((tree)); -extern void expand_continue_event PARAMS ((tree)); -extern void expand_send_buffer PARAMS ((tree, tree, tree, tree, tree)); -extern void expand_send_signal PARAMS ((tree, tree, tree, tree, tree)); -extern void build_start_process PARAMS ((tree, tree, tree, tree)); -extern tree build_copy_number PARAMS ((tree)); -extern tree build_gen_code PARAMS ((tree)); -extern tree build_gen_inst PARAMS ((tree, tree)); -extern tree build_gen_ptype PARAMS ((tree)); -extern void build_instance_type PARAMS ((void)); -extern tree build_process_header PARAMS ((tree, tree)); -extern void build_process_wrapper PARAMS ((tree, tree)); -extern tree build_proc_type PARAMS ((tree)); -extern tree build_queue_length PARAMS ((tree)); -extern tree build_signal_descriptor PARAMS ((tree, tree)); -extern tree build_signal_struct_type PARAMS ((tree, tree, tree)); -extern tree build_tasking_struct PARAMS ((void)); -extern tree chill_taskingcode_type_node; -extern tree check_queue_size PARAMS ((tree)); -extern tree generate_tasking_code_variable PARAMS ((tree, tree *, int)); -extern tree get_signal_type_name PARAMS ((tree)); -extern tree get_struct_type_name PARAMS ((tree)); -extern tree get_tasking_code_name PARAMS ((tree)); -extern tree make_process_struct PARAMS ((tree, tree)); -extern tree make_signal_struct PARAMS ((tree)); -extern tree max_queue_size PARAMS ((tree)); -extern void tasking_init PARAMS ((void)); -extern void tasking_registry PARAMS ((void)); -extern void tasking_setup PARAMS ((void)); - -/* in ch/timing.c */ -extern tree abs_timing_type_node; -extern tree after_stack; -extern void build_after_end PARAMS ((void)); -extern void build_after_start PARAMS ((tree, int)); -extern void build_after_timeout_start PARAMS ((void)); -extern void build_at_action PARAMS ((tree)); -extern void build_cycle_end PARAMS ((tree)); -extern tree build_cycle_start PARAMS ((tree)); -extern tree build_timeout_preface PARAMS ((void)); -extern void build_timesupervised_call PARAMS ((tree, tree)); -extern tree duration_timing_type_node; -extern void timing_init PARAMS ((void)); - -/* in ch/tree.c */ -extern tree build_alias_decl PARAMS ((tree, tree, tree)); -extern tree build_bitstring_type PARAMS ((tree)); -extern tree build_powerset_type PARAMS ((tree)); -extern tree build_string_type PARAMS ((tree, tree)); -extern tree decl_check_rename PARAMS ((tree, tree)); -extern tree discrete_count PARAMS ((tree)); -extern int list_length PARAMS ((tree)); -extern tree munge_exit_label PARAMS ((tree)); -extern tree save_if_needed PARAMS ((tree)); - -/* in ch/typeck.c */ -extern tree build_array_from_set PARAMS ((tree)); -extern tree build_chill_array_ref PARAMS ((tree, tree)); -extern tree build_chill_bitref PARAMS ((tree, tree)); -extern tree build_chill_cast PARAMS ((tree, tree)); -extern tree chill_equivalent PARAMS ((tree, tree, struct mode_chain*)); -extern tree build_init_struct PARAMS ((void)); -extern tree build_readonly_type PARAMS ((tree)); -extern int chill_compatible PARAMS ((tree, tree)); -extern int chill_compatible_classes PARAMS ((tree, tree)); -extern ch_class chill_expr_class PARAMS ((tree)); -extern tree chill_give_type_to_expr PARAMS ((tree, tree)); -extern tree chill_expand_tuple PARAMS ((tree, tree)); -extern ch_class chill_expr_class PARAMS ((tree)); -extern int chill_location PARAMS ((tree)); -extern tree chill_max_vary_array_index PARAMS ((tree)); -extern int chill_read_compatible PARAMS ((tree, tree)); -extern int chill_referable PARAMS ((tree)); -extern tree chill_root_mode PARAMS ((tree)); -extern ch_class chill_resulting_class PARAMS ((ch_class, ch_class)); -extern tree chill_resulting_mode PARAMS ((tree, tree)); -extern int chill_similar PARAMS ((tree, tree, struct mode_chain*)); -extern int discrete_type_p PARAMS ((tree)); -extern tree convert_to_discrete PARAMS ((tree)); -extern tree smash_dummy_type PARAMS ((tree)); -extern tree string_assignment_condition PARAMS ((tree, tree)); -extern tree type_for_mode PARAMS ((enum machine_mode, int)); -extern tree type_for_size PARAMS ((unsigned, int)); -extern int valid_array_index PARAMS ((tree, tree)); -extern void validate_varying_array_ref PARAMS ((tree, tree)); - -/* in toplev.c */ -extern void announce_function PARAMS ((tree)); -extern int floor_log2_wide PARAMS ((unsigned HOST_WIDE_INT)); -extern void rest_of_compilation PARAMS ((tree)); - -/* in varasm.c */ -extern void make_function_rtl PARAMS ((tree)); - -/* in ???? */ -extern void init_iterators PARAMS ((void)); -extern int mark_addressable PARAMS ((tree)); -extern tree chill_result_decl; - -#ifndef SET_WORD_SIZE -#define SET_WORD_SIZE BITS_PER_WORD -#endif - -struct module -{ - struct module *next_module; /* Next module, in order of their beginning. */ - struct module *prev_module; /* The surrounding module, if any. */ - tree name; - tree prefix_name; /* Usually same as name, expect for nested modules. - Used to generate DECL_ASSEMBLER_NAMEs. */ - /* procedure_seen indicates a procedure or process was declared. - After this, no SEIZE, DCL, SYN, NEWMODE, SYNMODE statement is allowed */ - int procedure_seen; - int is_spec_module; - - /* The value of current_nesting_level inside the module. */ - int nesting_level; - - /* A chain contain one ALIAS_DECL for each 'GRANT foo->bar'. - The DECL_NAME is get_identifier("bar"), and the DECL_INITIAL - is get_identifier("bar"). Only used in pass 1. */ - tree granted_decls; -}; - -extern struct module *current_module; - -/* fold a tree to constant as much as possible */ -extern tree deep_fold PARAMS ((tree)); - -extern const char * const gnuchill_version; - -#endif diff --git a/gcc/ch/chill.brochure b/gcc/ch/chill.brochure deleted file mode 100644 index 44301edff92..00000000000 --- a/gcc/ch/chill.brochure +++ /dev/null @@ -1,252 +0,0 @@ - GNU CHILL: A Complete CHILL Implementation - -CHILL (the CCITT High Level Language) is a strongly-typed, block -structured language designed primarily for the implementation of large -and complex embedded systems. Tens of millions of lines of CHILL code -exist, and about 15,000 programmers world-wide use CHILL. Many -central-office telephone switching systems use CHILL for their control -software. - -CHILL was designed to - - - enhance reliability and run time efficiency by means of extensive - compile time checking; - - provide sufficient flexibility and power to encompass the required - range of applications and to exploit a variety of hardware; - _ provide facilities that encourage piecewise and modular development - of large systems; - - cater to real-time implementations by providing built-in concurrency - and time supervision primitives; - - permit the generation of highly efficient object code; - - facilitate ease of use and a short learning curve. - -CHILL is specified in the "Blue Book": - CCITT High Level Language (CHILL) Recommendation Z.200 - ISO/IEC 9496, Geneva 1989 ISBN 92-61-03801-8 - -Cygnus Support has completed the first level implementation of the -GNU CHILL compiler. Our compiler now supports the core features of -the CHILL language. Our goal is a fully retargetable, complete -implementation of the Z.200 specification. The next phase of -implementation will include: - - . a minimal real-time kernel for demonstration use - . more rigorous type checking - . retargetable input/output - . interprocess communications - . fully compliant exception handling. - -The State of the Implementation - -The GNU CHILL compiler is in early beta state, performing correct -compilation and execution of correctly coded programs. Like most -CHILL compilers, the GNU compiler implements a large subset of the -language (as described below). - -Since it uses the same compiler back-ends as the GNU C and C++ -compilers, GNU CHILL is almost instantly available on all -platforms supported by GNU C, including the following: - - m680xx, i960, i80x86, AMD29K, R3000, R4000, SPARClite, - Hitachi H8 and SH families, Z8001/2 - -It has been specifically tested under SunOS on SPARCs and under -SCO Unix on 80386s. - -All of the GCC optimizations apply to CHILL as well, including -function inlining, dead code elimination, jump-to-jump elimination, -cross-jumping (tail-merging), constant propagation, common -subexpression elimination, loop-invariant code motion, strength -reduction, loop unrolling, induction variable elimination, flow -analysis (copy propagation, dead store elimination and elimination -of unreachable code), dataflow-driven instruction scheduling, and -many others. - -I/O statements are parsed. The anticipated timeframe for I/O code -generation is Q1 1994. - -What's Next - -The multi-tasking functions require a small real time kernel. -A free implementation of such a kernel is not yet available. -We plan to offer a productized P-threads interface in Q2 1994. -Other runtime functions involving strings and powersets are -working. - -GDB, the GNU Debugger, has been modified to provide simple CHILL -support. Some CHILL expressions are not yet recognized. - -For those who aren't familiar with CHILL, here's a small but -useful example program: - --- --- Convert binary integers to decimal-coded ASCII string --- -vary1: MODULE - - -- include declarations so we can output the test results - <> USE_SEIZE_FILE 'chprintf.grt' <> - SEIZE chprintf; - - -- create a new name for the CHAR array mode - SYNMODE dec_string = CHAR (6) VARYING; - - int_to_dec_char: PROC (decimal_num INT IN) - RETURNS (dec_string); - - DCL neg_num BOOL := FALSE; -- save sign of parameter - DCL out_string dec_string; - - IF decimal_num < 0 THEN -- positive numbers are easier - decimal_num := -decimal_num; - neg_num := TRUE; - FI - - IF decimal_num = 0 THEN - out_string := '0'; /* handle zero */ - ELSE - out_string := ''; - DO WHILE decimal_num /= 0; -- loop until number is zero - -- concatenate a new digit in front of the output string - out_string := CHAR (ABS (decimal_num REM D'10) + H'30) - // out_string; - decimal_num := decimal_num / D'10; - OD; - IF neg_num THEN - -- prepend a hyphen for numbers < zero - out_string := '-' // out_string; -- restore sign - FI; - FI; - RESULT out_string; -- remember result - - decimal_num := 0; -- reset for next call - neg_num := FALSE; - out_string := ' '; - - END int_to_dec_char; - - /* Try some test cases */ - chprintf (int_to_dec_char (123456), 0); - chprintf ("^J", 0); - - chprintf (int_to_dec_char (-654321), 0); - chprintf ("^J", 0); - - chprintf (int_to_dec_char (0), 0); - chprintf ("^J", 0); - -END vary1; - -Completeness - -GNU CHILL currently supports the following features. This outline -generally follows the structure of the Blue Book specification: - - CCITT High Level Language (CHILL) Recommendation Z.200 - ISO/IEC 9496, Geneva 1989 ISBN 92-61-03801-8 - - - Modes (types) - no DYNAMIC modes yet - discrete modes - integer, boolean, character, real - multiple integer/real precisions (an extension) - set modes, range modes - powersets - references - (no ROW modes) - procedure modes - instance modes - event modes - buffer modes - (no input/output modes yet) - (no timing modes yet) - composite modes - strings - arrays - structures - VARYING string/array modes - (type-checking is not fully rigorous yet) - forward references - - Expressions - literals - tuples - slices, ranges - the standard operators - - Actions (statements) - assignments - if .. then .. else .. fi - cases - do action - do .. with - exits - calls - results/returns - gotos - assertions - cause exception - start/stop/continue process - - Input/Output - (not yet) - - Exception handling - fully compiled, but exceptions aren't - generated in all of the required situations - - Time Supervision - (syntax only) - - Inter-process communications - delay/delay case actions - send signal/receive case actions - send buffer/receive case actions - - Multi-module programming - Seize/grant processing - multiple modules per source file - - -Bibliography - -This list is included as an invitation. We'd appreciate hearing -of CHILL-related documents (with ISBN if possible) which aren't -described here. We're particularly interested in getting copies -of other conference Proceedings. - - CCITT High Level Language (CHILL) Recommendation Z.200 - ISO/IEC 9496, Geneva 1989 ISBN 92-61-03801-8 - (The "blue book". The formal language definition; mostly a - language-lawyer's document, but more readable than most.) - - Study Group X - Report R 34 - This is the May 1992 revision of Z.200. - - An Analytic Description of CHILL, the CCITT high-level - language, Branquart, Louis & Wodon, Springer-Verlag 1981 - ISBN 3-540-11196-4 - - CHILL User's Manual - CCITT, Geneva 1986 ISBN 92-61-02601-X - (Most readable, but doesn't cover the whole language). - - Introduction to CHILL - CCITT, Geneva 1983 ISBN 92-61-017771-1 - - CHILL CCITT High Level Language - Proceedings of the 5th CHILL Conference - North-Holland, 1991 ISBN 0 444 88904 3 - - Introduction to the CHILL programming Language - TELEBRAS, Campinas, Brazil 1990 - - CHILL: A Self-Instruction Manual - Telecommunication Institute - PITTC - Available from KVATRO A/S, N-7005 Trondheim, Norway - Phone: +47 7 52 00 90 - (Great discussion of novelty.) - -Some of these documents are available from Global Engineering -Documents, in Irvine, CA, USA. +1 714 261 1455. diff --git a/gcc/ch/chill.in b/gcc/ch/chill.in deleted file mode 100644 index 62b73d5f961..00000000000 --- a/gcc/ch/chill.in +++ /dev/null @@ -1,130 +0,0 @@ -#!/bin/sh -# Compile GNU Chill programs. -: || exec /bin/sh -f $0 $argv:q - -# The compiler name might be different when doing cross-compilation -# (this should be configured) -gcc_name=gcc -whatgcc=gcc -speclang=-xnone -startfile=chillrt0 -gnuchill_script_flags= -gnuchill_version=unknown -extraflags= - -# replace the command name by the name of the new command -progname=`basename $0` -case "$0" in - */*) - gcc=`echo $0 | sed -e "s;/[^/]*$;;"`/$gcc_name - ;; - *) - gcc=$gcc_name - ;; -esac - -# $first is yes for first arg, no afterwards. -first=yes -# If next arg is the argument of an option, $quote is non-empty. -# More precisely, it is the option that wants an argument. -quote= -# $library is made empty to disable use of libchill. -library="-lchill" -libpath=chillrt -numargs=$# - -for arg -do - if [ $first = yes ] - then - # Need some 1st arg to `set' which does not begin with `-'. - # We get rid of it after the loop ends. - set gcc - first=no - fi - # If you have to ask what this does, you should not edit this file. :-) - # The ``S'' at the start is so that echo -nostdinc does not eat the - # -nostdinc. - arg=`echo "S$arg" | sed "s/^S//; s/'/'\\\\\\\\''/g"` - if [ x$quote != x ] - then - quote= - else - quote= - case $arg in - -nostdlib) - # Inhibit linking with -lchill. - library= - libpath= - startfile= - ;; - -B*) - gcc=`echo $arg | sed -e "s/^-B//"`$gcc_name - ;; - -[bBVDUoeTuIYmLiA] | -Tdata | -Xlinker) - # these switches take following word as argument, - # so don't treat it as a file name. - quote=$arg - ;; - -[cSEM] | -MM) - # Don't specify libraries if we won't link, - # since that would cause a warning. - library= - libpath= - startfile= - ;; - -x*) - speclang=$arg - ;; - -v) - # catch `chill -v' - if [ $numargs = 1 ] ; then - library= - libpath= - startfile= - fi - echo "GNUCHILL version $gnuchill_version" - ;; - -fgrant-only | -fchill-grant-only) - #inhibit production of an object file - extraflags="-S -o /dev/null" - library= - libpath= - startfile= - ;; - -*) - # Pass other options through; they don't need -x and aren't inputs. - ;; - *) - # If file ends in .i, put options around it. - # But not if a specified -x option is currently active. - case "$speclang $arg" in -xnone\ *.[i]) - set "$@" -xchill "'$arg'" -xnone - continue - esac - ;; - esac - fi - set "$@" "'$arg'" -done - -# Get rid of that initial 1st arg -if [ $first = no ]; then - shift -else - echo "$0: No input files specified." - exit 1 -fi - -if [ x$quote != x ] -then - echo "$0: argument to \`$quote' missing" - exit 1 -fi - -# The '-ansi' flag prevents cpp from changing this: -# NEWMODE x = SET (sun, mon, thu, wed, thu, fri, sat); -#to this: -# NEWMODE x = SET (1, mon, thu, wed, thu, fri, sat); -#which is a CHILL syntax error. -eval $whatgcc -ansi $gnuchill_script_flags $startfile "$@" $libpath $library $extraflags diff --git a/gcc/ch/chill.texi b/gcc/ch/chill.texi deleted file mode 100644 index 9dab1f02af4..00000000000 --- a/gcc/ch/chill.texi +++ /dev/null @@ -1,1231 +0,0 @@ -@\input texinfo @c -*-texinfo-*- -@setfilename chill.info -@settitle Guide to GNU Chill - - -@ifinfo -@format -START-INFO-DIR-ENTRY -* Chill: (chill). Chill compiler -END-INFO-DIR-ENTRY -@end format -@end ifinfo - -@titlepage -@title GNU Chill -@author William Cox, Per Bothner, Wilfried Moser -@end titlepage - -@ifinfo -@node Top -@top - -@menu -* Options:: Compiler options -* Missing:: Unimplemented parts of the Chill language -* Enhancements:: GNU-specific enhancements to the Chill language -* Conversions:: Value and location conversions -* Separate compilation:: Separate compilation -* Differences:: Differences between GNUCHILL and Z.200/1988 -* Directives:: Implemented Compiler Directives -* References:: Language definition references -@end menu - -@end ifinfo - -@node Options -@chapter Compiler options - -Invoking the compiler: - -The @sc{gnu} CHILL compiler supports several new command line options, and -brings a new use to another: - -@table @code -@item -lang-chill -This option instructs gcc that the following file is a CHILL source file, -even though its extension is not the default `.ch'. - -@item -flocal-loop-counter -The CHILL compiler makes a separate reach, or scope, -for each DO FOR loop. If @code{-flocal-loop-counter} is -specified, the loop counter of value enumeration and location -enumeration is automatically declared inside that reach. -This is the default behavior, required by Z.200. - -@item -fno-local-loop-counter -When this option is specified, the above automatic declaration -is not performed, and the user must declare all loop counters -explicitly. - -@item -fignore-case -When this option is specified, the compiler ignores case. All -identifiers are converted to lower case. This enables the usage -of C runtime libraries. - -@item -fno-ignore-case -Ignoring the case of identifiers is turned off. - -@item -fruntime-checking -The CHILL compiler normally generates code to check -the validity of expressions assigned to variables or -expressions passed as parameters to procedures and processes, -if those expressions cannot be checked at compile time. -This is the default behavior, required by Z.200. -This option allows you to re-enable the default behavior -after disabling it with the @code{-fno-runtime-checking} -option. - -@item -fno-runtime-checking -The CHILL compiler normally generates code to check -the validity of expressions assigned to variables, or -expressions passed as parameters to procedures and processes. -This option allows you to disable that code generation. -This might be done to reduce the size of a program's -generated code, or to increase its speed of execution. -Compile time range-checking is still performed. - -@item -fgrant-only -@itemx -fchill-grant-only -This option causes the compiler to stop successfully -after creating the grant file specified by the source -file (see modular programming in CHILL). No code is -generated, and many categories of errors are not reported. - -@item -fold-string -Implement the semantics of Chill 1984 with respect to strings: -String indexing yields a slice of length one; CHAR is similar -to CHAR(1) (or CHARS(1)); and BOOL is similar to BIT(1) (or BOOLS(1)). - -@item -fno-old-string -Don't implement 1984 Chill string semantics. This is the default. - -@item -I@var{seize_path} -This directive adds the specified seize path to the compiler's -list of paths to search for seize files. When processing a -USE_SEIZE_FILE directive, the compiler normally searches for -the specified seize file only in the current directory. When -one or more seize paths are specified, the compiler also -searches in those directories, in the order of their -specification on the command line, for the seize file. - -@item -c -This C-related switch, which normally prevents gcc from -attempting to link, is *not* yet implemented by the @code{chill} command, -but you can use the @code{gcc} command with this flag. -@end table - -@node Missing -@chapter Implemented and missing parts of the Chill language - -The numbers in parentheses are Z.200(1988) section numbers. - -@itemize @bullet -@item The FORBID keyword in a GRANT statement is currently ignored. - -@item A CASE action or expression allows only a single expression -in a case selector list (5.3.2, 6.4). - -@item ROW modes are not implemented (3.6.3, 3.13.4). - -@item Due to the absence of ROW modes, DYNAMIC has no meaning in -connection with access and text modes. - -@item Array and structure layout (PACK, POS, NOPACK, -STEP keywords) is ignored (3.12.6). - -@item Bit-string slices are not implemented. - -@item The support for synchronization modes and concurrent execution -is slightly non-standard. - -@item Exception handling is implemented, but exceptions are not -generated in all of the required situations. - -@item Dynamic modes are not implemented (though string slices should work). - -@item Reach-bound initializations are not implemented (4.1.2). - -@end itemize - -@node Enhancements -@chapter GNU-specific enhancements to the Chill language - -@itemize @bullet -@item Grantfiles. See @xref{Separate compilation}. -@item Precisions. Multiple integer and real precisions are supported, -as well as signed and unsigned variants of the integer modes. -@item DESCR built-in. The new built-in function -DESCR ( <descriptor argument> ) returns a pointer to -STRUCT( addr PTR, length ULONG ) where <descriptor argument> can be -anything the compiler can handle but at least a location of any mode -(except synchronizing modes) and any character string or powerset value. -(A temporary location within the current stack frame may be allocated -if an expression is used.) - -CHILL does not permit the writing of procedures with parameters of -any type. Yet some interfaces---in particular those to system -calls---require -the handling of a wide range of modes, e.g. any string mode, any structure -mode, or any powerset mode. This could be handled by specifying two -parameters (PTR, INT for the length) but this is error-prone (no guarantee -the same location is used after in ADDR and LENGTH), and it will not be -possible for expressions. - -Caveats: This feature permits the programmer to obtain the address of -a literal (if the compiler takes this shortcut---see 1st example below). -If hardware features protect constant parts of the program, erronous -abuse will be detected. - - Examples: - OFFER_HANDLER( descr("dbs"), ->dbs); - - SYNMODE m_els = SET( ela, elb, elc ); - SYNMODE m_elsel = POWERSET m_els; - DCL user_buf STRUCT( a mx, b my, c mz); - DCL select POWERSET m_elsel; - - select := m_elsel[LOWER(m_els) : UPPER(m_els)]; - - GET_RECORD( relation, recno, descr(user_buf), descr(select) ); - - PUT_RECORD( relation, recno, descr(user_buf.b), descr(m_elsel[elb]) ); - -@item LENGTH built-in on left-hand-side. The LENGTH built-in may be -used on the left-hand-side of an assignment, where its argument is a VARYING -character string. -@end itemize - -@node Conversions -@chapter Value and location conversions - -Value and location conversions are highly dependent on the target machine. -They are also very loosely specified in the 1988 standard. -(The 1992 standard seems an improvement.) - -The GNU Chill compiler interprets @code{@var{mode}(@var{exp})} as follows: - -@itemize @bullet -@item -If @var{exp} is a referable location, -and the size of (the mode of) @var{exp} is the same as the size of @var{mode}, -a location conversion is used. -It is implemented exactly as: @code{(@var{refmode}(-> @var{exp}))->}, -where @var{refmode} is a synmode for @code{REF @var{mode}}. - -The programmer is responsible for making sure that alignment -restrictions on machine addresses are not violated. - -If both @var{mode} and the mode of @var{exp} are discrete modes, -alignment should not be a problem, and we get the same conversion -as a standard value conversion. - -@item -If @var{exp} is a constant, -and the size of (the mode of) @var{exp} is the same as the size of @var{mode}, -then a value conversion is performed. This conversion is done -at compile time, and it has not been implemented for all types. -Specifically, converting to or from a floating-point type is not implemented. - -@item -If both @var{mode} and the mode of @var{exp} are discrete modes, -then a value conversion is performed, as described in Z.200. - -@item -If both @var{mode} and the mode of @var{exp} are reference modes, -then a value conversion is allowed. -The same is true is one mode is a reference mode, and the other -is an integral mode of the same size. - -@end itemize - -@node Separate compilation -@chapter Separate compilation - -The GNU CHILL compiler supports modular programming. It -allows the user to control the visibility of variables -and modes, outside of a MODULE, by the use of GRANT -and SEIZE directives. Any location or mode may be made -visible to another MODULE by GRANTing it in the MODULE -where it is defined, and SEIZEing it in another MODULE -which needs to refer to it. - -When variables are GRANTed in one or more modules of a -CHILL source file, the compiler outputs a grant file, -with the original source file name as the base name, -and the extension `.grt'. All of the variables and modes -defined in the source file are written to the grant file, -together with any use_seize_file directives, and the -GRANT directives. A grant file is created for every such -source file, except if an identical grant file already -exists. This prevents unnecessary makefile activity. - -The referencing source file must: - -@enumerate -@item specify the grant file in a use_seize_file directive, and -@item SEIZE each variable or mode definition that it needs. -@end enumerate - -An attempt to SEIZE a variable or mode which is not -GRANTed in some seize file is an error. - -An attempt to refer to a variable which is defined in -some seize file, but not explicitly granted, is an -error. - -An attempt to GRANT a variable or mode which is not -defined in the current MODULE is an error. - -Note that the GNU CHILL compiler will *not* write out a -grant file if: - -@itemize @bullet -@item there are no GRANT directives in the source file, or -@item the entire grant file already exists, and is - identical to the file which the compiler has just built. -(This latter ``feature'' may be removed at some point.) -@end itemize - -Otherwise, a grant file is an automatic, unsuppressable -result of a successful CHILL compilation. - -A future release will also support using remote spec modules -in a similar (but more Blue Book-conforming) manner. - -@node Differences -@chapter Differences to Z.200/1988 - -This chapter lists the differences and extensions between GNUCHILL -and the CCITT recommendation Z.200 in its 1988 version (reffered to -as Z.200/1988). - -@itemize @bullet - -@item 2.2 Vocabulary@* -The definition of @i{<simple name string>} is changed to: - -@example -@i{<simple name string> ::=} -@example -@i{@{<letter> | _ @} @{ <letter> | <digit | _ @}} -@end example -@end example - -@item 2.6 Compiler Directives@* -Only one directive is allowed between the compiler directive delimiters -`<>' and `<>' or the end-of-line, i.e. -@example -<> USE_SEIZE_FILE "foo.grt" <> -<> ALL_STATIC_OFF -@end example - -@item 3.3 Modes and Classes@* -The syntax of @i{<mode>} is changed to: - -@example -@i{<mode> ::=} -@example - [@b{READ}] @i{<non-composite-mode>} -| [@b{READ}] @i{composite-mode>} -@end example - -@i{<non-composite-mode> ::=} -@example - @i{<discrete mode>} -| @i{<real modes>} -| @i{<powerset modes>} -| @i{<reference mode>} -| @i{<procedure mode>} -| @i{<instance mode>} -| @i{<synchronization mode>} -| @i{<timing mode>} -@end example -@end example - -@item 3.4 Discrete Modes@* -The list of discrete modes is enhanced by the following modes: - -@example -BYTE 8-bit signed integer -UBYTE 8-bit unsigned integer -UINT 16-bit unsigned integer -LONG 32-bit signed integer -ULONG 32-bit unsigned integer -@end example - -@strong{Please note} that INT is implemented as 16-bit signed integer. - -@item 3.4.6 Range Modes@* -The mode BIN(n) is not implemented. Using INT(0 : 2 ** n - 1) instead of -BIN(n) makes this mode unneccessary. - -@item 3.X Real Modes@* -Note: This is an extension to Z.200/1988, however, it is defined in -Z.200/1992. - -@b{syntax:} - -@example -@i{<real mode> ::=} -@example -@i{<floating point mode>} -@end example -@end example - -@b{semantics:} - -@example -A real mode specifies a set of numerical values which approximate a -contiguous range of real numbers. -@end example - -@item 3.X.1 Floating point modes@* - -@b{syntax:} - -@example -@i{<floating point mode> ::=} -@example -@i{<floating point mode name} -@end example -@end example - -@b{predefined names:} - -The names @i{REAL} and @i{LONG_REAL} are predefined as @b{floating -point mode} names. - -@b{semantics:} - -A floating point mode defines a set of numeric approximations to a -range of real values, together with their minimum relative accuracy, -between implementation defined bounds, over which the usual ordering -and arithmetic operations are defined. This set contains only the -values which can be represented by the implementation. - -@b{examples:} - -@example -@i{REAL} -@i{LONG_REAL} -@end example - -@item 3.6 Reference Modes@* -Row modes are not implemeted at all. - -@item 3.7 Procedure Mode@* -The syntax for procedure modes is changed to: - -@example -@i{<procedure mode> ::=} -@example - @b{PROC} @i{([<parameter list>]) [ <result spec> ]} - @i{[}@b{EXCEPTIONS}@i{(<exception list>)] [}@b{RECURSIVE}@i{]} -| @i{<procedure mode name>} -@end example - -@i{<parameter list> ::=} -@example -@i{<parameter spec> @{, <parameter spec> @} *} -@end example - -@i{<parameter spec> ::=} -@example -@i{<mode> [ <parameter attribute> ]} -@end example - -@i{<parameter attribute> ::=} -@example -@b{IN} | @b{OUT} | @b{INOUT} | @b{LOC} -@end example - -@i{<result spec> ::=} -@example -@b{RETURNS} @i{( <mode> [}@b{LOC}@i{])} -@end example - -@i{<exception list> ::=} -@example -@i{<exception name> @{, <exception name> @} *} -@end example -@end example - - -@item 3.10 Input-Output Modes@* -Due to the absence of row modes, DYNAMIC has no meaning in an access -or text mode definition. - - -@item 3.12.2 String Modes@* -As @i{<string modes>} were defined differently in Z.200/1984, the syntax -of @i{<string mode>} is changed to: - -@example -@i{<string mode> ::=} -@example - @i{<string type> ( <string length> ) [} @b{VARYING} @i{]} -| @i{<parametrized string mode>} -| @i{<string mode name>} -@end example - -@i{<parameterized string mode> ::=} -@example - @i{<origin string mode name> ( <string length> )} -| @i{<parameterized string mode name>} -@end example - -@i{<origin string mode name> ::=} -@example -@i{<string mode name>} -@end example - -@i{string type} -@example - @b{BOOLS} -| @b{BIT} -| @b{CHARS} -| @b{CHAR} -@end example - -@i{<string length> ::=} -@example -@i{<integer literal expression>} -@end example -@end example - -@b{VARYING} is not implemented for @i{<string type>} @b{BIT} -and @b{BOOL}. - -@item 3.11.1 Duration Modes@* -The predefined mode @i{DURATION} is implemented as a NEWMODE ULONG and -holds the duration value in miliseconds. This gives a maximum duration -of - -@example -MILLISECS (UPPER (ULONG)), -SECS (4294967), -MINUTES (71582), -HOURS (1193), and -DAYS (49). -@end example - -@item 3.11.2 Absolute Time Modes@* -The predefined mode @i{TIME} is implemented as a NEWMODE ULONG and -holds the absolute time in seconds since Jan. 1st, 1970. This is -equivalent to the mode `time_t' defined on different systems. - -@item 3.12.4 Structure Modes@* -Variant fields are allowed, but the CASE-construct may define only one -tag field (one dimensional CASE). OF course, several variant fields may -be specified in one STRUCT mode. The tag field will (both at compile- -and runtime) not be interpreted in any way, however, it must be -interpreted by a debugger. As a consequence, there are no parameterized -STRUCT modes. - -@item 3.12.5 Layout description for array and structure modes@* -STEP and POS is not implemeted at all, therefore the syntax of -@i{<element layout} and @i{field layout} is changed to: - -@example -@i{<element layout> ::=} -@example -@b{PACK} | @b{NOPACK} -@end example - -@i{<field layout> ::=} -@example -@b{PACK} | @b{NOPACK} -@end example -@end example - -@item 3.13.4 Dynamic parameterised structure modes@* -Dynamic parameterised structure modes are not implemented. - -@item 4.1.2 Location declaration@* -The keyword STATIC is allowed, but has no effect at module level, because -all locations declared there are assumed to be `static' by default. Each -granted location will become `public'. A `static' declaration inside a -block, procedure, etc. places the variable in the data section instead of -the stack section. - -@item 4.1.4 Based decleration@* -The based declaration was taken from Z.200/1984 and has the following -syntax: - -@b{syntax:} - -@example -@i{<based declaration> ::=} -@example -@i{<defining occerrence list> <mode>} @b{BASED} -@i{( <free reference location name> )} -@end example -@end example - -@b{semantics:} - -A based declaration with @i{<free reference location name>} specifies -as many access names as are defining occerrences in the @i{defining -occurrence list}. Names declared in a base declaration serve as an -alternative way accessing a location by dereferencing a reference -value. This reference value is contained in the location specified by -the @i{free reference location name}. This dereferencing operation is -made each time and only when an access is made via a declared @b{based} -name. - -@b{static properties:} - -A defining occurrence in a @i{based declaration} with @i{free reference -location name} defines a @b{based} name. The mode attached to a -@b{based} name is the @i{mode} specified in the @i{based declaration}. A -@b{based} name is @b{referable}. - -@item 4.2.2 Access names@* -The syntax of access names is changed to: - -@example -@i{<access name> ::=} -@example - @i{<location name>} -| @i{<loc-identity name>} -| @i{<based name>} -| @i{<location enumeration name>} -| @i{<location do-with name>} -@end example -@end example - -The semantics, static properties and dynamic conditions remain -unchanged except that they are enhanced by @i{base name}. - -@item 5.2.4.1 Literals General@* -The syntax of @i{<literal>} is change to: - -@example -@i{<literal> ::=} -@example - @i{<integer literal>} -| @i{<boolean literal>} -| @i{<charater literal>} -| @i{<set literal>} -| @i{<emptiness literal>} -| @i{<character string literal>} -| @i{<bit string literal>} -| @i{<floating point literal>} -@end example -@end example - -Note: The @i{<floating point literal>} is an extension to Z.200/1988 and -will be described later on. - -@item 5.2.4.2 Integer literals@* -The @i{<decimal integer literal>} is changed to: - -@example -@i{<decimal integer literal> ::=} -@example - @i{@{ D | d @} ' @{ <digit> | _ @} +} -| @i{<digit> @{ <digit> | _ @} *} -@end example -@end example - -@item 5.2.4.4 Character literals@* -A character literal, e.g. 'M', may serve as a charater string literal of -length 1. - -@item 5.2.4.7 Character string literals@* -The syntax of a character string literal is: - -@example -@i{<character string literal> ::=} -@example - @i{'@{ <non-reserved character> | <single quote> |} - @i{<control sequence> @} * '} -| @i{'@{ <non-reserved character> | <double quote> |} - @i{<control sequence> @} * '} -@end example - -@i{<single quote> ::=} -@example -@i{''} -@end example - -@i{<double quote> ::=} -@example -@i{""} -@end example -@end example - -A character string litaral of length 1, enclosed in apostrophes -(e.g. 'M') may also serve as a charater literal. - -@item 5.2.4.9 Floating point literal@* -Note: This is an extension to Z.200/1988 ans was taken from Z.200/1992. - -@b{syntax:} - -@example -@i{<floating point literal> ::=} -@example - @i{<unsigned floating point literal>} -| @i{<signed floating point literal>} -@end example - -@i{<unsigned floating point literal> ::=} -@example - @i{<digit sequence> . [ <digit sequence> ] [ <exponent> ]} -| @i{[ <digit sequence> ] . <digit sequence> [ <exponent> ]} -@end example - -@i{<signed floating point literal> ::=} -@example -@i{- <unsigned floating point literal>} -@end example - -@i{<digit sequence> ::=} -@example -@i{<digit> @{ <digit> | _ @} *} -@end example - -@i{<exponent> ::=} -@example - @i{[ E | D | e | d ] <digit sequence>} -| @i{[ E | D | e | d ] - <digit sequence>} -@end example -@end example - -@item 5.2.14 Start Expression@* -The START expression is not implemented. - -@item 5.3 Values and Expressions@* -The undefined value, denoted by `*', is not implemented. - -@item 5.3.8 Operand-5@* -The @i{<string repetition operator>} is defined as: - -@example -@i{<string repetition operator> ::=} -@example -@i{(<integer expression>)} -@end example -@end example - -@item 6.4 Case Action@* -There may be only one case selector specified. The optional range list -must not be specified. - -@item 6.5 Do Action@* -A Do-Action without control part is not implemented. Grouping of -statements can be achieved via BEGIN and END. A location enumeration is not -allowed for BIT strings, only for (varying) CHAR strings and ARRAYs. - -The expression list in a DO WITH must consist of locations only. - -@item 6.13 Start Action@* -The syntax of the START action is changed to: - -@example -@i{<start action> ::=} -@example -@b{START} @i{<process name> (<copy number> [, <actual parameter list>])} -@i{[} @b{SET} @i{<instance location> ]} -@end example - -@i{<copy number> ::=} -@example -@i{<integer expression>} -@end example -@end example - -@item 6.16 Delay Action@* -The optional PRIORITY specification need not be a constant. - -@item 6.17 Delay Case Action@* -The optional SET branch and the, also optional, PRIORITY branch must be -separated by `;'. - -@item 6.18 Send Action@* -The send action must define a destination instance (via the TO branch), -since undirected signals are not supported. The optional PRIORITY -specification need not be a constant. Additional to the data -transported by the signal, there will be a user defined argument. - -The syntax of the @i{<send signal action>} is therefore: - -@example -@i{<send signal action> ::=} -@example -@b{SEND} @i{<signal name> [ ( <value> @{, <value> @} * ) ]} -@i{[} @b{WITH} @i{<expression> ]} -@b{TO} @i{<instance primitive value> [ <priority> ]} -@end example -@end example - -The default priority can be specified by the compiler directive -SEND_SIGNAL_DEFAULT_PRIORITY. If this also is omitted, the default -priority is 0. - -@item 6.20.3 CHILL value built-in calls@* -The CHILL value buit-in calls are enhanced by some calls, and other calls -will have different arguments as described in Z.200/1988. Any call not -mentioned here is the same as described in Z.200/1988. - -@b{syntax:} - -@example -@i{CHILL value built-in routine call> ::=} -@example - @i{ADDR (<location>)} -| @i{PRED (<pred succ argument>)} -| @i{SUCC (<pred succ argument>)} -| @i{ABS (<numeric expression>)} -| @i{LENGTH (<length argument>)} -| @i{SIN (<floating point expression>)} -| @i{COS (<floating point expression>)} -| @i{TAN (<floating point expression>)} -| @i{ARCSIN (<floating point expression>)} -| @i{ARCCOS (<floating point expression>)} -| @i{ARCTAN (<floating point expression>)} -| @i{EXP (<floating point expression>)} -| @i{LN (<floating point expression>)} -| @i{LOG (<floating point expression>)} -| @i{SQRT (<floating point expression>)} -| @i{QUEUE_LENGTH (<buffer location> | <event location>)} -| @i{GEN_INST (<integer expression> | <process name> ,} - @i{<integer expression>)} -| @i{COPY_NUMBER (<instance expression>)} -| @i{GEN_PTYE (<process name>)} -| @i{PROC_TYPE (<instance expression>)} -| @i{GEN_CODE (<process name> | <signal name>)} -| @i{DESCR (<location>)} -@end example - -@i{<pred succ argument> ::=} -@example - @i{<discrete expression>} -| @i{<bound reference expression>} -@end example - -@i{<numeric expression> ::=} -@example - @i{<integer expression>} -| @i{floating point expression>} -@end example - -@i{<length argument> ::=} -@example - @i{<string location>} -| @i{<string expression>} -| @i{<string mode name>} -| @i{<event location>} -| @i{<event mode name>} -| @i{<buffer location>} -| @i{<buffer mode name>} -| @i{<text location>} -| @i{<text mode name>} -@end example -@end example - -@b{semantics:} - -@i{ADDR} is derived syntax for -> @i{<location>}. - -@i{PRED} and @i{SUCC} delivers respectively, in case of a @i{discrete -expression}, the next lower or higher discrete value of their argument, -in case of @i{bound reference expression} these built-in calls deliver a -pointer to the previous or next element. - -@i{ABS} is defined on numeric values, i.e. integer values and floating -point values, delivering the corresponding absolute value. - -@i{LENGTH} is defined on - -@itemize @bullet - -@item string and text locations and string expressions, delivering the -length of them; - -@item event locations, delivering the @b{event length} of the mode of the -location; - -@item buffer locations, delivering the @b{buffer length} of the mode of -the location; - -@item string mode names, delivering the @b{string length} of the mode; - -@item text mode names, delivering the @b{text length} of the mode; - -@item buffer mode names, delivering the @b{buffer length} of the mode; - -@item event mode names, delivering the @b{event length} of the mode; - -@item Additionally, @i{LENGTH} also may be used on the left hand -side of an assignment to set a new length of a @i{varying character -string location}. However, to avoid undefined elements in the varying -string, the new length may only be less or equal to the current length. -Otherwise a @b{RANGEFAIL} exception will be generated. -@end itemize - -@i{SIN} delivers the sine of its argument (interpreted in radians). - -@i{COS} delivers the cosine of its argument (interpreted in radians). - -@i{TAN} delivers the tangent of its argument (interpreted in radians). - -@i{ARCSIN} delivers the sin -1 function of its argument. - -@i{ARCCOS} delivers the cos -1 function of its argument. - -@i{ARCTAN} delivers the tan -1 function of its argument. - -@i{EXP} delivers the exponential function, where x is the argument. - -@i{LN} delivers the natural logarithm of its argument. - -@i{LOG} delivers the base 10 logarithm of its argument. - -@i{SQRT} delivers the sqare root of its argument. - -@i{QUEUE_LENGTH} delivers either the number of sending delayed processes -plus the number of messages in a buffer queue (if the argument is a -@i{buffer location}), or the number of delayed processes (if the -argument specifies an @i{event location}) as @i{integer expression}. - -@i{GEN_INST} delivers an @i{instance expression} constructed from the -arguments. Both arguments must have the @i{&INT}-derived class. - -@i{COPY_NUMBER} delivers as @i{&INT}-derived class the copy number of an -@i{instance location}. - -@i{GEN_PTYPE} delivers as @i{&INT}-derived class the associated number -of the @i{process name}. - -@i{PROC_TYPE} delivers as @i{&INT}-derived class the process type of an -@i{instance expression}. - -@i{GEN_CODE} delivers as @i{&INT}-derived class the associated number of -the @i{process name} or @i{signal name}. - -@i{DESCR} delivers a @i{free reference expression} pointing to a -structure with the following layout describing the @i{location} argument. - -@example -SYNMODE __tmp_descr = STRUCT (p PTR, l ULONG); -@end example - - -@item 7.4.2 Associating an outside world object@* -The syntax of the associate built-in routine call is defined as: - -@example -@i{<associate built-in routine call> ::=} -@example -@i{ASSOCIATE ( <association location>, <string expression>,} [@i{, <string expression>} ] @i{)} -@end example -@end example - -The ASSOCIATE call has two parameters besides the association location: -a pathname and an optional mode string. - -The value of the first string expression must be a pathname according to -the rules of the underlying operating system. (Note that a relative pathname -implies a name relative to the working directory of the process.) - -The mode string may contain the value "VARIABLE", which requests -an external representation of records consisting of an UINT record -length followed by as many bytes of data as indicated by the length field. -Such a file with variable records is not indexable. - -A file with variable records can be written using any record mode. If the -record mode is CHARS(n) VARYING, the record length is equal to the actual -length of the value written. (Different record may have differing lengths.) -With all other record modes, all records written using the same access mode -will have the same length, but will still be prefixed with the length field. -(Note that by re-connecting with different access modes, the external -representation may ultimately contain records with differing lengths.) - -A file with variable records can only be read by using a record mode of -CHARS(n) VARYING. - - -@item 7.4.2 Accessing association attributes@* -The value of the READABLE and WRITEABLE attributes is determined using -the file status call provided by the operating system. The result will -depend on the device being accessed, or on the file mode. - -The INDEXABLE attribute has the value false for files with variable records, -and for files associated with devices not supporting random positioning -(character devices, FIFO special files, etc.). - -The variable attribute is true for files associated with the mode sting -"VARIABLE", and false otherwise. - - -@item 7.4.5 Modifying association attributes@* -The syntax of the MODIFY built-in routine call is defined as: - -@example -@i{<modify built-in call> ::=} -@example -@i{MODIFY ( <association location>, <string expression> )} -@end example -@end example - -At present, MODIFY accepts a character string containing a pathname -in addition to the association location, which will cause a renaming -of the associated file. - - -@item 7.4.9 Data transfer operations@* -READRECORD will fail (causing READFAIL) if the number of bytes from the -current position in the file to the end of the file is greater than zero -but less than the size of the record mode, and no data will be transferred. -(If the number of bytes is zero, no error occurs and OUTOFFILE will -return TRUE.) - -The number of bytes transferred by READRECORD and WRITERECORD is equal to -the size of the record mode of the access location. Note that the -internal representation of this mode may vary depending on the -record mode being packed or not. - - -@item 7.5 Text Input Output@* -Sequential text files will be represented so as to be compatible -with the standard representation of texts on the underlying operating -system, where control characters are used to delimit text records on files -as well as to control the movement of a cursor or printing head on a device. - -For indexed text files, records of a uniform length (i.e. the size of the -text record, including the length field) are written. All i/o codes cause -an i/o transfer without any carriage control characters being added to the -record, which will be expanded with spaces. - -An indexed text file is therefore not compatible with the standard -text representation of the underlying operating system. - - - -@item 7.5.3 Text transfer operations@* -The syntax of @i{<text argument>} is changed to: - -@example -@i{<text argument> ::=} -@example - @i{<text location>} -| @i{<predefined text location>} -| @i{<varying string location>} -@end example - -@i{<predefined text location> ::=} -@example - STDIN -| STDOUT -| STDERR -@end example -@end example - -NOTE: The identifiers STDIN, STDOUT, and STDERR are predefined. -Association and connection with files or devices is done according to -operating system rules. - -The effect of using READTEXT or WRITETEXT with a character string location -as a text argument (i.e. the first parameter) where the same location also -appears in the i/o list is undefined. - -The current implementation of formatting assumes run-to-completion semantics -of CHILL tasks within an image. - - - -@item 7.5.5 Conversion@* -Due to the implementation of @i{<floating point modes>} the syntax -is changed to: - -@example -@i{<conversion clause> ::=} -@example -@i{<conversion code> @{ <conversion qualifier @} *} -@i{[ <clause width> ]} -@end example - -@i{<conversion code> ::=} -@example -@i{B} | @i{O} | @i{H} | @i{C} | @i{F} -@end example - -@i{<conversion qualifier> ::=} -@example -@i{L} | @i{E} | @i{P<character>} -@end example - -@i{<clause width> ::=} -@example - @i{@{ <digit> @} +} | @i{V} -| @i{<real clause width>} -@end example - -@i{<real clause width> ::=} -@example -@i{@{ @{ <digit> + | V @} : @{ @{ <digit> @} + | V @}} -@end example -@end example - -Note: The @i{<real clause width>} is only valid for @i{<conversion -code>} `C' or `F'. - - -@item 7.5.7 I/O control@* -To achieve compatibility of text files written with CHILL i/o with -the standard representation of text on the underlying operating system -the interpretation of the i/o control clause of the format -deviates from Z.200. The following table shows the i/o codes together -with the control characters written before and after the text record, -to achieve the indicated function: -@table @samp -@item / -Write next record (record, line feed) - -@item + -Write record on next page (form feed, record, line feed) - -@item - -Write record on current line (record, carriage return) - -@item ? -Write record as a prompt (carriage return, record) - -@item ! -Emit record (record). - -@item = -Force new page for the next line: The control character written before -the next record will be form feed, irrespective of the i/o control used for -transferring the record. -@end table - -When reading a text file containing control characters other than line feed, -these characters have to be reckoned with by the format used to read the -text records. - - - - -@item 11.2.2 Regionality@* -Regionality is not implemented at all, so there is no difference in the -generated code when REGION is substituted by MODULE in a GNUCHILL -compilation unit. - -@item 11.5 Signal definition statement@* -The @i{<signal definition statement>} may only occur at module level. - -@item 12.3 Case Selection@* -The syntax of @i{<case label specification>} is changed to: - -@example -@i{<case label specification> ::=} -@example -@i{( <case label> @{, <case label> @} * )} -@end example - -@i{<case label> ::=} -@example - @i{<discrete literal expression>} -| @i{<literal range>} -| @i{<discrete mode name>} -| @b{ELSE} -@end example -@end example - -@end itemize - -@node Directives -@chapter Compiler Directives - -@itemize @bullet - -@item ALL_STATIC_ON, ALL_STATIC_OFF@* -These directives control where procedure local variables are -allocated. ALL_STATIC_ON turns allocation of procedure local variables -in the data space ON, regardless of the keyword STATIC being used or not. -ALL_STATIC_OFF places procedure local variables in the stack space. -The default is ALL_STATIC_OFF. - -@item RANGE_ON, RANGE_OFF@* -Turns generation of rangecheck code ON and OFF. - -@item USE_SEIZE_FILE <character string literal>@* -Specify the filename (as a character string literal) where -subsequent SEIZE statements are related to. This directive -and the subsequent SEIZEs are written -to a possibly generated grant file for this module. - -@example -<> USE_SEIZE_FILE "foo.grt" <> -SEIZE bar; -@end example - -@item USE_SEIZE_FILE_RESTRICTED "filename"@* -Same as USE_SEIZE_FILE. The difference is that this directive -and subsequent SEIZEs are *not* written to a possibly generated -grant file. - -@item PROCESS_TYPE = <integer expression>@* -Set start value for all PROCESS delclarations. This value automatically -gets incremented after each PROCESS declaration and may be changed with -a new PROCESS_TYPE compiler directive. - -@item SIGNAL_CODE = <integer expression>@* -Set start value for all SIGNAL definitions. This value automatically -gets incremented after each SIGNAL definition and may be changed with a -new SIGNAL_CODE compiler directive. - -@item SEND_SIGNAL_DEFAULT_PRIORITY = <integer expression>@* -Set default priority for send signal action. - -@item SEND_BUFFER_DEFAULT_PRIORITY = <integer expression>@* -Set default priority for send buffer action. - -Note: Every <integer expression> in the above mentioned compiler -directives may also be specified by a SYNONYM of an integer type. - -@example -SYN first_signal_code = 10; -<> SIGNAL_CODE = first_signal_code <> -SIGNAL s1; -@end example - -@end itemize - -@node References -@chapter Language Definition References - -@itemize @bullet -@item CCITT High Level Language (CHILL) Recommendation Z.200 - ISO/IEC 9496, Geneva 1989 ISBN 92-61-03801-8 - -@item An Analytic Description of CHILL, the CCITT high-level - language, Branquart, Louis & Wodon, Springer-Verlag 1981 - ISBN 3-540-11196-4 - -@item CHILL User's Manual - CCITT, Geneva 1986 ISBN 92-61-02601-X - -@item Introduction to CHILL - CCITT, Geneva 1983 ISBN 92-61-017771-1 - -@item CHILL CCITT High Level Language - Proceedings of the 5th CHILL Conference - North-Holland, 1991 ISBN 0 444 88904 3 - -@item Introduction to the CHILL programming Language - TELEBRAS, Campinas, Brazil 1990 - -@end itemize - -Z.200 is mostly a language-lawyer's document, but more readable -than most. The User's Guide is more readable by far, but doesn't -cover the whole language. Our copies of these documents came through -Global Engineering Documents, in Irvine, CA, USA. (714)261-1455. - -@contents -@bye diff --git a/gcc/ch/config-lang.in b/gcc/ch/config-lang.in deleted file mode 100644 index b0bd9293e29..00000000000 --- a/gcc/ch/config-lang.in +++ /dev/null @@ -1,41 +0,0 @@ -# Top level configure fragment for GNU CHILL. -# Copyright (C) 1994, 2000 Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. */ - -# Configure looks for the existence of this file to auto-config each language. -# We define several parameters used by configure: -# -# language - name of language as it would appear in $(LANGUAGES) -# compilers - value to add to $(COMPILERS) -# stagestuff - files to add to $(STAGESTUFF) -# diff_excludes - files to ignore when building diffs between two versions. - -language="CHILL" - -compilers="cc1chill\$(exeext)" - -stagestuff="chill chill-cross\$(exeext) cc1chill\$(exeext)" - -diff_excludes="-x -x ch/chill.info*" - -outputs=ch/Makefile - -target_libs=target-libchill - -build_by_default=no diff --git a/gcc/ch/configure b/gcc/ch/configure deleted file mode 100755 index fd1b50ddbdf..00000000000 --- a/gcc/ch/configure +++ /dev/null @@ -1,635 +0,0 @@ -#!/bin/sh -# Configuration script for GNU CHILL -# Copyright (C) 1994 Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. */ - -# -# Shell script to create proper links to machine-dependent files in -# preparation for compiling gcc. -# -# Options: --srcdir=DIR specifies directory where sources are. -# --host=HOST specifies host configuration. -# --target=TARGET specifies target configuration. -# --build=TARGET specifies configuration of machine you are -# using to compile GCC. -# --prefix=DIR specifies directory to install in. -# --local-prefix=DIR specifies directory to put local ./include in. -# --exec-prefix=DIR specifies directory to install executables in. -# --with-gnu-ld arrange to work with GNU ld. -# --with-gnu-as arrange to work with GAS. -# --with-stabs arrange to use stabs instead of host debug format. -# --with-elf arrange to use elf instead of host debug format. -# --nfp assume system has no FPU. -# -# If configure succeeds, it leaves its status in config.status. -# If configure fails after disturbing the status quo, -# config.status is removed. -# - -progname=$0 -# Configure the runtime and regression-test directories -SUBDIRS="runtime utils" -SUBDIRS="$SUBDIRS testsuite/compile" -SUBDIRS="$SUBDIRS testsuite/execute" -SUBDIRS="$SUBDIRS testsuite/execute/telebras" -SUBDIRS="$SUBDIRS testsuite/noncompile" -SUBDIRS="$SUBDIRS testsuite/examples" -SUBDIRS="$SUBDIRS testsuite/execute/oe" -SUBDIRS="$SUBDIRS testsuite/compile/elektra" -SUBDIRS="$SUBDIRS testsuite/compile/votrics" - -# Default --srcdir to the directory where the script is found, -# if a directory was specified. -# The second sed call is to convert `.//configure' to `./configure'. -srcdir=`echo $0 | sed 's|//|/|' | sed 's|/[^/]*$||'` -if [ x$srcdir = x$0 ] -then -srcdir= -fi - -host= - -# Default prefix to /usr/local. -prefix=/usr/local - -# local_prefix specifies where to find the directory /usr/local/include -# We don't use $(prefix) for this -# because we always want GCC to search /usr/local/include -# even if GCC is installed somewhere other than /usr/local. -# Think THREE TIMES before specifying any other value for this! -# DO NOT make this use $prefix! -local_prefix=/usr/local -# For our purposes, this must be prefix. This is apparently -# only done for the benefit of glibc, and we don't use glibc. -local_prefix='$(prefix)' -# Default is to let the Makefile set exec_prefix from $(prefix) -exec_prefix='$(prefix)' - -program_transform_name= -program_transform_set= -site= - -remove=rm -hard_link=ln -symbolic_link='ln -s' -copy=cp - -# Record all the arguments, to write them in config.status. -arguments=$* - -#for Test -#remove="echo rm" -#hard_link="echo ln" -#symbolic_link="echo ln -s" - -target= -host= -build= - -for arg in $*; -do - case $next_arg in - --srcdir) - srcdir=$arg - next_arg= - ;; - --host) - host=$arg - next_arg= - ;; - --target) - target=$arg - next_arg= - ;; - --build) - build=$arg - next_arg= - ;; - --prefix) - prefix=$arg - next_arg= - ;; - --local-prefix) - local_prefix=$arg - next_arg= - ;; - --exec-prefix) - exec_prefix=$arg - next_arg= - ;; - --program-transform-name) - # Double any backslashes or dollar signs in the argument. - if [ -n "${arg}" ] ; then - program_transform_name="${program_transform_name} -e `echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`" - fi - program_transform_set=yes - next_arg= - ;; - --program-prefix) - if [ -n "${arg}" ]; then - program_transform_name="${program_transform_name} -e s,^,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`," - fi - program_transform_set=yes - next_arg= - ;; - --program-suffix) - if [ -n "${arg}" ]; then - program_transform_name="${program_transform_name} -e s,\$\$,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`," - fi - program_transform_set=yes - next_arg= - ;; - --site) - site=${arg} - next_arg= - ;; - --x-*) - next_arg= - ;; - *) - case $arg in - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s) - next_arg=--srcdir - ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*) - srcdir=`echo $arg | sed 's/-*s[a-z]*=//'` - ;; - -host | --host | --hos | --ho | --h) - next_arg=--host - ;; - -host=* | --host=* | --hos=* | --ho=* | --h=*) - host=`echo $arg | sed 's/-*h[a-z]*=//'` - ;; - -target | --target | --targe | --targ | --tar | --ta | --t) - next_arg=--target - ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target=`echo $arg | sed 's/-*t[a-z]*=//'` - ;; - -build | --build | --buil | --bui | --bu | --b) - next_arg=--build - ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*) - build=`echo $arg | sed 's/-*b[a-z]*=//'` - ;; - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - next_arg=--prefix - ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=`echo $arg | sed 's/-*p[a-z]*=//'` - ;; - -local-prefix | --local-prefix | --local-prefi | --local-pref | --local-pre \ - | --local-pr | --local-p | --local- | --local | --loc | --lo | --l) - next_arg=--local-prefix - ;; - -local-prefix=* | --local-prefix=* | --local-prefi=* | --local-pref=* \ - | --local-pre=* | --local-pr=* | --local-p=* | --local-=* | --local=* \ - | --loc=* | --lo=* | --l=*) - local_prefix=`echo $arg | sed 's/-*l[-a-z]*=//'` - ;; - -exec-prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre \ - | --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e) - next_arg=--exec-prefix - ;; - -exec-prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* \ - | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* \ - | --exe=* | --ex=* | --e=*) - exec_prefix=`echo $arg | sed 's/-*e[-a-z]*=//'` - ;; - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- | --program-transform \ - | --program-transfor | --program-transfo | --program-transf \ - | --program-trans | --program-tran | --program-tra \ - | --program-tr | --program-t) - next_arg=--program-transform-name - ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* | --program-transfo=* \ - | --program-transf=* | --program-trans=* | --program-tran=* \ - | --program-tra=* | --program-tr=* | --program-t=*) - arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'` - # Double any \ or $ in the argument. - if [ -n "${arg}" ] ; then - program_transform_name="${program_transform_name} -e `echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`" - fi - program_transform_set=yes - ;; - -program-prefix | --program-prefix | --program-prefi \ - | --program-pref | --program-pre | --program-pr \ - | --program-p) - next_arg=--program-prefix - ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* \ - | --program-p=*) - arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'` - if [ -n "${arg}" ]; then - program_transform_name="${program_transform_name} -e s,^,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`," - fi - program_transform_set=yes - ;; - -program-suffix | --program-suffix | --program-suffi \ - | --program-suff | --program-suf | --program-su \ - | --program-s) - next_arg=--program-suffix - ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* \ - | --program-s=*) - arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'` - if [ -n "${arg}" ]; then - program_transform_name="${program_transform_name} -e s,\$\$,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`," - fi - program_transform_set=yes - ;; - -site | --site | --sit) - next_arg=--site - ;; - -site=* | --site=* | --sit=* | --si=*) - site=`echo ${arg} | sed 's/^[-a-z]*=//'` - ;; - -with-gnu-ld | --with-gnu-ld | --with-gnu-l) - gnu_ld=yes - ;; - -gas | --gas | --ga | --g | -with-gnu-as | --with-gnu-as | -with-gnu-a) - gas=yes - ;; - -nfp | --nfp | --nf | --n) - nfp=yes - ;; - -with-stabs | -with-stab | -with-sta | -with-st | -with-s \ - | --with-stabs | --with-stab | --with-sta | --with-st | --with-s \ - | -stabs | -stab | -sta | -st \ - | --stabs | --stab | --sta | --st) - stabs=yes - ;; - -with-elf | -with-el | -with-se \ - | --with-elf | --with-el | --with-e \ - | -elf | -el | -e \ - |--elf | --el | --e) - elf=yes - ;; - -with-* | --with-*) ;; #ignored - -without-* | --without-*) ;; #ignored - -enable-* | --enable-*) ;; #ignored - -x | --x) ;; # ignored - -x-*=* | --x-*=*) ;; # ignored - -x-* | --x-*) - next_arg=--x-ignored # ignored - ;; - --he*) ;; # ignored for now (--help) - --vers*) ;; # ignored for now (--version) - -v | -verb* | --verb*) ;; # ignored for now (--verbose) - --program-*) ;; #ignored (--program-prefix, --program-suffix) - --c*) ;; #ignored (--cache-file) - --q*) ;; #ignored (--quiet) - --si*) ;; #ignored (--silent) - -*) - echo "Invalid option \`$arg'" 1>&2 - exit 1 - ;; - *) -# Allow configure HOST TARGET - if [ x$host = x ] - then - host=$target - fi - target=$arg - ;; - esac - esac -done - -# Find the source files, if location was not specified. -if [ x$srcdir = x ] -then - srcdirdefaulted=1 - srcdir=. - if [ ! -r tree.c ] - then - srcdir=.. - fi -fi - -if [ ! -r ${srcdir}/grant.c ] -then - if [ x$srcdirdefaulted = x ] - then - echo "$progname: Can't find CHILL frontend sources in \`${srcdir}'" 1>&2 - else - echo "$progname: Can't find CHILL frontend sources in \`.' or \`..'" 1>&2 - fi - exit 1 -fi - -# Make sure that scripts are executable -[ -w ${srcdir} -a -f ${srcdir}/regression.sh ] && \ - chmod +x ${srcdir}/regression.sh -[ -w ${srcdir} -a -f ${srcdir}/regression.prpt ] && \ - chmod +x ${srcdir}/regression.prpt -[ -w ${srcdir} -a -f ${srcdir}/regression.awk3 ] && \ - chmod +x ${srcdir}/regression.awk3 - -if [ -r ${srcdir}/config.status ] && [ x$srcdir != x. ] -then - echo "$progname: \`configure' has been run in \`${srcdir}'" 1>&2 - exit 1 -fi - -host_xmake_file= -host_truncate_target= - -# Complain if an arg is missing -if [ x$build = x ] -then - # If host was specified, always use it for build also to avoid - # confusion. If someone wants a cross compiler where build != host, - # then they must specify build explicitly. Since this case is - # extremely rare, it does not matter that it is slightly inconvenient. - if [ x$host != x ] - then - build=$host - - # This way of testing the result of a command substitution is - # defined by Posix.2 (section 3.9.1) as well as traditional shells. - elif build=`${srcdir}/../config.guess` - then - echo "This appears to be a ${build} system." 1>&2 - - elif [ x$target != x ] - then - echo 'Config.guess failed to determine the host type. Defaulting to target.' - build=$target - else - echo 'Config.guess failed to determine the host type. You need to specify one.' 1>&2 - echo "\ -Usage: `basename $progname` [--host=HOST] [--build=BUILD] - [--prefix=DIR] [--gxx-include-dir=DIR] [--local-pref=DIR] [--exec-pref=DIR] - [--with-gnu-as] [--with-gnu-ld] [--with-stabs] [--with-elf] [--nfp] TARGET" 1>&2 - echo "Where HOST, TARGET and BUILD are three-part configuration names " 1>&2 - if [ -r config.status ] - then - tail +2 config.status 1>&2 - fi - exit 1 - fi -fi - -# If $host was not specified, use $build. -if [ x$host = x ] -then - host=$build -fi - -# If $target was not specified, use $host. -if [ x$target = x ] -then - target=$host -fi - -# Validate the specs, and canonicalize them. -canon_build=`/bin/sh $srcdir/../config.sub $build` || exit 1 -canon_host=`/bin/sh $srcdir/../config.sub $host` || exit 1 -canon_target=`/bin/sh $srcdir/../config.sub $target` || exit 1 - -rm -f config.bak -if [ -f config.status ]; then mv -f config.status config.bak; fi - -# -# For the current directory and all of the designated SUBDIRS, -# do the rest of the script... -# -if [ ! -d testsuite ] ; then mkdir testsuite; fi -_SUBDIRS= -for d in $SUBDIRS; do - [ -d $srcdir/$d ] && _SUBDIRS="$_SUBDIRS $d" -done - -savesrcdir=$srcdir -STARTDIR=`pwd` - -for subdir in $_SUBDIRS -do - tmake_file= - host_xmake_file= - oldsrcdir=$savesrcdir - - # ${invsubdir} is inverse of ${subdir), *with* trailing /, if needed. - invsubdir=`echo ${subdir}/ | sed -e 's|\./||g' -e 's|[^/]*/|../|g'` - - # Re-adjust the path - # Also create a .gdbinit file which runs the one in srcdir - # and tells GDB to look there for source files. - - case $oldsrcdir in - ".") srcdir=. ;; - /*) # absolute path - srcdir=${oldsrcdir}/${subdir} ;; - *) # otherwise relative - srcdir=${invsubdir}${oldsrcdir}/${subdir} ;; - esac - - if [ -r ${oldsrcdir}/${subdir}/.gdbinit -a ${oldsrcdir} != "." ] ; then - cat > ${subdir}/.gdbinit <<EOF -dir . -dir ${srcdir} -source ${srcdir}/.gdbinit -EOF - fi - - case $oldsrcdir in - /*) ;; - *) oldsrcdir=${invsubdir}${oldsrcdir} ;; - esac - mainsrcdir=${oldsrcdir}/.. - test -d $subdir || mkdir $subdir - cd $subdir - # - # Create Makefile.tem from Makefile.in. - # Make it set VPATH if necessary so that the sources are found. - # Also change its value of srcdir. - rm -f Makefile.tem - echo "VPATH = ${srcdir}" \ - | cat - ${srcdir}/Makefile.in \ - | sed "s@^srcdir = \.@srcdir = ${srcdir}@" > Makefile.tem - - # Conditionalize the makefile for this host machine. - if [ -f ${mainsrcdir}/config/${host_xmake_file} ] - then - rm -f Makefile.xx - sed -e "/####host/ r ${mainsrcdir}/config/${host_xmake_file}" Makefile.tem > Makefile.xx - echo "Merged ${host_xmake_file}." - rm -f Makefile.tem - mv Makefile.xx Makefile.tem - else - # Say in the makefile that there is no host_xmake_file, - # by using a name which (when interpreted relative to $srcdir/config) - # will duplicate another dependency: $srcdir/Makefile.in. - host_xmake_file=../Makefile.in - fi - - # Define variables host_canonical, build_canonical, and target_canonical - # because some Cygnus local changes in the Makefile depend on them. - echo host_canonical = ${canon_host} > Makefile.xx - echo target_canonical = ${canon_target} >> Makefile.xx - echo build_canonical = ${canon_build} >> Makefile.xx - cat Makefile.tem >> Makefile.xx - mv Makefile.xx Makefile.tem - - # Conditionalize the makefile for this target machine. - if [ -f ${mainsrcdir}/config/${tmake_file} ] - then - rm -f Makefile.xx - sed -e "/####target/ r ${mainsrcdir}/config/${tmake_file}" Makefile.tem > Makefile.xx - echo "Merged ${tmake_file}." - rm -f Makefile.tem - mv Makefile.xx Makefile.tem - else - # Say in the makefile that there is no tmake_file, - # by using a name which (when interpreted relative to $srcdir/config) - # will duplicate another dependency: $srcdir/Makefile.in. - tmake_file=../Makefile.in - fi - - # Conditionalize the makefile for this site. - if [ -f ${mainsrcdir}/config/ms-${site} ] - then - rm -f Makefile.xx - sed -e "/####site/ r ${mainsrcdir}/config/ms-${site}" Makefile.tem > Makefile.xx - echo "Merged ms-${site}." - rm -f Makefile.tem - mv Makefile.xx Makefile.tem - fi - - # If this is a cross compilation, and we have newlib in the build - # tree, then define inhibit_libc in LIBGCC2_CFLAGS. This will cause - # __eprintf to be left out of libgcc.a, but that's OK because newlib - # has its own version of assert.h. - if [ x$host != x$target ]; then - sed -e 's/^\(LIBGCC2_CFLAGS[ ]*=[ ]*\)/\1-Dinhibit_libc /' Makefile.tem > Makefile.tem2 - rm -f Makefile.tem - mv Makefile.tem2 Makefile.tem - fi - - # Remove all formfeeds, since some Makes get confused by them. - # Also arrange to give the variables `target', `host_xmake_file', - # `tmake_file', `prefix', `local_prefix', `exec_prefix', `FIXINCLUDES' - # and `INSTALL_HEADERS_DIR' values in the Makefile from the values - # they have in this script. - rm -f Makefile.xx - sed -e "s/ //" -e "s/^target=.*$/target=${target}/" \ - -e "s|^xmake_file=.*$|xmake_file=${host_xmake_file}|" \ - -e "s|^tmake_file=.*$|tmake_file=${tmake_file}|" \ - -e "s|^version=.*$|version=${version}|" \ - -e "s|^prefix[ ]*=.*|prefix = $prefix|" \ - -e "s|^local_prefix[ ]*=.*|local_prefix = $local_prefix|" \ - -e "s|^exec_prefix[ ]*=.*|exec_prefix = $exec_prefix|" \ - -e "s|^objdir[ ]*=.*|objdir=`pwd`|" \ - Makefile.tem > Makefile.xx - rm -f Makefile.tem - mv Makefile.xx Makefile.tem - - # Install Makefile for real, after making final changes. - # Define macro CROSS_COMPILE in compilation if this is a cross-compiler. - # Also use all.cross instead of all.internal, and add cross-make to Makefile. - if [ x$canon_host = x$canon_target ] - then - rm -f Makefile - if [ x$canon_host = x$canon_build ] - then - mv Makefile.tem Makefile - else - # When building gcc with a cross-compiler, we need to fix a - # few things. - echo "build= $build" > Makefile - sed -e "/####build/ r ${mainsrcdir}/build-make" Makefile.tem >> Makefile - rm -f Makefile.tem Makefile.xx - fi - else - rm -f Makefile - echo "CROSS=-DCROSS_COMPILE" > Makefile - sed -e "/####cross/ r ${mainsrcdir}/cross-make" Makefile.tem >> Makefile - rm -f Makefile.tem Makefile.xx - fi - - echo "Created \`$subdir/Makefile'." - - if [ xx${vint} != xx ] - then - vintmsg=" (vint)" - fi - - # Describe the chosen configuration in config.status. - # Make that file a shellscript which will reestablish the same configuration. - - rm -f config.bak - if [ -f config.status ]; then mv -f config.status config.bak; fi - - echo "#!/bin/sh - # This directory was configured as follows: -cd $invsubdir; ${progname}" $arguments > config.new - echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new - chmod a+x config.new - - # If we aren't executing the configure script in . - if [ x$subdir != x. ] - then - if [ -f $srcdir/configure ] - then - echo "Running \`${CONFIG_SHELL-sh} $srcdir/configure $arguments\'" - ${CONFIG_SHELL-sh} $srcdir/configure $arguments - echo "${srcdir}/configure" $arguments >> config.new - echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new - fi - fi - - if [ -f config.bak ] && cmp config.bak config.new >/dev/null 2>/dev/null; - then - mv -f config.bak config.status - rm -f config.new - else - mv -f config.new config.status - rm -f config.bak - fi - - cd $STARTDIR -done # end of current-dir SUBDIRS loop - -srcdir=$savesrcdir - -# Describe the chosen configuration in config.status. -# Make that file a shellscript which will reestablish the same configuration. -echo "#!/bin/sh -# This directory was configured as follows: -${progname}" $arguments > config.new -echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new -chmod a+x config.new -if [ -f config.bak ] && cmp config.bak config.new >/dev/null 2>/dev/null; -then - mv -f config.bak config.status - rm -f config.new -else - mv -f config.new config.status - rm -f config.bak -fi - -exit 0 diff --git a/gcc/ch/convert.c b/gcc/ch/convert.c deleted file mode 100644 index e7c93109bd0..00000000000 --- a/gcc/ch/convert.c +++ /dev/null @@ -1,1249 +0,0 @@ -/* Language-level data type conversion for GNU CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -/* This file contains the functions for converting CHILL expressions - to different data types. The only entry point is `convert'. - Every language front end must have a `convert' function - but what kind of conversions it does will depend on the language. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "flags.h" -#include "convert.h" -#include "lex.h" -#include "toplev.h" -#include "output.h" - -extern tree bit_one_node, bit_zero_node; -extern tree string_one_type_node; -extern tree bitstring_one_type_node; - -static tree convert_to_reference PARAMS ((tree, tree)); -static tree convert_to_boolean PARAMS ((tree, tree)); -static tree convert_to_char PARAMS ((tree, tree)); -#if 0 -static tree base_type_size_in_bytes PARAMS ((tree)); -#endif -static tree remove_tree_element PARAMS ((tree, tree *)); -static tree check_ps_range PARAMS ((tree, tree, tree)); -static tree digest_powerset_tuple PARAMS ((tree, tree)); -static tree digest_structure_tuple PARAMS ((tree, tree)); -static tree digest_array_tuple PARAMS ((tree, tree, int)); -static tree convert1 PARAMS ((tree, tree)); - -static tree -convert_to_reference (reftype, expr) - tree reftype, expr; -{ - while (TREE_CODE (expr) == NOP_EXPR) /* RETYPE_EXPR */ - expr = TREE_OPERAND (expr, 0); - - if (! CH_LOCATION_P (expr)) - error("internal error: trying to make loc-identity with non-location"); - else - { - mark_addressable (expr); - return fold (build1 (ADDR_EXPR, reftype, expr)); - } - - return error_mark_node; -} - -tree -convert_from_reference (expr) - tree expr; -{ - tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr); - TREE_READONLY (e) = TREE_READONLY (expr); - return e; -} - -/* Convert EXPR to a boolean type. */ - -static tree -convert_to_boolean (type, expr) - tree type, expr; -{ - register tree intype = TREE_TYPE (expr); - - if (integer_zerop (expr)) - return boolean_false_node; - if (integer_onep (expr)) - return boolean_true_node; - - /* Convert a singleton bitstring to a Boolean. - Needed if flag_old_strings. */ - if (CH_BOOLS_ONE_P (intype)) - { - if (TREE_CODE (expr) == CONSTRUCTOR) - { - tree valuelist = TREE_OPERAND (expr, 1); - if (valuelist == NULL_TREE) - return boolean_false_node; - if (TREE_CHAIN (valuelist) == NULL_TREE - && TREE_PURPOSE (valuelist) == NULL_TREE - && integer_zerop (TREE_VALUE (valuelist))) - return boolean_true_node; - } - return build_chill_bitref (expr, - build_tree_list (NULL_TREE, - integer_zero_node)); - } - - if (INTEGRAL_TYPE_P (intype)) - return build1 (CONVERT_EXPR, type, expr); - - error ("cannot convert to a boolean mode"); - return boolean_false_node; -} - -/* Convert EXPR to a char type. */ - -static tree -convert_to_char (type, expr) - tree type, expr; -{ - register tree intype = TREE_TYPE (expr); - register enum chill_tree_code form = TREE_CODE (intype); - - if (form == CHAR_TYPE) - return build1 (NOP_EXPR, type, expr); - - /* Convert a singleton string to a char. - Needed if flag_old_strings. */ - if (CH_CHARS_ONE_P (intype)) - { - if (TREE_CODE (expr) == STRING_CST) - { - expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0); - TREE_TYPE (expr) = char_type_node; - return expr; - } - else - return build (ARRAY_REF, char_type_node, expr, integer_zero_node); - - } - - /* For now, assume it will always fit */ - if (form == INTEGER_TYPE) - return build1 (CONVERT_EXPR, type, expr); - - error ("cannot convert to a char mode"); - - { - register tree tem = build_int_2 (0, 0); - TREE_TYPE (tem) = type; - return tem; - } -} - -#if 0 -static tree -base_type_size_in_bytes (type) - tree type; -{ - if (type == NULL_TREE - || TREE_CODE (type) == ERROR_MARK - || TREE_CODE (type) != ARRAY_TYPE) - return error_mark_node; - return size_in_bytes (TREE_TYPE (type)); -} -#endif - -/* - * build a singleton array type, of TYPE objects. - */ -tree -build_array_type_for_scalar (type) - tree type; -{ - /* KLUDGE */ - if (type == char_type_node) - return build_string_type (type, integer_one_node); - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - - return build_chill_array_type - (type, - tree_cons (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_zero_node, integer_zero_node), - NULL_TREE), - 0, NULL_TREE); - -} - -#if 0 -static tree -unreferenced_type_of (type) - tree type; -{ - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - while (TREE_CODE (type) == REFERENCE_TYPE) - type = TREE_TYPE (type); - return type; -} -#endif - - -/* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY. - Return the TREE_LIST node, or NULL_TREE on failure. */ - -static tree -remove_tree_element (key, listp) - tree *listp; - tree key; -{ - tree node = *listp; - for ( ; node; listp = &TREE_CHAIN (node), node = *listp) - { - if (TREE_PURPOSE (node) == key) - { - *listp = TREE_CHAIN (node); - TREE_CHAIN (node) = NULL_TREE; - return node; - } - } - return NULL_TREE; -} - -/* This is quite the same as check_range in actions.c, but with - different error message. */ - -static tree -check_ps_range (value, lo_limit, hi_limit) - tree value; - tree lo_limit; - tree hi_limit; -{ - tree check = test_range (value, lo_limit, hi_limit); - - if (!integer_zerop (check)) - { - if (TREE_CODE (check) == INTEGER_CST) - { - error ("powerset tuple element out of range"); - return error_mark_node; - } - else - value = check_expression (value, check, - ridpointers[(int) RID_RANGEFAIL]); - } - return value; -} - -static tree -digest_powerset_tuple (type, inits) - tree type; - tree inits; -{ - tree list; - tree result; - tree domain = TYPE_DOMAIN (type); - int i = 0; - int is_erroneous = 0, is_constant = 1, is_simple = 1; - if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK) - return error_mark_node; - for (list = TREE_OPERAND (inits, 1); list; list = TREE_CHAIN (list), i++) - { - tree val = TREE_VALUE (list); - if (TREE_CODE (val) == ERROR_MARK) - { - is_erroneous = 1; - continue; - } - if (!TREE_CONSTANT (val)) - is_constant = 0; - else if (!initializer_constant_valid_p (val, TREE_TYPE (val))) - is_simple = 0; - if (! CH_COMPATIBLE (val, domain)) - { - error ("incompatible member of powerset tuple (at position #%d)", i); - is_erroneous = 1; - continue; - } - /* check range of value */ - val = check_ps_range (val, TYPE_MIN_VALUE (domain), - TYPE_MAX_VALUE (domain)); - if (TREE_CODE (val) == ERROR_MARK) - { - is_erroneous = 1; - continue; - } - - /* Updating the list in place is in principle questionable, - but I can't think how it could hurt. */ - TREE_VALUE (list) = convert (domain, val); - - val = TREE_PURPOSE (list); - if (val == NULL_TREE) - continue; - - if (TREE_CODE (val) == ERROR_MARK) - { - is_erroneous = 1; - continue; - } - if (! CH_COMPATIBLE (val, domain)) - { - error ("incompatible member of powerset tuple (at position #%d)", i); - is_erroneous = 1; - continue; - } - val = check_ps_range (val, TYPE_MIN_VALUE (domain), - TYPE_MAX_VALUE (domain)); - if (TREE_CODE (val) == ERROR_MARK) - { - is_erroneous = 1; - continue; - } - TREE_PURPOSE (list) = convert (domain, val); - if (!TREE_CONSTANT (val)) - is_constant = 0; - else if (!initializer_constant_valid_p (val, TREE_TYPE (val))) - is_simple = 0; - } - result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1)); - if (is_erroneous) - return error_mark_node; - if (is_constant) - TREE_CONSTANT (result) = 1; - if (is_constant && is_simple) - TREE_STATIC (result) = 1; - return result; -} - -static tree -digest_structure_tuple (type, inits) - tree type; - tree inits; -{ - tree elements = CONSTRUCTOR_ELTS (inits); - tree values = NULL_TREE; - int is_constant = 1; - int is_simple = 1; - int is_erroneous = 0; - tree field; - int labelled_elements = 0; - int unlabelled_elements = 0; - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - { - if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE) - { /* Regular fixed field. */ - tree value = remove_tree_element (DECL_NAME (field), &elements); - - if (value) - labelled_elements++; - else if (elements && TREE_PURPOSE (elements) == NULL_TREE) - { - value = elements; - elements = TREE_CHAIN (elements); - unlabelled_elements++; - } - - if (value) - { - tree val; - char msg[120]; - sprintf (msg, "initializer for field `%.80s'", - IDENTIFIER_POINTER (DECL_NAME (field))); - val = chill_convert_for_assignment (TREE_TYPE (field), - TREE_VALUE (value), msg); - if (TREE_CODE (val) == ERROR_MARK) - is_erroneous = 1; - else - { - TREE_VALUE (value) = val; - TREE_CHAIN (value) = values; - TREE_PURPOSE (value) = field; - values = value; - if (TREE_CODE (val) == ERROR_MARK) - is_erroneous = 1; - else if (!TREE_CONSTANT (val)) - is_constant = 0; - else if (!initializer_constant_valid_p (val, - TREE_TYPE (val))) - is_simple = 0; - } - } - else - { - pedwarn ("no initializer value for fixed field `%s'", - IDENTIFIER_POINTER (DECL_NAME (field))); - } - } - else - { - tree variant; - tree selected_variant = NULL_TREE; - tree variant_values = NULL_TREE; - - /* In a tagged variant structure mode, try to figure out - (from the fixed fields), which is the selected variant. */ - if (TYPE_TAGFIELDS (TREE_TYPE (field))) - { - for (variant = TYPE_FIELDS (TREE_TYPE (field)); - variant; variant = TREE_CHAIN (variant)) - { - tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant)); - tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field)); - if (DECL_NAME (variant) == ELSE_VARIANT_NAME) - { - selected_variant = variant; - break; - } - for (; tag_labels && tag_fields; - tag_labels = TREE_CHAIN (tag_labels), - tag_fields = TREE_CHAIN (tag_fields)) - { - tree tag_value = values; - int found = 0; - tree tag_decl = TREE_VALUE (tag_fields); - tree tag_value_set = TREE_VALUE (tag_labels); - for ( ; tag_value; tag_value = TREE_CHAIN (tag_value)) - { - if (TREE_PURPOSE (tag_value) == tag_decl) - { - tag_value = TREE_VALUE (tag_value); - break; - } - } - if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST) - { - pedwarn ("non-constant value for tag field `%s'", - IDENTIFIER_POINTER (DECL_NAME (tag_decl))); - goto get_values; - } - - /* Check if the value of the tag (as given in a - previous field) matches the case label list. */ - for (; tag_value_set; - tag_value_set = TREE_CHAIN (tag_value_set)) - { - if (tree_int_cst_equal (TREE_VALUE (tag_value_set), - tag_value)) - { - found = 1; - break; - } - } - if (!found) - break; - } - if (!tag_fields) - { - selected_variant = variant; - break; - } - } - } - get_values: - for (variant = TYPE_FIELDS (TREE_TYPE (field)); - variant; variant = TREE_CHAIN (variant)) - { - tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant)); - tree vfield; - for (vfield = vfield0; vfield; vfield = TREE_CHAIN (vfield)) - { - tree value = remove_tree_element (DECL_NAME (vfield), - &elements); - - if (value) - labelled_elements++; - else if (variant == selected_variant - && elements && TREE_PURPOSE (elements) == NULL_TREE) - { - value = elements; - elements = TREE_CHAIN (elements); - unlabelled_elements++; - } - - if (value) - { - if (selected_variant && selected_variant != variant) - { - error ("field `%s' in wrong variant", - IDENTIFIER_POINTER (DECL_NAME (vfield))); - is_erroneous = 1; - } - else - { - if (!selected_variant && vfield != vfield0) - pedwarn ("missing variant fields (at least `%s')", - IDENTIFIER_POINTER (DECL_NAME (vfield0))); - selected_variant = variant; - if (CH_COMPATIBLE (TREE_VALUE (value), - TREE_TYPE (vfield))) - { - tree val = convert (TREE_TYPE (vfield), - TREE_VALUE (value)); - TREE_PURPOSE (value) = vfield; - TREE_VALUE (value) = val; - TREE_CHAIN (value) = variant_values; - variant_values = value; - if (TREE_CODE (val) == ERROR_MARK) - is_erroneous = 1; - else if (!TREE_CONSTANT (val)) - is_constant = 0; - else if (!initializer_constant_valid_p - (val, TREE_TYPE (val))) - is_simple = 0; - } - else - { - is_erroneous = 1; - error ("bad initializer for field `%s'", - IDENTIFIER_POINTER (DECL_NAME (vfield))); - } - } - } - else if (variant == selected_variant) - { - pedwarn ("no initializer value for variant field `%s'", - IDENTIFIER_POINTER (DECL_NAME (field))); - } - } - } - if (selected_variant == NULL_TREE) - pedwarn ("no selected variant"); - else - { - variant_values = build (CONSTRUCTOR, - TREE_TYPE (selected_variant), - NULL_TREE, nreverse (variant_values)); - variant_values - = build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE, - build_tree_list (selected_variant, variant_values)); - values = tree_cons (field, variant_values, values); - } - } - } - - if (labelled_elements && unlabelled_elements) - pedwarn ("mixture of labelled and unlabelled tuple elements"); - - /* Check for unused initializer elements. */ - unlabelled_elements = 0; - for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements)) - { - if (TREE_PURPOSE (elements) == NULL_TREE) - unlabelled_elements++; - else - { - if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0) - error ("probably not a structure tuple"); - else - error ("excess initializer for field `%s'", - IDENTIFIER_POINTER (TREE_PURPOSE (elements))); - is_erroneous = 1; - } - } - if (unlabelled_elements) - { - error ("excess unnamed initializers"); - is_erroneous = 1; - } - - CONSTRUCTOR_ELTS (inits) = nreverse (values); - TREE_TYPE (inits) = type; - if (is_erroneous) - return error_mark_node; - if (is_constant) - TREE_CONSTANT (inits) = 1; - if (is_constant && is_simple) - TREE_STATIC (inits) = 1; - return inits; -} - -/* Return a Chill representation of the INTEGER_CST VAL. - The result may be in a static buffer, */ - -const char * -display_int_cst (val) - tree val; -{ - static char buffer[50]; - HOST_WIDE_INT x; - tree fields; - if (TREE_CODE (val) != INTEGER_CST) - return "<not a constant>"; - - x = TREE_INT_CST_LOW (val); - - switch (TREE_CODE (TREE_TYPE (val))) - { - case BOOLEAN_TYPE: - if (x == 0) - return "FALSE"; - if (x == 1) - return "TRUE"; - goto int_case; - case CHAR_TYPE: - if (x == '^') - strcpy (buffer, "'^^'"); - else if (x == '\n') - strcpy (buffer, "'^J'"); - else if (x < ' ' || x > '~') - sprintf (buffer, "'^(%u)'", (unsigned int) x); - else - sprintf (buffer, "'%c'", (char) x); - return buffer; - case ENUMERAL_TYPE: - for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE; - fields = TREE_CHAIN (fields)) - { - if (tree_int_cst_equal (TREE_VALUE (fields), val)) - return IDENTIFIER_POINTER (TREE_PURPOSE (fields)); - } - goto int_case; - case POINTER_TYPE: - if (x == 0) - return "NULL"; - goto int_case; - int_case: - default: - /* This code is derived from print-tree.c:print_code_brief. */ - if (TREE_INT_CST_HIGH (val) == 0) - sprintf (buffer, -#if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT - "%1u", -#else - "%1lu", -#endif - x); - else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0) - sprintf (buffer, -#if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT - "-%1u", -#else - "-%1lu", -#endif - -x); - else - sprintf (buffer, -#if HOST_BITS_PER_WIDE_INT == 64 -#if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT - "H'%lx%016lx", -#else - "H'%x%016x", -#endif -#else -#if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT - "H'%lx%08lx", -#else - "H'%x%08x", -#endif -#endif - TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val)); - return buffer; - } -} - -static tree -digest_array_tuple (type, init, allow_missing_elements) - tree type; - tree init; - int allow_missing_elements; -{ - tree element = CONSTRUCTOR_ELTS (init); - int is_constant = 1; - int is_simple = 1; - tree element_type = TREE_TYPE (type); - tree default_value = NULL_TREE; - tree element_list = NULL_TREE; - tree domain_min; - tree domain_max; - tree *ptr = &element_list; - int errors = 0; - int labelled_elements = 0; - int unlabelled_elements = 0; - tree first, last = NULL_TREE; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - - domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); - domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - - if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST) - { - error ("non-constant start index for tuple"); - return error_mark_node; - } - if (TREE_CODE (domain_max) != INTEGER_CST) - is_constant = 0; - - if (TREE_CODE (type) != ARRAY_TYPE) - abort (); - - for ( ; element != NULL_TREE; element = TREE_CHAIN (element)) - { - tree purpose = TREE_PURPOSE (element); - tree value = TREE_VALUE (element); - - if (purpose == NULL_TREE) - { - if (last == NULL_TREE) - first = domain_min; - else - { - HOST_WIDE_INT new_lo, new_hi; - add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last), - 1, 0, - &new_lo, &new_hi); - first = build_int_2 (new_lo, new_hi); - TREE_TYPE (first) = TYPE_DOMAIN (type); - } - last = first; - unlabelled_elements++; - } - else - { - labelled_elements++; - if (TREE_CODE (purpose) == INTEGER_CST) - first = last = purpose; - else if (TREE_CODE (purpose) == TYPE_DECL - && discrete_type_p (TREE_TYPE (purpose))) - { - first = TYPE_MIN_VALUE (TREE_TYPE (purpose)); - last = TYPE_MAX_VALUE (TREE_TYPE (purpose)); - } - else if (TREE_CODE (purpose) != RANGE_EXPR) - { - error ("invalid array tuple label"); - errors++; - continue; - } - else if (TREE_OPERAND (purpose, 0) == NULL_TREE) - first = last = NULL_TREE; /* Default value. */ - else - { - first = TREE_OPERAND (purpose, 0); - last = TREE_OPERAND (purpose, 1); - } - if ((first != NULL && TREE_CODE (first) != INTEGER_CST) - || (last != NULL && TREE_CODE (last) != INTEGER_CST)) - { - error ("non-constant array tuple index range"); - errors++; - } - } - - if (! CH_COMPATIBLE (value, element_type)) - { - const char *err_val_name = - first ? display_int_cst (first) : "(default)"; - error ("incompatible array tuple element %s", err_val_name); - value = error_mark_node; - } - else - value = convert (element_type, value); - if (TREE_CODE (value) == ERROR_MARK) - errors++; - else if (!TREE_CONSTANT (value)) - is_constant = 0; - else if (!initializer_constant_valid_p (value, TREE_TYPE (value))) - is_simple = 0; - - if (first == NULL_TREE) - { - if (default_value != NULL) - { - error ("multiple (*) or (ELSE) array tuple labels"); - errors++; - } - default_value = value; - continue; - } - - if (first != last && tree_int_cst_lt (last, first)) - { - error ("empty range in array tuple"); - errors++; - continue; - } - - ptr = &element_list; - -#define MAYBE_RANGE_OP(PURPOSE, OPNO) \ - (TREE_CODE (PURPOSE) == RANGE_EXPR ? TREE_OPERAND (PURPOSE, OPNO): PURPOSE) -#define CONSTRUCTOR_ELT_LO(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 0) -#define CONSTRUCTOR_ELT_HI(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 1) - while (*ptr && tree_int_cst_lt (last, - CONSTRUCTOR_ELT_LO (*ptr))) - ptr = &TREE_CHAIN (*ptr); - if (*ptr && ! tree_int_cst_lt (CONSTRUCTOR_ELT_HI (*ptr), first)) - { - const char *err_val_name = display_int_cst (first); - error ("array tuple has duplicate index %s", err_val_name); - errors++; - continue; - } - if ((ptr == &element_list && tree_int_cst_lt (domain_max, last)) - || (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min))) - { - if (purpose) - error ("array tuple index out of range"); - else if (errors == 0) - error ("too many array tuple values"); - errors++; - continue; - } - if (! tree_int_cst_lt (first, last)) - purpose = first; - else if (purpose == NULL_TREE || TREE_CODE (purpose) != RANGE_EXPR) - purpose = build_nt (RANGE_EXPR, first, last); - *ptr = tree_cons (purpose, value, *ptr); - } - - element_list = nreverse (element_list); - - /* For each missing element, set it to the default value, - if there is one. Otherwise, emit an error. */ - - if (errors == 0 - && (!allow_missing_elements || default_value != NULL_TREE)) - { - /* Iterate over each *gap* between specified elements/ranges. */ - tree prev_elt; - if (element_list && - tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min)) - { - ptr = &TREE_CHAIN (element_list); - prev_elt = element_list; - } - else - { - prev_elt = NULL_TREE; - ptr = &element_list; - } - for (;;) - { - tree first, last; - /* Calculate the first element of the gap. */ - if (prev_elt == NULL_TREE) - first = domain_min; - else - { - first = CONSTRUCTOR_ELT_HI (prev_elt); - if (tree_int_cst_equal (first, domain_max)) - break; /* We're done. Avoid overflow below. */ - first = copy_node (first); - add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first), - 1, 0, - &TREE_INT_CST_LOW (first), - &TREE_INT_CST_HIGH (first)); - } - /* Calculate the last element of the gap. */ - if (*ptr) - last = fold (build (MINUS_EXPR, integer_type_node, - CONSTRUCTOR_ELT_LO (*ptr), - integer_one_node)); - else - last = domain_max; - - if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first)) - ; /* Empty "gap" - no missing elements. */ - else if (default_value) - { - tree purpose; - if (tree_int_cst_equal (first, last)) - purpose = first; - else - purpose = build_nt (RANGE_EXPR, first, last); - *ptr = tree_cons (purpose, default_value, *ptr); - } - else - { - const char *err_val_name = display_int_cst (first); - if (TREE_CODE (last) != INTEGER_CST) - error ("dynamic array tuple without (*) or (ELSE)"); - else if (tree_int_cst_equal (first, last)) - error ("missing array tuple element %s", err_val_name); - else - { - char *first_name = (char *) - xmalloc (strlen (err_val_name) + 1); - strcpy (first_name, err_val_name); - err_val_name = display_int_cst (last); - error ("missing array tuple elements %s : %s", - first_name, err_val_name); - free (first_name); - } - errors++; - } - if (*ptr == NULL_TREE) - break; - prev_elt = *ptr; - ptr = &TREE_CHAIN (*ptr); - } - } - if (errors) - return error_mark_node; - - element = build (CONSTRUCTOR, type, NULL_TREE, element_list); - TREE_CONSTANT (element) = is_constant; - if (is_constant && is_simple) - TREE_STATIC (element) = 1; - if (labelled_elements && unlabelled_elements) - pedwarn ("mixture of labelled and unlabelled tuple elements"); - return element; -} - -/* This function is needed because no-op CHILL conversions are not fully - understood by the initialization machinery. This function should only - be called when a conversion truly is a no-op. */ - -static tree -convert1 (type, expr) - tree type, expr; -{ - int was_constant = TREE_CONSTANT (expr); - STRIP_NOPS (expr); - was_constant |= TREE_CONSTANT (expr); - expr = copy_node (expr); - TREE_TYPE (expr) = type; - if (TREE_CONSTANT (expr) != was_constant) abort (); - TREE_CONSTANT (expr) = was_constant; - return expr; -} - -/* Create an expression whose value is that of EXPR, - converted to type TYPE. The TREE_TYPE of the value - is always TYPE. This function implements all reasonable - conversions; callers should filter out those that are - not permitted by the language being compiled. - - In CHILL, we assume that the type is Compatible with the - Class of expr, and generally complain otherwise. - However, convert is more general (e.g. allows enum<->int - conversion), so there should probably be at least two routines. - Maybe add something like convert_for_assignment. FIXME. */ - -tree -convert (type, expr) - tree type, expr; -{ - register tree e = expr; - register enum chill_tree_code code; - int type_varying; - - if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK) - return error_mark_node; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - - code = TREE_CODE (type); - - if (type == TREE_TYPE (e)) - return e; - - if (TREE_TYPE (e) != NULL_TREE - && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE) - e = convert_from_reference (e); - - /* Support for converting *to* a reference type is limited; - it is only here as a convenience for loc-identity declarations, - and loc parameters. */ - if (code == REFERENCE_TYPE) - return convert_to_reference (type, e); - - /* if expression was untyped because of its context (an if_expr or case_expr - in a tuple, perhaps) just apply the type */ - if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == ERROR_MARK) - { - TREE_TYPE (e) = type; - return e; - } - - /* Turn a NULL keyword into [0, 0] for an instance */ - if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node) - { - tree field0 = TYPE_FIELDS (type); - tree field1 = TREE_CHAIN (field0); - e = build (CONSTRUCTOR, type, NULL_TREE, - tree_cons (field0, integer_zero_node, - tree_cons (field1, integer_zero_node, - NULL_TREE))); - TREE_CONSTANT (e) = 1; - TREE_STATIC (e) = 1; - return e; - } - - /* Turn a pointer into a function pointer for a procmode */ - if (TREE_CODE (type) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE - && expr == null_pointer_node) - return convert1 (type, expr); - - /* turn function_decl expression into a pointer to - that function */ - if (TREE_CODE (expr) == FUNCTION_DECL - && TREE_CODE (type) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) - { - e = build1 (ADDR_EXPR, type, expr); - TREE_CONSTANT (e) = 1; - return e; - } - - if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE) - e = varying_to_slice (e); - type_varying = chill_varying_type_p (type); - - /* Convert a char to a singleton string. - Needed for compatibility with 1984 version of Z.200. */ - if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == CHAR_TYPE - && (CH_CHARS_ONE_P (type) || type_varying)) - { - if (TREE_CODE (e) == INTEGER_CST) - { - char ch = TREE_INT_CST_LOW (e); - e = build_chill_string (1, &ch); - } - else - e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE, - tree_cons (NULL_TREE, e, NULL_TREE)); - } - - /* Convert a Boolean to a singleton bitstring. - Needed for compatibility with 1984 version of Z.200. */ - if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == BOOLEAN_TYPE - && (CH_BOOLS_ONE_P (type) || type_varying)) - { - if (TREE_CODE (e) == INTEGER_CST) - e = integer_zerop (e) ? bit_zero_node : bit_one_node; - else - e = build (COND_EXPR, bitstring_one_type_node, - e, bit_one_node, bit_zero_node); - } - - if (type_varying) - { - tree nentries; - tree field0 = TYPE_FIELDS (type); - tree field1 = TREE_CHAIN (field0); - tree orig_e = e; - tree target_array_type = TREE_TYPE (field1); - tree needed_padding; - tree padding_max_size = 0; - int orig_e_constant = TREE_CONSTANT (orig_e); - if (TREE_TYPE (e) != NULL_TREE - && TREE_CODE (TREE_TYPE (e)) == ARRAY_TYPE) - { - /* Note that array_type_nelts returns 1 less than the size. */ - nentries = array_type_nelts (TREE_TYPE (e)); - needed_padding = fold (build (MINUS_EXPR, integer_type_node, - array_type_nelts (target_array_type), - nentries)); - if (TREE_CODE (needed_padding) != INTEGER_CST) - { - padding_max_size = size_in_bytes (TREE_TYPE (e)); - if (TREE_CODE (padding_max_size) != INTEGER_CST) - padding_max_size = TYPE_ARRAY_MAX_SIZE (TREE_TYPE (e)); - } - nentries = fold (build (PLUS_EXPR, integer_type_node, - nentries, integer_one_node)); - } - else if (TREE_CODE (e) == CONSTRUCTOR) - { - HOST_WIDE_INT init_cnt = 0; - tree chaser = CONSTRUCTOR_ELTS (e); - for ( ; chaser; chaser = TREE_CHAIN (chaser)) - init_cnt++; /* count initializer elements */ - nentries = build_int_2 (init_cnt, 0); - needed_padding = integer_zero_node; - if (TREE_TYPE (e) == NULL_TREE) - e = digest_array_tuple (TREE_TYPE (field1), e, 1); - orig_e_constant = TREE_CONSTANT (e); - } - else - { - error ("initializer is not an array or string mode"); - return error_mark_node; - } -#if 0 - FIXME check that nentries will fit in type; -#endif - if (!integer_zerop (needed_padding)) - { - tree padding, padding_type, padding_range; - if (TREE_CODE (needed_padding) == INTEGER_CST - && (long)TREE_INT_CST_LOW (needed_padding) < 0) - { - error ("destination is too small"); - return error_mark_node; - } - padding_range = build_chill_range_type (NULL_TREE, integer_one_node, - needed_padding); - padding_type - = build_simple_array_type (TREE_TYPE (target_array_type), - padding_range, NULL_TREE); - TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size; - if (CH_CHARS_TYPE_P (target_array_type)) - MARK_AS_STRING_TYPE (padding_type); - padding = build (UNDEFINED_EXPR, padding_type); - if (TREE_CONSTANT (e)) - e = build_chill_binary_op (CONCAT_EXPR, e, padding); - else - e = build (CONCAT_EXPR, target_array_type, e, padding); - } - e = convert (TREE_TYPE (field1), e); - /* We build this constructor by hand (rather than going through - digest_structure_tuple), to avoid some type-checking problem. - E.g. type may have non-null novelty, but its field1 will - have non-novelty. */ - e = build (CONSTRUCTOR, type, NULL_TREE, - tree_cons (field0, nentries, - build_tree_list (field1, e))); - /* following was wrong, cause orig_e never will be TREE_CONSTANT. e - may become constant after digest_array_tuple. */ - if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */ - { - TREE_CONSTANT (e) = 1; - if (TREE_STATIC (nentries) && TREE_STATIC (orig_e)) - TREE_STATIC (e) = 1; - } - } - if (TREE_TYPE (e) == NULL_TREE) - { - if (TREE_CODE (e) == CONSTRUCTOR) - { - if (TREE_CODE (type) == SET_TYPE) - return digest_powerset_tuple (type, e); - else if (TREE_CODE (type) == RECORD_TYPE) - return digest_structure_tuple (type, e); - else if (TREE_CODE (type) == ARRAY_TYPE) - return digest_array_tuple (type, e, 0); - else - abort (); - } - else if (TREE_CODE (e) == COND_EXPR) - e = build (COND_EXPR, type, - TREE_OPERAND (e, 0), - convert (type, TREE_OPERAND (e, 1)), - convert (type, TREE_OPERAND (e, 2))); - else if (TREE_CODE (e) == CASE_EXPR) - TREE_TYPE (e) = type; - else - { - error ("internal error: unknown type of expression"); - return error_mark_node; - } - } - - if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)) - || (CH_NOVELTY (type) != NULL_TREE - && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e)))) - return convert1 (type, e); - - if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) - { - error ("void value not ignored as it ought to be"); - return error_mark_node; - } - if (code == VOID_TYPE) - return build1 (CONVERT_EXPR, type, e); - - if (code == SET_TYPE) - return convert1 (type, e); - - if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) - { - if (flag_old_strings) - { - if (CH_CHARS_ONE_P (TREE_TYPE (e))) - e = convert_to_char (char_type_node, e); - else if (CH_BOOLS_ONE_P (TREE_TYPE (e))) - e = convert_to_boolean (boolean_type_node, e); - } - return fold (convert_to_integer (type, e)); - } - if (code == POINTER_TYPE) - return fold (convert_to_pointer (type, e)); - if (code == REAL_TYPE) - return fold (convert_to_real (type, e)); - if (code == BOOLEAN_TYPE) - return fold (convert_to_boolean (type, e)); - if (code == CHAR_TYPE) - return fold (convert_to_char (type, e)); - - if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e))) - { - /* The mode of the expression is different from that of the type. - Earlier checks should have tested against different lengths. - But even if the lengths are the same, it is possible that one - type is a static type (and hence could be say SImode), while the - other type is dynamic type (and hence is BLKmode). - This causes problems when emitting instructions. */ - tree ee = build1 (INDIRECT_REF, type, - build1 (NOP_EXPR, build_pointer_type (type), - build1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (e)), - e))); - TREE_READONLY (ee) = TYPE_READONLY (type); - return ee; - } - - /* The default! */ - return convert1 (type, e); -} - -/* Return an expression whose value is EXPR, but whose class is CLASS. */ - -tree -convert_to_class (class, expr) - struct ch_class class; - tree expr; -{ - switch (class.kind) - { - case CH_NULL_CLASS: - case CH_ALL_CLASS: - return expr; - case CH_DERIVED_CLASS: - if (TREE_TYPE (expr) != class.mode) - expr = convert (class.mode, expr); - if (!CH_DERIVED_FLAG (expr)) - { - expr = copy_node (expr); - CH_DERIVED_FLAG (expr) = 1; - } - return expr; - case CH_VALUE_CLASS: - case CH_REFERENCE_CLASS: - if (TREE_TYPE (expr) != class.mode) - expr = convert (class.mode, expr); - if (CH_DERIVED_FLAG (expr)) - { - expr = copy_node (expr); - CH_DERIVED_FLAG (expr) = 0; - } - return expr; - } - return expr; -} diff --git a/gcc/ch/decl.c b/gcc/ch/decl.c deleted file mode 100644 index 11a05e00218..00000000000 --- a/gcc/ch/decl.c +++ /dev/null @@ -1,4967 +0,0 @@ -/* Process declarations and variables for GNU CHILL compiler. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -/* Process declarations and symbol lookup for CHILL front end. - Also constructs types; the standard scalar types at initialization, - and structure, union, array and enum types when they are declared. */ - -/* NOTES on Chill name resolution - - Chill allows one to refer to an identifier that is declared later in - the same Group. Hence, a single pass over the code (as in C) is - insufficient. - - This implementation uses two complete passes over the source code, - plus some extra passes over internal data structures. - - Loosely, during pass 1, a 'scope' object is created for each Chill - reach. Each scope object contains a list of 'decl' objects, - one for each 'defining occurrence' in the reach. (This list - is in the 'remembered_decls' field of each scope.) - The scopes and their decls are replayed in pass 2: As each reach - is entered, the decls saved from pass 1 are made visible. - - There are some exceptions. Declarations that cannot be referenced - before their declaration (i.e. whose defining occurrence precede - their reach), can be deferred to pass 2. These include formal - parameter declarations, and names defined in a DO action. - - During pass 2, as each scope is entered, we must make visible all - the declarations defined in the scope, before we generate any code. - We must also simplify the declarations from pass 1: For example - a VAR_DECL may have a array type whose bounds are expressions; - these need to be folded. But of course the expressions may contain - identifiers that may be defined later in the scope - or even in - a different module. - - The "satisfy" process has two main phases: - - 1: Binding. Each identifier *referenced* in a declaration (i.e. in - a mode or the RHS of a synonum declaration) must be bound to its - defining occurrence. This may need to be linking via - grants and/or seizes (which are represented by ALIAS_DECLs). - A further complication is handling implied name strings. - - 2: Layout. Each CONST_DECL or TYPE_DECL *referenced* in a declaration - must than be replaced by its value (or type). Constants must be - folded. Types and declarstions must be laid out. DECL_RTL must be set. - While doing this, we must watch out for circular dependencies. - - If a scope contains nested modulions, then the Binding phase must be - done for each nested module (recursively) before the Layout phase - can start for that scope. As an example of why this is needed, consider: - - M1: MODULE - DCL a ARRAY [1:y] int; -- This should have 7 elements. - SYN x = 5; - SEIZE y; - END M1; - M2: MODULE - SYN x = 2; - SYN y = x + 5; - GRANT y; - END M2; - - Here, the 'x' in "x + 5" must be Bound to the 'x' in module M2. - This must be done before we can Layout a. - The reason this is an issue is that we do *not* have a lookup - (or hash) table per scope (or module). Instead we have a single - global table we keep adding and removing bindings from. - (This is both for speed, and because of gcc history.) - - Note that a SEIZE generates a declaration in the current scope, - linked to something in the surrounding scope. Determining (binding) - the link must be done in pass 2. On the other hand, a GRANT - generates a declaration in the surrounding scope, linked to - something in the current scope. This linkage is Bound in pass 1. - - The sequence for the above example is: - - Enter the declarations of M1 (i.e. {a, x, y}) into the hash table. - - For each of {a, x, y}, examine dependent expression (the - rhs of x, the bounds of a), and Bind any identifiers to - the current declarations (as found in the hash table). Specifically, - the 'y' in the array bounds of 'a' is bound to the 'y' declared by - the SEIZE declaration. Also, 'y' is Bound to the implicit - declaration in the global scope (generated from the GRANT in M2). - - Remove the bindings for M1 (i.e. {a, x, y}) from the hash table. - - Enter the declarations of M2 (i.e. {x, y}) into the hash table. - - For each of {x, y} examine the dependent expressions (the rhs of - x and y), and Bind any identifiers to their current declarartions - (in this case the 'x' in "x + 5" is bound to the 'x' that is 2. - - Remove the bindings for M2 (i.e. {x, y}) from the hash table. - - Perform Layout for M1: This requires the size of a, which - requires the value of y. The 'y' is Bound to the implicit - declaration in the global scope, which is Bound to the declaration - of y in M2. We now require the value of this 'y', which is "x + 5" - where x is bound to the x in M2 (thanks to our previous Binding - phase). So we get that the value of y is 7. - - Perform layout of M2. This implies calculating (constant folding) - the value of y - but we already did that, so we're done. - - An example illustating the problem with implied names: - - M1: MODULE - SEIZE y; - use(e); -- e is implied by y. - END M1; - M2: MODULE - GRANT y; - SYNMODE y = x; - SEIZE x; - END M2; - M3: MODULE - GRANT x; - SYNMODE x = SET (e); - END M3; - - This implies that determining the implied name e in M1 - must be done after Binding of y to x in M2. - - Yet another nasty: - M1: MODULE - SEIZE v; - DCL a ARRAY(v:v) int; - END M1; - M2: MODULE - GRANT v; - SEIZE x; - SYN v x = e; - END M2; - M3: MODULE - GRANT x; - SYNMODE x = SET(e); - END M3; - - This one implies that determining the implied name e in M2, - must be done before Layout of a in M1. - - These two examples togother indicate the determining implieed - names requries yet another phase. - - Bind strong names in M1. - - Bind strong names in M2. - - Bind strong names in M3. - - Determine weak names implied by SEIZEs in M1. - - Bind the weak names in M1. - - Determine weak names implied by SEIZEs in M2. - - Bind the weak names in M2. - - Determine weak names implied by SEIZEs in M3. - - Bind the weak names in M3. - - Layout M1. - - Layout M2. - - Layout M3. - - We must bind the strong names in every module before we can determine - weak names in any module (because of seized/granted synmode/newmodes). - We must bind the weak names in every module before we can do Layout - in any module. - - Sigh. - - */ - -/* ??? not all decl nodes are given the most useful possible - line numbers. For example, the CONST_DECLs for enum values. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "flags.h" -#include "ch-tree.h" -#include "lex.h" -#include "obstack.h" -#include "input.h" -#include "rtl.h" -#include "toplev.h" - -#define IS_UNKNOWN_TYPE(type) (TYPE_SIZE(type)==0) -#define BUILTIN_NESTING_LEVEL (-1) - -/* For backward compatibility, we define Chill INT to be the same - as SHORT (i.e. 16 bits), at least if C INT is the same as LONG. - This is a lose. */ -#define CHILL_INT_IS_SHORT (INT_TYPE_SIZE==LONG_TYPE_SIZE) - -extern int ignore_case; -extern tree process_type; -extern struct obstack *saveable_obstack; -extern tree signal_code; -extern int special_UC; - -static tree get_next_decl PARAMS ((void)); -static tree lookup_name_for_seizing PARAMS ((tree)); -#if 0 -static tree lookup_name_current_level PARAMS ((tree)); -#endif -static void save_decl PARAMS ((tree)); - -extern struct obstack permanent_obstack; -extern int in_pseudo_module; - -struct module *current_module = NULL; -struct module *first_module = NULL; -struct module **next_module = &first_module; - -extern int in_pseudo_module; - -int module_number = 0; - -/* This is only used internally (by signed_type). */ - -tree signed_boolean_type_node; - -tree global_function_decl = NULL_TREE; - -/* This is a temportary used by RESULT to store its value. - Note we cannot directly use DECL_RESULT for two reasons: - a) If DECL_RESULT is a register, it may get clobbered by a - subsequent function call; and - b) if the function returns a struct, we might (visibly) modify the - destination before we're supposed to. */ -tree chill_result_decl; - -int result_never_set; - -/* forward declarations */ -static void pushdecllist PARAMS ((tree, int)); -static int init_nonvalue_struct PARAMS ((tree)); -static int init_nonvalue_array PARAMS ((tree)); -static void set_nesting_level PARAMS ((tree, int)); -static tree make_chill_variants PARAMS ((tree, tree, tree)); -static tree fix_identifier PARAMS ((tree)); -static void proclaim_decl PARAMS ((tree, int)); -static tree maybe_acons PARAMS ((tree, tree)); -static void push_scope_decls PARAMS ((int)); -static void pop_scope_decls PARAMS ((tree, tree)); -static tree build_implied_names PARAMS ((tree)); -static void bind_sub_modules PARAMS ((int)); -static void layout_array_type PARAMS ((tree)); -static void do_based_decl PARAMS ((tree, tree, tree)); -static void handle_one_level PARAMS ((tree, tree)); - -int current_nesting_level = BUILTIN_NESTING_LEVEL; -int current_module_nesting_level = 0; - -/* Lots of declarations copied from c-decl.c. */ -/* ??? not all decl nodes are given the most useful possible - line numbers. For example, the CONST_DECLs for enum values. */ - - -/* We let tm.h override the types used here, to handle trivial differences - such as the choice of unsigned int or long unsigned int for size_t. - When machines start needing nontrivial differences in the size type, - it would be best to do something here to figure out automatically - from other information what type to use. */ - -#ifndef PTRDIFF_TYPE -#define PTRDIFF_TYPE "long int" -#endif - -#ifndef WCHAR_TYPE -#define WCHAR_TYPE "int" -#endif - -tree wchar_type_node; -tree signed_wchar_type_node; -tree unsigned_wchar_type_node; - -tree void_list_node; - -/* type of initializer structure, which points to - a module's module-level code, and to the next - such structure. */ -tree initializer_type; - -/* type of a CHILL predefined value builtin routine */ -tree chill_predefined_function_type; - -/* type `int ()' -- used for implicit declaration of functions. */ - -tree default_function_type; - -const char **boolean_code_name; - -/* Nodes for boolean constants TRUE and FALSE. */ -tree boolean_true_node, boolean_false_node; - -tree string_one_type_node; /* The type of CHARS(1). */ -tree bitstring_one_type_node; /* The type of BOOLS(1). */ -tree bit_zero_node; /* B'0' */ -tree bit_one_node; /* B'1' */ - -/* Nonzero if we have seen an invalid cross reference - to a struct, union, or enum, but not yet printed the message. */ - -tree pending_invalid_xref; -/* File and line to appear in the eventual error message. */ -char *pending_invalid_xref_file; -int pending_invalid_xref_line; - -/* After parsing the declarator that starts a function definition, - `start_function' puts here the list of parameter names or chain of decls. - `store_parm_decls' finds it here. */ - -static tree current_function_parms; - -/* Nonzero when store_parm_decls is called indicates a varargs function. - Value not meaningful after store_parm_decls. */ - -static int c_function_varargs; - -/* These are irrelevant for Chill, but are referenced from from c-typeck.c. */ -int warn_format; -int warn_traditional; -int warn_bad_function_cast; - -/* Identifiers that hold VAR_LENGTH and VAR_DATA. */ -tree var_length_id, var_data_id; - -tree case_else_node; - -/* For each binding contour we allocate a scope structure - * which records the names defined in that contour. - * Contours include: - * 0) the global one - * 1) one for each function definition, - * where internal declarations of the parameters appear. - * 2) one for each compound statement, - * to record its declarations. - * - * The current meaning of a name can be found by searching the levels from - * the current one out to the global one. - */ - -/* To communicate between pass 1 and 2, we maintain a list of "scopes". - Each scope corrresponds to a nested source scope/block that contain - that can contain declarations. The TREE_VALUE of the scope points - to the list of declarations declared in that scope. - The TREE_PURPOSE of the scope points to the surrounding scope. - (We may need to handle nested modules later. FIXME) - The TREE_CHAIN field contains a list of scope as they are seen - in chronological order. (Reverse order during first pass, - but it is reverse before pass 2.) */ - -struct scope -{ - /* The enclosing scope. */ - struct scope *enclosing; - - /* The next scope, in chronlogical order. */ - struct scope *next; - - /* A chain of DECLs constructed using save_decl during pass 1. */ - tree remembered_decls; - - /* A chain of _DECL nodes for all variables, constants, functions, - and typedef types belong to this scope. */ - tree decls; - - /* List of declarations that have been granted into this scope. */ - tree granted_decls; - - /* List of implied (weak) names. */ - tree weak_decls; - - /* For each level, a list of shadowed outer-level local definitions - to be restored when this level is popped. - Each link is a TREE_LIST whose TREE_PURPOSE is an identifier and - whose TREE_VALUE is its old definition (a kind of ..._DECL node). */ - tree shadowed; - - /* For each level (except not the global one), - a chain of BLOCK nodes for all the levels - that were entered and exited one level down. */ - tree blocks; - - /* The BLOCK node for this level, if one has been preallocated. - If 0, the BLOCK is allocated (if needed) when the level is popped. */ - tree this_block; - - /* The binding level which this one is contained in (inherits from). */ - struct scope *level_chain; - - /* Nonzero for a level that corresponds to a module. */ - char module_flag; - - /* Zero means called from backend code. */ - char two_pass; - - /* The modules that are directly enclosed by this scope - are chained together. */ - struct scope* first_child_module; - struct scope** tail_child_module; - struct scope* next_sibling_module; -}; - -/* The outermost binding level, for pre-defined (builtin) names. */ - -static struct scope builtin_scope = { - NULL, NULL, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, NULL, 0, 0, NULL, NULL, NULL}; - -struct scope *global_scope; - -/* The binding level currently in effect. */ - -static struct scope *current_scope = &builtin_scope; - -/* The most recently seen scope. */ -struct scope *last_scope = &builtin_scope; - -/* Binding level structures are initialized by copying this one. */ - -static struct scope clear_scope = { - NULL, NULL, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, NULL, 0, 0, NULL, NULL, NULL}; - -/* Chain of decls accessible through IDENTIFIER_OUTER_VALUE. - Decls with the same DECL_NAME are adjacent in the chain. */ - -static tree outer_decls = NULL_TREE; - -/* C-specific option variables. */ - -/* Nonzero means allow type mismatches in conditional expressions; - just make their values `void'. */ - -int flag_cond_mismatch; - -/* Nonzero means give `double' the same size as `float'. */ - -int flag_short_double; - -/* Nonzero means don't recognize the keyword `asm'. */ - -int flag_no_asm; - -/* Nonzero means don't recognize any builtin functions. */ - -int flag_no_builtin; - -/* Nonzero means don't recognize the non-ANSI builtin functions. - -ansi sets this. */ - -int flag_no_nonansi_builtin; - -/* Nonzero means do some things the same way PCC does. */ - -int flag_traditional; - -/* Nonzero means to allow single precision math even if we're generally - being traditional. */ -int flag_allow_single_precision = 0; - -/* Nonzero means to treat bitfields as signed unless they say `unsigned'. */ - -int flag_signed_bitfields = 1; -int explicit_flag_signed_bitfields = 0; - -/* Nonzero means warn about implicit declarations. */ - -int warn_implicit; - -/* Nonzero means give string constants the type `const char *' - to get extra warnings from them. These warnings will be too numerous - to be useful, except in thoroughly ANSIfied programs. */ - -int warn_write_strings; - -/* Nonzero means warn about pointer casts that can drop a type qualifier - from the pointer target type. */ - -int warn_cast_qual; - -/* Nonzero means warn about sizeof(function) or addition/subtraction - of function pointers. */ - -int warn_pointer_arith; - -/* Nonzero means warn for non-prototype function decls - or non-prototyped defs without previous prototype. */ - -int warn_strict_prototypes; - -/* Nonzero means warn for any global function def - without separate previous prototype decl. */ - -int warn_missing_prototypes; - -/* Nonzero means warn about multiple (redundant) decls for the same single - variable or function. */ - -int warn_redundant_decls = 0; - -/* Nonzero means warn about extern declarations of objects not at - file-scope level and about *all* declarations of functions (whether - extern or static) not at file-scope level. Note that we exclude - implicit function declarations. To get warnings about those, use - -Wimplicit. */ - -int warn_nested_externs = 0; - -/* Warn about a subscript that has type char. */ - -int warn_char_subscripts = 0; - -/* Warn if a type conversion is done that might have confusing results. */ - -int warn_conversion; - -/* Warn if adding () is suggested. */ - -int warn_parentheses; - -/* Warn if initializer is not completely bracketed. */ - -int warn_missing_braces; - -/* Define the special tree codes that we use. */ - -/* Table indexed by tree code giving a string containing a character - classifying the tree code. Possibilities are - t, d, s, c, r, <, 1 and 2. See ch-tree.def for details. */ - -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, - - const char chill_tree_code_type[] = { - 'x', -#include "ch-tree.def" - }; -#undef DEFTREECODE - -/* Table indexed by tree code giving number of expression - operands beyond the fixed part of the node structure. - Not used for types or decls. */ - -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, - -int chill_tree_code_length[] = { - 0, -#include "ch-tree.def" - }; -#undef DEFTREECODE - - -/* Names of tree components. - Used for printing out the tree and error messages. */ -#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, - -const char *chill_tree_code_name[] = { - "@@dummy", -#include "ch-tree.def" - }; -#undef DEFTREECODE - -/* Nonzero means `$' can be in an identifier. */ -#ifndef DOLLARS_IN_IDENTIFIERS -#define DOLLARS_IN_IDENTIFIERS 0 -#endif -int dollars_in_ident = DOLLARS_IN_IDENTIFIERS > 1; - -/* An identifier that is used internally to indicate - an "ALL" prefix for granting or seizing. - We use "*" rather than the external name "ALL", partly for convenience, - and partly to avoid case senstivity problems. */ - -tree ALL_POSTFIX; - -void -allocate_lang_decl (t) - tree t ATTRIBUTE_UNUSED; -{ - /* Nothing needed */ -} - -void -copy_lang_decl (node) - tree node ATTRIBUTE_UNUSED; -{ - /* Nothing needed */ -} - -tree -build_lang_decl (code, name, type) - enum chill_tree_code code; - tree name; - tree type; -{ - return build_decl (code, name, type); -} - -/* Decode the string P as a language-specific option for C. - Return the number of strings consumed for a valid option. - Return 0 for an invalid option. */ - -int -c_decode_option (argc, argv) - int argc ATTRIBUTE_UNUSED; - char **argv; -{ - char *p = argv[0]; - if (!strcmp (p, "-ftraditional") || !strcmp (p, "-traditional")) - { - flag_traditional = 1; - flag_writable_strings = 1; -#if DOLLARS_IN_IDENTIFIERS > 0 - dollars_in_ident = 1; -#endif - } - else if (!strcmp (p, "-fnotraditional") || !strcmp (p, "-fno-traditional")) - { - flag_traditional = 0; - flag_writable_strings = 0; - dollars_in_ident = DOLLARS_IN_IDENTIFIERS > 1; - } - else if (!strcmp (p, "-fsigned-char")) - flag_signed_char = 1; - else if (!strcmp (p, "-funsigned-char")) - flag_signed_char = 0; - else if (!strcmp (p, "-fno-signed-char")) - flag_signed_char = 0; - else if (!strcmp (p, "-fno-unsigned-char")) - flag_signed_char = 1; - else if (!strcmp (p, "-fsigned-bitfields") - || !strcmp (p, "-fno-unsigned-bitfields")) - { - flag_signed_bitfields = 1; - explicit_flag_signed_bitfields = 1; - } - else if (!strcmp (p, "-funsigned-bitfields") - || !strcmp (p, "-fno-signed-bitfields")) - { - flag_signed_bitfields = 0; - explicit_flag_signed_bitfields = 1; - } - else if (!strcmp (p, "-fshort-enums")) - flag_short_enums = 1; - else if (!strcmp (p, "-fno-short-enums")) - flag_short_enums = 0; - else if (!strcmp (p, "-fcond-mismatch")) - flag_cond_mismatch = 1; - else if (!strcmp (p, "-fno-cond-mismatch")) - flag_cond_mismatch = 0; - else if (!strcmp (p, "-fshort-double")) - flag_short_double = 1; - else if (!strcmp (p, "-fno-short-double")) - flag_short_double = 0; - else if (!strcmp (p, "-fasm")) - flag_no_asm = 0; - else if (!strcmp (p, "-fno-asm")) - flag_no_asm = 1; - else if (!strcmp (p, "-fbuiltin")) - flag_no_builtin = 0; - else if (!strcmp (p, "-fno-builtin")) - flag_no_builtin = 1; - else if (!strcmp (p, "-ansi")) - flag_no_asm = 1, flag_no_nonansi_builtin = 1, dollars_in_ident = 0; - else if (!strcmp (p, "-Wimplicit")) - warn_implicit = 1; - else if (!strcmp (p, "-Wno-implicit")) - warn_implicit = 0; - else if (!strcmp (p, "-Wwrite-strings")) - warn_write_strings = 1; - else if (!strcmp (p, "-Wno-write-strings")) - warn_write_strings = 0; - else if (!strcmp (p, "-Wcast-qual")) - warn_cast_qual = 1; - else if (!strcmp (p, "-Wno-cast-qual")) - warn_cast_qual = 0; - else if (!strcmp (p, "-Wpointer-arith")) - warn_pointer_arith = 1; - else if (!strcmp (p, "-Wno-pointer-arith")) - warn_pointer_arith = 0; - else if (!strcmp (p, "-Wstrict-prototypes")) - warn_strict_prototypes = 1; - else if (!strcmp (p, "-Wno-strict-prototypes")) - warn_strict_prototypes = 0; - else if (!strcmp (p, "-Wmissing-prototypes")) - warn_missing_prototypes = 1; - else if (!strcmp (p, "-Wno-missing-prototypes")) - warn_missing_prototypes = 0; - else if (!strcmp (p, "-Wredundant-decls")) - warn_redundant_decls = 1; - else if (!strcmp (p, "-Wno-redundant-decls")) - warn_redundant_decls = 0; - else if (!strcmp (p, "-Wnested-externs")) - warn_nested_externs = 1; - else if (!strcmp (p, "-Wno-nested-externs")) - warn_nested_externs = 0; - else if (!strcmp (p, "-Wchar-subscripts")) - warn_char_subscripts = 1; - else if (!strcmp (p, "-Wno-char-subscripts")) - warn_char_subscripts = 0; - else if (!strcmp (p, "-Wconversion")) - warn_conversion = 1; - else if (!strcmp (p, "-Wno-conversion")) - warn_conversion = 0; - else if (!strcmp (p, "-Wparentheses")) - warn_parentheses = 1; - else if (!strcmp (p, "-Wno-parentheses")) - warn_parentheses = 0; - else if (!strcmp (p, "-Wreturn-type")) - warn_return_type = 1; - else if (!strcmp (p, "-Wno-return-type")) - warn_return_type = 0; - else if (!strcmp (p, "-Wcomment")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wno-comment")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wcomments")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wno-comments")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wtrigraphs")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wno-trigraphs")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wimport")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wno-import")) - ; /* cpp handles this one. */ - else if (!strcmp (p, "-Wmissing-braces")) - warn_missing_braces = 1; - else if (!strcmp (p, "-Wno-missing-braces")) - warn_missing_braces = 0; - else if (!strcmp (p, "-Wall")) - { - extra_warnings = 1; - /* We save the value of warn_uninitialized, since if they put - -Wuninitialized on the command line, we need to generate a - warning about not using it without also specifying -O. */ - if (warn_uninitialized != 1) - warn_uninitialized = 2; - warn_implicit = 1; - warn_return_type = 1; - set_Wunused (1); - warn_char_subscripts = 1; - warn_parentheses = 1; - warn_missing_braces = 1; - } - else - return 0; - - return 1; -} - -/* Hooks for print_node. */ - -void -print_lang_decl (file, node, indent) - FILE *file; - tree node; - int indent; -{ - indent_to (file, indent + 3); - fputs ("nesting_level ", file); - fprintf (file, HOST_WIDE_INT_PRINT_DEC, DECL_NESTING_LEVEL (node)); - fputs (" ", file); - if (DECL_WEAK_NAME (node)) - fprintf (file, "weak_name "); - if (CH_DECL_SIGNAL (node)) - fprintf (file, "decl_signal "); - print_node (file, "tasking_code", - (tree)DECL_TASKING_CODE_DECL (node), indent + 4); -} - - -void -print_lang_type (file, node, indent) - FILE *file; - tree node; - int indent; -{ - tree temp; - - indent_to (file, indent + 3); - if (CH_IS_BUFFER_MODE (node)) - fprintf (file, "buffer_mode "); - if (CH_IS_EVENT_MODE (node)) - fprintf (file, "event_mode "); - - if (CH_IS_EVENT_MODE (node) || CH_IS_BUFFER_MODE (node)) - { - temp = max_queue_size (node); - if (temp) - print_node_brief (file, "qsize", temp, indent + 4); - } -} - -void -print_lang_identifier (file, node, indent) - FILE *file; - tree node; - int indent; -{ - print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4); - print_node (file, "outer", IDENTIFIER_OUTER_VALUE (node), indent + 4); - print_node (file, "implicit", IDENTIFIER_IMPLICIT_DECL (node), indent + 4); - print_node (file, "error locus", IDENTIFIER_ERROR_LOCUS (node), indent + 4); - print_node (file, "signal_dest", IDENTIFIER_SIGNAL_DEST (node), indent + 4); - indent_to (file, indent + 3); - if (IDENTIFIER_SIGNAL_DATA(node)) - fprintf (file, "signal_data "); -} - -/* initialise non-value struct */ - -static int -init_nonvalue_struct (expr) - tree expr; -{ - tree type = TREE_TYPE (expr); - tree field; - int res = 0; - - if (CH_IS_BUFFER_MODE (type)) - { - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (expr, get_identifier ("__buffer_data")), - null_pointer_node)); - return 1; - } - else if (CH_IS_EVENT_MODE (type)) - { - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (expr, get_identifier ("__event_data")), - null_pointer_node)); - return 1; - } - else if (CH_IS_ASSOCIATION_MODE (type)) - { - expand_expr_stmt ( - build_chill_modify_expr (expr, - chill_convert_for_assignment (type, association_init_value, - "association"))); - return 1; - } - else if (CH_IS_ACCESS_MODE (type)) - { - init_access_location (expr, type); - return 1; - } - else if (CH_IS_TEXT_MODE (type)) - { - init_text_location (expr, type); - return 1; - } - - for (field = TYPE_FIELDS (type); field != NULL_TREE; field = TREE_CHAIN (field)) - { - type = TREE_TYPE (field); - if (CH_TYPE_NONVALUE_P (type)) - { - tree exp = build_component_ref (expr, DECL_NAME (field)); - if (TREE_CODE (type) == RECORD_TYPE) - res |= init_nonvalue_struct (exp); - else if (TREE_CODE (type) == ARRAY_TYPE) - res |= init_nonvalue_array (exp); - } - } - return res; -} - -/* initialize non-value array */ -/* do it with DO FOR unique-id IN expr; ... OD; */ -static int -init_nonvalue_array (expr) - tree expr; -{ - tree tmpvar = get_unique_identifier ("NONVALINIT"); - tree type; - int res = 0; - - push_loop_block (); - build_loop_iterator (tmpvar, expr, NULL_TREE, NULL_TREE, 0, 1, 0); - nonvalue_begin_loop_scope (); - build_loop_start (NULL_TREE); - tmpvar = lookup_name (tmpvar); - type = TREE_TYPE (tmpvar); - if (CH_TYPE_NONVALUE_P (type)) - { - if (TREE_CODE (type) == RECORD_TYPE) - res |= init_nonvalue_struct (tmpvar); - else if (TREE_CODE (type) == ARRAY_TYPE) - res |= init_nonvalue_array (tmpvar); - } - build_loop_end (); - nonvalue_end_loop_scope (); - pop_loop_block (); - return res; -} - -/* This excessive piece of code sets DECL_NESTING_LEVEL (DECL) to LEVEL. */ - -static void -set_nesting_level (decl, level) - tree decl; - int level; -{ - static tree *small_ints = NULL; - static int max_small_ints = 0; - - if (level < 0) - decl->decl.vindex = NULL_TREE; - else - { - if (level >= max_small_ints) - { - int new_max = level + 20; - if (small_ints == NULL) - small_ints = (tree*)xmalloc (new_max * sizeof(tree)); - else - small_ints = (tree*)xrealloc (small_ints, new_max * sizeof(tree)); - while (max_small_ints < new_max) - small_ints[max_small_ints++] = NULL_TREE; - } - if (small_ints[level] == NULL_TREE) - { - push_obstacks (&permanent_obstack, &permanent_obstack); - small_ints[level] = build_int_2 (level, 0); - pop_obstacks (); - } - /* set DECL_NESTING_LEVEL */ - decl->decl.vindex = small_ints[level]; - } -} - -/* OPT_EXTERNAL is non-zero when the declaration is at module level. - * OPT_EXTERNAL == 2 means implicitly grant it. - */ -void -do_decls (names, type, opt_static, lifetime_bound, opt_init, opt_external) - tree names; - tree type; - int opt_static; - int lifetime_bound; - tree opt_init; - int opt_external; -{ - if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST) - { - for (; names != NULL_TREE; names = TREE_CHAIN (names)) - do_decl (TREE_VALUE (names), type, opt_static, lifetime_bound, - opt_init, opt_external); - } - else if (TREE_CODE (names) != ERROR_MARK) - do_decl (names, type, opt_static, lifetime_bound, opt_init, opt_external); -} - -tree -do_decl (name, type, is_static, lifetime_bound, opt_init, opt_external) - tree name, type; - int is_static; - int lifetime_bound; - tree opt_init; - int opt_external; -{ - tree decl; - - if (current_function_decl == global_function_decl - && ! lifetime_bound /*&& opt_init != NULL_TREE*/) - seen_action = 1; - - if (pass < 2) - { - push_obstacks (&permanent_obstack, &permanent_obstack); - decl = make_node (VAR_DECL); - DECL_NAME (decl) = name; - TREE_TYPE (decl) = type; - DECL_ASSEMBLER_NAME (decl) = name; - - /* Try to put things in common when possible. - Tasking variables must go into common. */ - DECL_COMMON (decl) = 1; - DECL_EXTERNAL (decl) = opt_external > 0; - TREE_PUBLIC (decl) = opt_external > 0; - TREE_STATIC (decl) = is_static; - - if (pass == 0) - { - /* We have to set this here, since we build the decl w/o - calling `build_decl'. */ - DECL_INITIAL (decl) = opt_init; - pushdecl (decl); - finish_decl (decl); - } - else - { - save_decl (decl); - pop_obstacks (); - } - DECL_INITIAL (decl) = opt_init; - if (opt_external > 1 || in_pseudo_module) - push_granted (DECL_NAME (decl), decl); - } - else /* pass == 2 */ - { - tree temp = NULL_TREE; - int init_it = 0; - - decl = get_next_decl (); - - if (name != DECL_NAME (decl)) - abort (); - - type = TREE_TYPE (decl); - - push_obstacks_nochange (); - if (TYPE_READONLY_PROPERTY (type)) - { - if (CH_TYPE_NONVALUE_P (type)) - { - error_with_decl (decl, "`%s' must not be declared readonly"); - opt_init = NULL_TREE; /* prevent subsequent errors */ - } - else if (opt_init == NULL_TREE && !opt_external) - error("declaration of readonly variable without initialization"); - } - TREE_READONLY (decl) = TYPE_READONLY (type); - - if (!opt_init && chill_varying_type_p (type)) - { - tree fixed_part_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); - if (fixed_part_type != NULL_TREE && TREE_CODE (fixed_part_type) != ERROR_MARK) - { - if (CH_CHARS_TYPE_P (fixed_part_type)) - opt_init = build_chill_string (0, ""); - else - opt_init = build_nt (CONSTRUCTOR, NULL_TREE, NULL_TREE); - lifetime_bound = 1; - } - } - - if (opt_init) - { - if (CH_TYPE_NONVALUE_P (type)) - { - error_with_decl (decl, - "no initialisation allowed for `%s'"); - temp = NULL_TREE; - } - else if (TREE_CODE (type) == REFERENCE_TYPE) - { /* A loc-identity declaration */ - if (! CH_LOCATION_P (opt_init)) - { - error_with_decl (decl, - "value for loc-identity `%s' is not a location"); - temp = NULL_TREE; - } - else if (! CH_READ_COMPATIBLE (TREE_TYPE (type), - TREE_TYPE (opt_init))) - { - error_with_decl (decl, - "location for `%s' not read-compatible"); - temp = NULL_TREE; - } - else - temp = convert (type, opt_init); - } - else - { /* Normal location declaration */ - char place[80]; - sprintf (place, "`%.60s' initializer", - IDENTIFIER_POINTER (DECL_NAME (decl))); - temp = chill_convert_for_assignment (type, opt_init, place); - } - } - else if (CH_TYPE_NONVALUE_P (type)) - { - temp = NULL_TREE; - init_it = 1; - } - DECL_INITIAL (decl) = NULL_TREE; - - if (temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK) - { - /* The same for stack variables (assuming no nested modules). */ - if (lifetime_bound || !is_static) - { - if (is_static && ! TREE_CONSTANT (temp)) - error_with_decl (decl, "nonconstant initializer for `%s'"); - else - DECL_INITIAL (decl) = temp; - } - } - finish_decl (decl); - /* Initialize the variable unless initialized statically. */ - if ((!is_static || ! lifetime_bound) && - temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK) - { - int was_used = TREE_USED (decl); - emit_line_note (input_filename, lineno); - expand_expr_stmt (build_chill_modify_expr (decl, temp)); - /* Don't let the initialization count as "using" the variable. */ - TREE_USED (decl) = was_used; - if (current_function_decl == global_function_decl) - build_constructor = 1; - } - else if (init_it && TREE_CODE (type) != ERROR_MARK) - { - /* Initialize variables with non-value type */ - int was_used = TREE_USED (decl); - int something_initialised = 0; - - emit_line_note (input_filename, lineno); - if (TREE_CODE (type) == RECORD_TYPE) - something_initialised = init_nonvalue_struct (decl); - else if (TREE_CODE (type) == ARRAY_TYPE) - something_initialised = init_nonvalue_array (decl); - if (! something_initialised) - { - error ("do_decl: internal error: don't know what to initialize"); - abort (); - } - /* Don't let the initialization count as "using" the variable. */ - TREE_USED (decl) = was_used; - if (current_function_decl == global_function_decl) - build_constructor = 1; - } - } - return decl; -} - -/* - * ARGTYPES is a tree_list of formal argument types. TREE_VALUE - * is the type tree for each argument, while the attribute is in - * TREE_PURPOSE. - */ -tree -build_chill_function_type (return_type, argtypes, exceptions, recurse_p) - tree return_type, argtypes, exceptions, recurse_p; -{ - tree ftype, arg; - - if (exceptions != NULL_TREE) - { - /* if we have exceptions we add 2 arguments, callers filename - and linenumber. These arguments will be added automatically - when calling a function which may raise exceptions. */ - argtypes = chainon (argtypes, - build_tree_list (NULL_TREE, ridpointers[(int) RID_PTR])); - argtypes = chainon (argtypes, - build_tree_list (NULL_TREE, ridpointers[(int) RID_LONG])); -} - - /* Indicate the argument list is complete. */ - argtypes = chainon (argtypes, - build_tree_list (NULL_TREE, void_type_node)); - - /* INOUT and OUT parameters must be a REFERENCE_TYPE since - we'll be passing a temporary's address at call time. */ - for (arg = argtypes; arg; arg = TREE_CHAIN (arg)) - if (TREE_PURPOSE (arg) == ridpointers[(int) RID_LOC] - || TREE_PURPOSE (arg) == ridpointers[(int) RID_OUT] - || TREE_PURPOSE (arg) == ridpointers[(int) RID_INOUT] - ) - TREE_VALUE (arg) = - build_chill_reference_type (TREE_VALUE (arg)); - - /* Cannot use build_function_type, because if does hash-canonlicalization. */ - ftype = make_node (FUNCTION_TYPE); - TREE_TYPE (ftype) = return_type ? return_type : void_type_node ; - TYPE_ARG_TYPES (ftype) = argtypes; - - if (exceptions) - ftype = build_exception_variant (ftype, exceptions); - - if (recurse_p) - sorry ("RECURSIVE PROCs"); - - return ftype; -} - -/* - * ARGTYPES is a tree_list of formal argument types. - */ -tree -push_extern_function (name, typespec, argtypes, exceptions, granting) - tree name, typespec, argtypes, exceptions; - int granting ATTRIBUTE_UNUSED;/*If 0 do pushdecl(); if 1 do push_granted()*/ -{ - tree ftype, fndecl; - - push_obstacks_nochange (); - end_temporary_allocation (); - - if (pass < 2) - { - ftype = build_chill_function_type (typespec, argtypes, - exceptions, NULL_TREE); - - fndecl = build_decl (FUNCTION_DECL, name, ftype); - - DECL_EXTERNAL(fndecl) = 1; - TREE_STATIC (fndecl) = 1; - TREE_PUBLIC (fndecl) = 1; - if (pass == 0) - { - pushdecl (fndecl); - finish_decl (fndecl); - } - else - { - save_decl (fndecl); - pop_obstacks (); - } - make_function_rtl (fndecl); - } - else - { - fndecl = get_next_decl (); - finish_decl (fndecl); - } -#if 0 - - if (granting) - push_granted (name, decl); - else - pushdecl(decl); -#endif - return fndecl; -} - - - -void -push_extern_process (name, argtypes, exceptions, granting) - tree name, argtypes, exceptions; - int granting; -{ - tree decl, func, arglist; - - push_obstacks_nochange (); - end_temporary_allocation (); - - if (pass < 2) - { - tree proc_struct = make_process_struct (name, argtypes); - arglist = (argtypes == NULL_TREE) ? NULL_TREE : - tree_cons (NULL_TREE, - build_chill_pointer_type (proc_struct), NULL_TREE); - } - else - arglist = NULL_TREE; - - func = push_extern_function (name, NULL_TREE, arglist, - exceptions, granting); - - /* declare the code variable */ - decl = generate_tasking_code_variable (name, &process_type, 1); - CH_DECL_PROCESS (func) = 1; - /* remember the code variable in the function decl */ - DECL_TASKING_CODE_DECL (func) = (struct lang_decl *)decl; - - add_taskstuff_to_list (decl, "_TT_Process", NULL_TREE, func, NULL_TREE); -} - -void -push_extern_signal (signame, sigmodelist, optsigdest) - tree signame, sigmodelist, optsigdest; -{ - tree decl, sigtype; - - push_obstacks_nochange (); - end_temporary_allocation (); - - sigtype = - build_signal_struct_type (signame, sigmodelist, optsigdest); - - /* declare the code variable outside the process */ - decl = generate_tasking_code_variable (signame, &signal_code, 1); - add_taskstuff_to_list (decl, "_TT_Signal", NULL_TREE, sigtype, NULL_TREE); -} - -void -print_mode (mode) - tree mode; -{ - while (mode != NULL_TREE) - { - switch (TREE_CODE (mode)) - { - case POINTER_TYPE: - printf (" REF "); - mode = TREE_TYPE (mode); - break; - case INTEGER_TYPE: - case REAL_TYPE: - printf (" %s ", IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (mode)))); - mode = NULL_TREE; - break; - case ARRAY_TYPE: - { - tree itype = TYPE_DOMAIN (mode); - if (CH_STRING_TYPE_P (mode)) - { - fputs (" STRING (", stdout); - printf (HOST_WIDE_INT_PRINT_DEC, - TREE_INT_CST_LOW (TYPE_MAX_VALUE (itype))); - fputs (") OF ", stdout); - } - else - { - fputs (" ARRAY (", stdout); - printf (HOST_WIDE_INT_PRINT_DEC, - TREE_INT_CST_LOW (TYPE_MIN_VALUE (itype))); - fputs (":", stdout); - printf (HOST_WIDE_INT_PRINT_DEC, - TREE_INT_CST_LOW (TYPE_MAX_VALUE (itype))); - fputs (") OF ", stdout); - } - mode = TREE_TYPE (mode); - break; - } - case RECORD_TYPE: - { - tree fields = TYPE_FIELDS (mode); - printf (" RECORD ("); - while (fields != NULL_TREE) - { - printf (" %s:", IDENTIFIER_POINTER (DECL_NAME (fields))); - print_mode (TREE_TYPE (fields)); - if (TREE_CHAIN (fields)) - printf (","); - fields = TREE_CHAIN (fields); - } - printf (")"); - mode = NULL_TREE; - break; - } - default: - abort (); - } - } -} - -tree -chill_munge_params (nodes, type, attr) - tree nodes, type, attr; -{ - tree node; - if (pass == 1) - { - /* Convert the list of identifiers to a list of types. */ - for (node = nodes; node != NULL_TREE; node = TREE_CHAIN (node)) - { - TREE_VALUE (node) = type; /* this was the identifier node */ - TREE_PURPOSE (node) = attr; - } - } - return nodes; -} - -/* Push the declarations described by SYN_DEFS into the current scope. */ -void -push_syndecl (name, mode, value) - tree name, mode, value; -{ - if (pass == 1) - { - tree decl = make_node (CONST_DECL); - DECL_NAME (decl) = name; - DECL_ASSEMBLER_NAME (decl) = name; - TREE_TYPE (decl) = mode; - DECL_INITIAL (decl) = value; - TREE_READONLY (decl) = 1; - save_decl (decl); - if (in_pseudo_module) - push_granted (DECL_NAME (decl), decl); - } - else /* pass == 2 */ - get_next_decl (); -} - - - -/* Push the declarations described by (MODENAME,MODE) into the current scope. - MAKE_NEWMODE is 1 for NEWMODE, 0 for SYNMODE, and - -1 for internal use (in which case the mode does not need to be copied). */ - -tree -push_modedef (modename, mode, make_newmode) - tree modename; - tree mode; /* ignored if pass==2. */ - int make_newmode; -{ - tree newdecl, newmode; - - if (pass == 1) - { - /* FIXME: need to check here for SYNMODE fred fred; */ - push_obstacks (&permanent_obstack, &permanent_obstack); - - newdecl = build_lang_decl (TYPE_DECL, modename, mode); - - if (make_newmode >= 0) - { - newmode = make_node (LANG_TYPE); - TREE_TYPE (newmode) = mode; - TREE_TYPE (newdecl) = newmode; - TYPE_NAME (newmode) = newdecl; - if (make_newmode > 0) - CH_NOVELTY (newmode) = newdecl; - } - - save_decl (newdecl); - pop_obstacks (); - - } - else /* pass == 2 */ - { - /* FIXME: need to check here for SYNMODE fred fred; */ - newdecl = get_next_decl (); - if (DECL_NAME (newdecl) != modename) - abort (); - if (TREE_CODE (TREE_TYPE (newdecl)) != ERROR_MARK) - { - /* ASSOCIATION, ACCESS, TEXT, BUFFER, and EVENT must not be READOnly */ - if (TREE_READONLY (TREE_TYPE (newdecl)) && - (CH_IS_ASSOCIATION_MODE (TREE_TYPE (newdecl)) || - CH_IS_ACCESS_MODE (TREE_TYPE (newdecl)) || - CH_IS_TEXT_MODE (TREE_TYPE (newdecl)) || - CH_IS_BUFFER_MODE (TREE_TYPE (newdecl)) || - CH_IS_EVENT_MODE (TREE_TYPE (newdecl)))) - error_with_decl (newdecl, "`%s' must not be READonly"); - rest_of_decl_compilation (newdecl, NULL_PTR, - global_bindings_p (), 0); - } - } - return newdecl; -} - -/* Return a chain of FIELD_DECLs for the names in NAMELIST. All of - of type TYPE. When NAMELIST is passed in from the parser, it is - in reverse order. - LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list), - meaning (default, pack, nopack, POS (...) ). */ - -tree -grok_chill_fixedfields (namelist, type, layout) - tree namelist, type; - tree layout; -{ - tree decls = NULL_TREE; - - if (layout != NULL_TREE && TREE_CHAIN (namelist) != NULL_TREE) - { - if (layout != integer_one_node && layout != integer_zero_node) - { - layout = NULL_TREE; - error ("POS may not be specified for a list of field declarations"); - } - } - - /* we build the chain of FIELD_DECLs backwards, effectively - unreversing the reversed names in NAMELIST. */ - for (; namelist; namelist = TREE_CHAIN (namelist)) - { - tree decl = build_decl (FIELD_DECL, - TREE_VALUE (namelist), type); - DECL_INITIAL (decl) = layout; - TREE_CHAIN (decl) = decls; - decls = decl; - } - - return decls; -} - -struct tree_pair -{ - tree value; - tree decl; -}; - -static int label_value_cmp PARAMS ((struct tree_pair *, - struct tree_pair *)); - -/* Function to help qsort sort variant labels by value order. */ -static int -label_value_cmp (x, y) - struct tree_pair *x, *y; -{ - return TREE_INT_CST_LOW (x->value) - TREE_INT_CST_LOW (y->value); -} - -static tree -make_chill_variants (tagfields, body, variantelse) - tree tagfields; - tree body; - tree variantelse; -{ - tree utype; - tree first = NULL_TREE; - for (; body; body = TREE_CHAIN (body)) - { - tree decls = TREE_VALUE (body); - tree labellist = TREE_PURPOSE (body); - - if (labellist != NULL_TREE - && TREE_CODE (TREE_VALUE (labellist)) == TREE_LIST - && TREE_VALUE (TREE_VALUE (labellist)) == case_else_node - && TREE_CHAIN (labellist) == NULL_TREE) - { - if (variantelse) - error ("(ELSE) case label as well as ELSE variant"); - variantelse = decls; - } - else - { - tree rtype = start_struct (RECORD_TYPE, NULL_TREE); - rtype = finish_struct (rtype, decls); - - first = chainon (first, build_decl (FIELD_DECL, NULL_TREE, rtype)); - - TYPE_TAG_VALUES (rtype) = labellist; - } - } - - if (variantelse != NULL_TREE) - { - tree rtype = start_struct (RECORD_TYPE, NULL_TREE); - rtype = finish_struct (rtype, variantelse); - first = chainon (first, - build_decl (FIELD_DECL, - ELSE_VARIANT_NAME, rtype)); - } - - utype = start_struct (UNION_TYPE, NULL_TREE); - utype = finish_struct (utype, first); - TYPE_TAGFIELDS (utype) = tagfields; - return utype; -} - -tree -layout_chill_variants (utype) - tree utype; -{ - tree first = TYPE_FIELDS (utype); - int nlabels, label_index = 0; - struct tree_pair *label_value_array; - tree decl; - extern int errorcount; - - if (TYPE_SIZE (utype)) - return utype; - - for (decl = first; decl; decl = TREE_CHAIN (decl)) - { - tree tagfields = TYPE_TAGFIELDS (utype); - tree t = TREE_TYPE (decl); - tree taglist = TYPE_TAG_VALUES (t); - if (DECL_NAME (decl) == ELSE_VARIANT_NAME) - continue; - if (tagfields == NULL_TREE) - continue; - for ( ; tagfields != NULL_TREE && taglist != NULL_TREE; - tagfields = TREE_CHAIN (tagfields), taglist = TREE_CHAIN (taglist)) - { - tree labellist = TREE_VALUE (taglist); - for (; labellist; labellist = TREE_CHAIN (labellist)) - { - int compat_error = 0; - tree label_value = TREE_VALUE (labellist); - if (TREE_CODE (label_value) == RANGE_EXPR) - { - if (TREE_OPERAND (label_value, 0) != NULL_TREE) - { - if (!CH_COMPATIBLE (TREE_OPERAND (label_value, 0), - TREE_TYPE (TREE_VALUE (tagfields))) - || !CH_COMPATIBLE (TREE_OPERAND (label_value, 1), - TREE_TYPE (TREE_VALUE (tagfields)))) - compat_error = 1; - } - } - else if (TREE_CODE (label_value) == TYPE_DECL) - { - if (!CH_COMPATIBLE (label_value, - TREE_TYPE (TREE_VALUE (tagfields)))) - compat_error = 1; - } - else if (TREE_CODE (label_value) == INTEGER_CST) - { - if (!CH_COMPATIBLE (label_value, - TREE_TYPE (TREE_VALUE (tagfields)))) - compat_error = 1; - } - if (compat_error) - { - if (TYPE_FIELDS (t) == NULL_TREE) - error ("inconsistent modes between labels and tag field"); - else - error_with_decl (TYPE_FIELDS (t), - "inconsistent modes between labels and tag field"); - } - } - } - if (tagfields != NULL_TREE) - error ("too few tag labels"); - if (taglist != NULL_TREE) - error ("too many tag labels"); - } - - /* Compute the number of labels to be checked for duplicates. */ - nlabels = 0; - for (decl = first; decl; decl = TREE_CHAIN (decl)) - { - tree t = TREE_TYPE (decl); - /* Only one tag (first case_label_list) supported, for now. */ - tree labellist = TYPE_TAG_VALUES (t); - if (labellist) - labellist = TREE_VALUE (labellist); - - for (; labellist != NULL_TREE; labellist = TREE_CHAIN (labellist)) - if (TREE_CODE (TREE_VALUE (labellist)) == INTEGER_CST) - nlabels++; - } - - /* Check for duplicate label values. */ - label_value_array = (struct tree_pair *)alloca (nlabels * sizeof (struct tree_pair)); - for (decl = first; decl; decl = TREE_CHAIN (decl)) - { - tree t = TREE_TYPE (decl); - /* Only one tag (first case_label_list) supported, for now. */ - tree labellist = TYPE_TAG_VALUES (t); - if (labellist) - labellist = TREE_VALUE (labellist); - - for (; labellist != NULL_TREE; labellist = TREE_CHAIN (labellist)) - { - struct tree_pair p; - - tree x = TREE_VALUE (labellist); - if (TREE_CODE (x) == RANGE_EXPR) - { - if (TREE_OPERAND (x, 0) != NULL_TREE) - { - if (TREE_CODE (TREE_OPERAND (x, 0)) != INTEGER_CST) - error ("case label lower limit is not a discrete constant expression"); - if (TREE_CODE (TREE_OPERAND (x, 1)) != INTEGER_CST) - error ("case label upper limit is not a discrete constant expression"); - } - continue; - } - else if (TREE_CODE (x) == TYPE_DECL) - continue; - else if (TREE_CODE (x) == ERROR_MARK) - continue; - else if (TREE_CODE (x) != INTEGER_CST) /* <-- FIXME: what about CONST_DECLs? */ - { - error ("case label must be a discrete constant expression"); - continue; - } - - if (TREE_CODE (x) == CONST_DECL) - x = DECL_INITIAL (x); - if (TREE_CODE (x) != INTEGER_CST) abort (); - p.value = x; - p.decl = decl; - if (p.decl == NULL_TREE) - p.decl = TREE_VALUE (labellist); - label_value_array[label_index++] = p; - } - } - if (errorcount == 0) - { - int limit; - qsort (label_value_array, - label_index, sizeof (struct tree_pair), - (int (*) PARAMS ((const void *, const void *))) label_value_cmp); - limit = label_index - 1; - for (label_index = 0; label_index < limit; label_index++) - { - if (tree_int_cst_equal (label_value_array[label_index].value, - label_value_array[label_index+1].value)) - { - error_with_decl (label_value_array[label_index].decl, - "variant label declared here..."); - error_with_decl (label_value_array[label_index+1].decl, - "...is duplicated here"); - } - } - } - layout_type (utype); - return utype; -} - -/* Convert a TREE_LIST of tag field names into a list of - field decls, found from FIXED_FIELDS, re-using the input list. */ - -tree -lookup_tag_fields (tag_field_names, fixed_fields) - tree tag_field_names; - tree fixed_fields; -{ - tree list; - for (list = tag_field_names; list != NULL_TREE; list = TREE_CHAIN (list)) - { - tree decl = fixed_fields; - for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl)) - { - if (DECL_NAME (decl) == TREE_VALUE (list)) - { - TREE_VALUE (list) = decl; - break; - } - } - if (decl == NULL_TREE) - { - error ("no field (yet) for tag %s", - IDENTIFIER_POINTER (TREE_VALUE (list))); - TREE_VALUE (list) = error_mark_node; - } - } - return tag_field_names; -} - -/* If non-NULL, TAGFIELDS is the tag fields for this variant record. - BODY is a TREE_LIST of (optlabels, fixed fields). - If non-null, VARIANTELSE is a fixed field for the else part of the - variant record. */ - -tree -grok_chill_variantdefs (tagfields, body, variantelse) - tree tagfields, body, variantelse; -{ - tree t; - - t = make_chill_variants (tagfields, body, variantelse); - if (pass != 1) - t = layout_chill_variants (t); - return build_decl (FIELD_DECL, NULL_TREE, t); -} - -/* - In pass 1, PARMS is a list of types (with attributes). - In pass 2, PARMS is a chain of PARM_DECLs. - */ - -int -start_chill_function (label, rtype, parms, exceptlist, attrs) - tree label, rtype, parms, exceptlist, attrs; -{ - tree decl, fndecl, type, result_type, func_type; - int nested = current_function_decl != 0; - if (pass == 1) - { - func_type - = build_chill_function_type (rtype, parms, exceptlist, 0); - fndecl = build_decl (FUNCTION_DECL, label, func_type); - - save_decl (fndecl); - - /* Make the init_value nonzero so pushdecl knows this is not tentative. - error_mark_node is replaced below (in poplevel) with the BLOCK. */ - DECL_INITIAL (fndecl) = error_mark_node; - - DECL_EXTERNAL (fndecl) = 0; - - /* This function exists in static storage. - (This does not mean `static' in the C sense!) */ - TREE_STATIC (fndecl) = 1; - - for (; attrs != NULL_TREE; attrs = TREE_CHAIN (attrs)) - { - if (TREE_VALUE (attrs) == ridpointers[RID_GENERAL]) - CH_DECL_GENERAL (fndecl) = 1; - else if (TREE_VALUE (attrs) == ridpointers[RID_SIMPLE]) - CH_DECL_SIMPLE (fndecl) = 1; - else if (TREE_VALUE (attrs) == ridpointers[RID_RECURSIVE]) - CH_DECL_RECURSIVE (fndecl) = 1; - else if (TREE_VALUE (attrs) == ridpointers[RID_INLINE]) - DECL_INLINE (fndecl) = 1; - else - abort (); - } - } - else /* pass == 2 */ - { - fndecl = get_next_decl (); - if (DECL_NAME (fndecl) != label) - abort (); /* outta sync - got wrong decl */ - func_type = TREE_TYPE (fndecl); - if (TYPE_RAISES_EXCEPTIONS (func_type) != NULL_TREE) - { - /* In this case we have to add 2 parameters. - See build_chill_function_type (pass == 1). */ - tree arg; - - arg = make_node (PARM_DECL); - DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_FILE); - DECL_IGNORED_P (arg) = 1; - parms = chainon (parms, arg); - - arg = make_node (PARM_DECL); - DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_LINE); - DECL_IGNORED_P (arg) = 1; - parms = chainon (parms, arg); - } - } - - current_function_decl = fndecl; - result_type = TREE_TYPE (func_type); - if (CH_TYPE_NONVALUE_P (result_type)) - error ("non-value mode may only returned by LOC"); - - pushlevel (1); /* Push parameters. */ - - if (pass == 2) - { - DECL_ARGUMENTS (fndecl) = parms; - for (decl = DECL_ARGUMENTS (fndecl), type = TYPE_ARG_TYPES (func_type); - decl != NULL_TREE; - decl = TREE_CHAIN (decl), type = TREE_CHAIN (type)) - { - /* check here that modes with the non-value property (like - BUFFER's, EVENT's, ASSOCIATION's, ACCESS's, or TEXT's) only - gets passed by LOC */ - tree argtype = TREE_VALUE (type); - tree argattr = TREE_PURPOSE (type); - - if (TREE_CODE (argtype) == REFERENCE_TYPE) - argtype = TREE_TYPE (argtype); - - if (TREE_CODE (argtype) != ERROR_MARK && - TREE_CODE_CLASS (TREE_CODE (argtype)) != 't') - { - error_with_decl (decl, "mode of `%s' is not a mode"); - TREE_VALUE (type) = error_mark_node; - } - - if (CH_TYPE_NONVALUE_P (argtype) && - argattr != ridpointers[(int) RID_LOC]) - error_with_decl (decl, "`%s' may only be passed by LOC"); - TREE_TYPE (decl) = TREE_VALUE (type); - DECL_ARG_TYPE (decl) = TREE_TYPE (decl); - DECL_CONTEXT (decl) = fndecl; - TREE_READONLY (decl) = TYPE_READONLY (argtype); - layout_decl (decl, 0); - } - - pushdecllist (DECL_ARGUMENTS (fndecl), 0); - - DECL_RESULT (current_function_decl) - = build_decl (RESULT_DECL, NULL_TREE, result_type); - -#if 0 - /* Write a record describing this function definition to the prototypes - file (if requested). */ - gen_aux_info_record (fndecl, 1, 0, prototype); -#endif - - if (fndecl != global_function_decl || seen_action) - { - /* Initialize the RTL code for the function. */ - init_function_start (fndecl, input_filename, lineno); - - /* Set up parameters and prepare for return, for the function. */ - expand_function_start (fndecl, 0); - } - - if (!nested) - /* Allocate further tree nodes temporarily during compilation - of this function only. */ - temporary_allocation (); - - /* If this fcn was already referenced via a block-scope `extern' decl (or - an implicit decl), propagate certain information about the usage. */ - if (TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (current_function_decl))) - TREE_ADDRESSABLE (current_function_decl) = 1; - } - - /* Z.200 requires that formal parameter names be defined in - the same block as the procedure body. - We could do this by keeping boths sets of DECLs in the same - scope, but we would have to be careful to not merge the - two chains (e.g. DECL_ARGUEMENTS musr not contains locals). - Instead, we just make sure they have the same nesting_level. */ - current_nesting_level--; - pushlevel (1); /* Push local variables. */ - - if (pass == 2 && (fndecl != global_function_decl || seen_action)) - { - /* generate label for possible 'exit' */ - expand_start_bindings (1); - - result_never_set = 1; - } - - if (TREE_CODE (result_type) == VOID_TYPE) - chill_result_decl = NULL_TREE; - else - { - /* We use the same name as the keyword. - This makes it easy to print and change the RESULT from gdb. */ - const char *result_str = - (ignore_case || ! special_UC) ? "result" : "RESULT"; - if (pass == 2 && TREE_CODE (result_type) == ERROR_MARK) - TREE_TYPE (current_scope->remembered_decls) = result_type; - chill_result_decl = do_decl (get_identifier (result_str), - result_type, 0, 0, 0, 0); - DECL_CONTEXT (chill_result_decl) = fndecl; - } - - return 1; -} - -/* For checking purpose added pname as new argument - MW Wed Oct 14 14:22:10 1992 */ -void -finish_chill_function () -{ - register tree fndecl = current_function_decl; - tree outer_function = decl_function_context (fndecl); - int nested; - if (outer_function == NULL_TREE && fndecl != global_function_decl) - outer_function = global_function_decl; - nested = current_function_decl != global_function_decl; - if (pass == 2 && (fndecl != global_function_decl || seen_action)) - expand_end_bindings (getdecls (), 1, 0); - - /* pop out of function */ - poplevel (1, 1, 0); - current_nesting_level++; - /* pop out of its parameters */ - poplevel (1, 0, 1); - - if (pass == 2) - { - /* TREE_READONLY (fndecl) = 1; - This caused &foo to be of type ptr-to-const-function which - then got a warning when stored in a ptr-to-function variable. */ - - BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; - - /* Must mark the RESULT_DECL as being in this function. */ - - DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; - - if (fndecl != global_function_decl || seen_action) - { - /* Generate rtl for function exit. */ - expand_function_end (input_filename, lineno, 0); - - /* Run the optimizers and output assembler code for this function. */ - rest_of_compilation (fndecl); - } - - if (DECL_SAVED_INSNS (fndecl) == 0 && ! nested) - { - /* Stop pointing to the local nodes about to be freed. */ - /* But DECL_INITIAL must remain nonzero so we know this - was an actual function definition. */ - /* For a nested function, this is done in pop_chill_function_context. */ - DECL_INITIAL (fndecl) = error_mark_node; - DECL_ARGUMENTS (fndecl) = 0; - } - } - current_function_decl = outer_function; -} - -/* process SEIZE */ - -/* Points to the head of the _DECLs read from seize files. */ -#if 0 -static tree seized_decls; - -static tree processed_seize_files = 0; -#endif - -void -chill_seize (old_prefix, new_prefix, postfix) - tree old_prefix, new_prefix, postfix; -{ - if (pass == 1) - { - tree decl = build_alias_decl (old_prefix, new_prefix, postfix); - DECL_SEIZEFILE(decl) = use_seizefile_name; - save_decl (decl); - } - else /* pass == 2 */ - { - /* Do nothing - get_next_decl automatically ignores ALIAS_DECLs */ - } -} -#if 0 - -/* - * output a debug dump of a scope structure - */ -void -debug_scope (sp) - struct scope *sp; -{ - if (sp == (struct scope *)NULL) - { - fprintf (stderr, "null scope ptr\n"); - return; - } - fprintf (stderr, "enclosing 0x%x ", sp->enclosing); - fprintf (stderr, "next 0x%x ", sp->next); - fprintf (stderr, "remembered_decls 0x%x ", sp->remembered_decls); - fprintf (stderr, "decls 0x%x\n", sp->decls); - fprintf (stderr, "shadowed 0x%x ", sp->shadowed); - fprintf (stderr, "blocks 0x%x ", sp->blocks); - fprintf (stderr, "this_block 0x%x ", sp->this_block); - fprintf (stderr, "level_chain 0x%x\n", sp->level_chain); - fprintf (stderr, "module_flag %c ", sp->module_flag ? 'T' : 'F'); - fprintf (stderr, "first_child_module 0x%x ", sp->first_child_module); - fprintf (stderr, "next_sibling_module 0x%x\n", sp->next_sibling_module); - if (sp->remembered_decls != NULL_TREE) - { - tree temp; - fprintf (stderr, "remembered_decl chain:\n"); - for (temp = sp->remembered_decls; temp; temp = TREE_CHAIN (temp)) - debug_tree (temp); - } -} -#endif - -static void -save_decl (decl) - tree decl; -{ - if (current_function_decl != global_function_decl) - DECL_CONTEXT (decl) = current_function_decl; - - TREE_CHAIN (decl) = current_scope->remembered_decls; - current_scope->remembered_decls = decl; -#if 0 - fprintf (stderr, "\n\nsave_decl 0x%x\n", decl); - debug_scope (current_scope); /* ************* */ -#endif - set_nesting_level (decl, current_nesting_level); -} - -static tree -get_next_decl () -{ - tree decl; - do - { - decl = current_scope->remembered_decls; - current_scope->remembered_decls = TREE_CHAIN (decl); - /* We ignore ALIAS_DECLs, because push_scope_decls - can convert a single ALIAS_DECL representing 'SEIZE ALL' - into one ALIAS_DECL for each seizeable name. - This means we lose the nice one-to-one mapping - between pass 1 decls and pass 2 decls. - (Perhaps ALIAS_DECLs should not be on the remembered_decls list.) */ - } while (decl && TREE_CODE (decl) == ALIAS_DECL); - return decl; -} - -/* At the end of pass 1, we reverse the chronological chain of scopes. */ - -void -switch_to_pass_2 () -{ -#if 0 - extern int errorcount, sorrycount; -#endif - if (current_scope != &builtin_scope) - abort (); - last_scope = &builtin_scope; - builtin_scope.remembered_decls = nreverse (builtin_scope.remembered_decls); - write_grant_file (); - -#if 0 - if (errorcount || sorrycount) - exit (FATAL_EXIT_CODE); - else -#endif - if (grant_only_flag) - exit (SUCCESS_EXIT_CODE); - - pass = 2; - module_number = 0; - next_module = &first_module; -} - -/* - * Called during pass 2, when we're processing actions, to - * generate a temporary variable. These don't need satisfying - * because they're compiler-generated and always declared - * before they're used. - */ -tree -decl_temp1 (name, type, opt_static, opt_init, - opt_external, opt_public) - tree name, type; - int opt_static; - tree opt_init; - int opt_external, opt_public; -{ - int orig_pass = pass; /* be cautious */ - tree mydecl; - - pass = 1; - mydecl = do_decl (name, type, opt_static, opt_static, - opt_init, opt_external); - - if (opt_public) - TREE_PUBLIC (mydecl) = 1; - pass = 2; - do_decl (name, type, opt_static, opt_static, opt_init, opt_external); - - pass = orig_pass; - return mydecl; -} - -/* True if we're reading a seizefile, but we haven't seen a SPEC MODULE yet. - For backwards compatibility, we treat declarations in such a context - as implicity granted. */ - -tree -set_module_name (name) - tree name; -{ - module_number++; - if (name == NULL_TREE) - { - /* NOTE: build_prefix_clause assumes a generated - module starts with a '_'. */ - char buf[20]; - sprintf (buf, "_MODULE_%d", module_number); - name = get_identifier (buf); - } - return name; -} - -tree -push_module (name, is_spec_module) - tree name; - int is_spec_module; -{ - struct module *new_module; - if (pass == 1) - { - new_module = (struct module*) permalloc (sizeof (struct module)); - new_module->prev_module = current_module; - - *next_module = new_module; - } - else - { - new_module = *next_module; - } - next_module = &new_module->next_module; - - new_module->procedure_seen = 0; - new_module->is_spec_module = is_spec_module; - new_module->name = name; - if (current_module) - new_module->prefix_name - = get_identifier3 (IDENTIFIER_POINTER (current_module->prefix_name), - "__", IDENTIFIER_POINTER (name)); - else - new_module->prefix_name = name; - - new_module->granted_decls = NULL_TREE; - new_module->nesting_level = current_nesting_level + 1; - - current_module = new_module; - current_module_nesting_level = new_module->nesting_level; - in_pseudo_module = name ? 0 : 1; - - pushlevel (1); - - current_scope->module_flag = 1; - - *current_scope->enclosing->tail_child_module = current_scope; - current_scope->enclosing->tail_child_module - = ¤t_scope->next_sibling_module; - - /* Rename the global function to have the same name as - the first named non-spec module. */ - if (!is_spec_module - && IDENTIFIER_POINTER (name)[0] != '_' - && IDENTIFIER_POINTER (DECL_NAME (global_function_decl))[0] == '_') - { - tree fname = get_identifier3 ("", IDENTIFIER_POINTER (name), "_"); - DECL_NAME (global_function_decl) = fname; - DECL_ASSEMBLER_NAME (global_function_decl) = fname; - } - - return name; /* may have generated a name */ -} -/* Make a copy of the identifier NAME, replacing each '!' by '__'. */ -static tree -fix_identifier (name) - tree name; -{ - char *buf = (char*)alloca (2 * IDENTIFIER_LENGTH (name) + 1); - int fixed = 0; - register char *dptr = buf; - register const char *sptr = IDENTIFIER_POINTER (name); - for (; *sptr; sptr++) - { - if (*sptr == '!') - { - *dptr++ = '_'; - *dptr++ = '_'; - fixed++; - } - else - *dptr++ = *sptr; - } - *dptr = '\0'; - return fixed ? get_identifier (buf) : name; -} - -void -find_granted_decls () -{ - if (pass == 1) - { - /* Match each granted name to a granted decl. */ - - tree alias = current_module->granted_decls; - tree next_alias, decl; - /* This is an O(M*N) algorithm. FIXME! */ - for (; alias; alias = next_alias) - { - int found = 0; - next_alias = TREE_CHAIN (alias); - for (decl = current_scope->remembered_decls; - decl; decl = TREE_CHAIN (decl)) - { - tree new_name = (! DECL_NAME (decl)) ? NULL_TREE : - decl_check_rename (alias, - DECL_NAME (decl)); - - if (!new_name) - continue; - /* A Seized declaration is not grantable. */ - if (TREE_CODE (decl) == ALIAS_DECL && !CH_DECL_GRANTED (decl)) - continue; - found = 1; - if (global_bindings_p ()) - TREE_PUBLIC (decl) = 1; - if (DECL_ASSEMBLER_NAME (decl) == NULL_TREE) - DECL_ASSEMBLER_NAME (decl) = fix_identifier (new_name); - if (DECL_POSTFIX_ALL (alias)) - { - tree new_alias - = build_alias_decl (NULL_TREE, NULL_TREE, new_name); - TREE_CHAIN (new_alias) = TREE_CHAIN (alias); - TREE_CHAIN (alias) = new_alias; - DECL_ABSTRACT_ORIGIN (new_alias) = decl; - DECL_SOURCE_LINE (new_alias) = 0; - DECL_SEIZEFILE (new_alias) = DECL_SEIZEFILE (alias); - } - else - { - DECL_ABSTRACT_ORIGIN (alias) = decl; - break; - } - } - if (!found) - { - error_with_decl (alias, "Nothing named `%s' to grant."); - DECL_ABSTRACT_ORIGIN (alias) = error_mark_node; - } - } - } -} - -void -pop_module () -{ - tree decl; - struct scope *module_scope = current_scope; - - poplevel (0, 0, 0); - - if (pass == 1) - { - /* Write out the grant file. */ - if (!current_module->is_spec_module) - { - /* After reversal, TREE_CHAIN (last_old_decl) is the oldest - decl of the current module. */ - write_spec_module (module_scope->remembered_decls, - current_module->granted_decls); - } - - /* Move the granted decls into the enclosing scope. */ - if (current_scope == global_scope) - { - tree next_decl; - for (decl = current_module->granted_decls; decl; decl = next_decl) - { - tree name = DECL_NAME (decl); - next_decl = TREE_CHAIN (decl); - if (name != NULL_TREE) - { - tree old_decl = IDENTIFIER_OUTER_VALUE (name); - set_nesting_level (decl, current_nesting_level); - if (old_decl != NULL_TREE) - { - pedwarn_with_decl (decl, "duplicate grant for `%s'"); - pedwarn_with_decl (old_decl, "previous grant for `%s'"); - TREE_CHAIN (decl) = TREE_CHAIN (old_decl); - TREE_CHAIN (old_decl) = decl; - } - else - { - TREE_CHAIN (decl) = outer_decls; - outer_decls = decl; - IDENTIFIER_OUTER_VALUE (name) = decl; - } - } - } - } - else - current_scope->granted_decls = chainon (current_module->granted_decls, - current_scope->granted_decls); - } - - chill_check_no_handlers (); /* Sanity test */ - current_module = current_module->prev_module; - current_module_nesting_level = current_module ? - current_module->nesting_level : 0; - in_pseudo_module = 0; -} - -/* Nonzero if we are currently in the global binding level. */ - -int -global_bindings_p () -{ - /* We return -1 here for the sake of variable_size() in ../stor-layout.c. */ - return (current_function_decl == NULL_TREE - || current_function_decl == global_function_decl) ? -1 : 0; -} - -/* Nonzero if the current level needs to have a BLOCK made. */ - -int -kept_level_p () -{ - return current_scope->decls != 0; -} - -/* Make DECL visible. - Save any existing definition. - Check redefinitions at the same level. - Suppress error messages if QUIET is true. */ - -static void -proclaim_decl (decl, quiet) - tree decl; - int quiet; -{ - tree name = DECL_NAME (decl); - if (name) - { - tree old_decl = IDENTIFIER_LOCAL_VALUE (name); - if (old_decl == NULL) ; /* No duplication */ - else if (DECL_NESTING_LEVEL (old_decl) != current_nesting_level) - { - /* Record for restoration when this binding level ends. */ - current_scope->shadowed - = tree_cons (name, old_decl, current_scope->shadowed); - } - else if (DECL_WEAK_NAME (decl)) - return; - else if (!DECL_WEAK_NAME (old_decl)) - { - tree base_decl = decl, base_old_decl = old_decl; - while (TREE_CODE (base_decl) == ALIAS_DECL) - base_decl = DECL_ABSTRACT_ORIGIN (base_decl); - while (TREE_CODE (base_old_decl) == ALIAS_DECL) - base_old_decl = DECL_ABSTRACT_ORIGIN (base_old_decl); - /* Note that duplicate definitions are allowed for set elements - of similar set modes. See Z200 (1988) 12.2.2. - However, if the types are identical, we are defining the - same name multiple times in the same SET, which is naughty. */ - if (!quiet && base_decl != base_old_decl) - { - if (TREE_CODE (base_decl) != CONST_DECL - || TREE_CODE (base_old_decl) != CONST_DECL - || !CH_DECL_ENUM (base_decl) - || !CH_DECL_ENUM (base_old_decl) - || TREE_TYPE (base_decl) == TREE_TYPE (base_old_decl) - || !CH_SIMILAR (TREE_TYPE (base_decl), - TREE_TYPE(base_old_decl))) - { - error_with_decl (decl, "duplicate definition `%s'"); - error_with_decl (old_decl, "previous definition of `%s'"); - } - } - } - IDENTIFIER_LOCAL_VALUE (name) = decl; - } - /* Should be redundant most of the time ... */ - set_nesting_level (decl, current_nesting_level); -} - -/* Return tree_cons (NULL_TREE, ELEMENT, LIST) unless ELEMENT - is already in LIST, in which case return LIST. */ - -static tree -maybe_acons (element, list) - tree element, list; -{ - tree pair; - for (pair = list; pair; pair = TREE_CHAIN (pair)) - if (element == TREE_VALUE (pair)) - return list; - return tree_cons (NULL_TREE, element, list); -} - -struct path -{ - struct path *prev; - tree node; -}; - -static tree find_implied_types PARAMS ((tree, struct path *, tree)); - -/* Look for implied types (enumeral types) implied by TYPE (a decl or type). - Add these to list. - Use old_path to guard against cycles. */ - -static tree -find_implied_types (type, old_path, list) - tree type; - struct path *old_path; - tree list; -{ - struct path path[1], *link; - if (type == NULL_TREE) - return list; - path[0].prev = old_path; - path[0].node = type; - - /* Check for a cycle. Something more clever might be appropriate. FIXME? */ - for (link = old_path; link; link = link->prev) - if (link->node == type) - return list; - - switch (TREE_CODE (type)) - { - case ENUMERAL_TYPE: - return maybe_acons (type, list); - case LANG_TYPE: - case POINTER_TYPE: - case REFERENCE_TYPE: - case INTEGER_TYPE: - return find_implied_types (TREE_TYPE (type), path, list); - case SET_TYPE: - return find_implied_types (TYPE_DOMAIN (type), path, list); - case FUNCTION_TYPE: -#if 0 - case PROCESS_TYPE: -#endif - { tree t; - list = find_implied_types (TREE_TYPE (type), path, list); - for (t = TYPE_ARG_TYPES (type); t != NULL_TREE; t = TREE_CHAIN (t)) - list = find_implied_types (TREE_VALUE (t), path, list); - return list; - } - case ARRAY_TYPE: - list = find_implied_types (TYPE_DOMAIN (type), path, list); - return find_implied_types (TREE_TYPE (type), path, list); - case RECORD_TYPE: - case UNION_TYPE: - { tree fields; - for (fields = TYPE_FIELDS (type); fields != NULL_TREE; - fields = TREE_CHAIN (fields)) - list = find_implied_types (TREE_TYPE (fields), path, list); - return list; - } - - case IDENTIFIER_NODE: - return find_implied_types (lookup_name (type), path, list); - break; - case ALIAS_DECL: - return find_implied_types (DECL_ABSTRACT_ORIGIN (type), path, list); - case VAR_DECL: - case FUNCTION_DECL: - case TYPE_DECL: - return find_implied_types (TREE_TYPE (type), path, list); - default: - return list; - } -} - -/* Make declarations in current scope visible. - Also, expand SEIZEs, and make correspondong ALIAS_DECLs visible. */ - -static void -push_scope_decls (quiet) - int quiet; /* If 1, we're pre-scanning, so suppress errors. */ -{ - tree decl; - - /* First make everything except 'SEIZE ALL' names visible, before - handling 'SEIZE ALL'. (This makes it easier to check 'seizable'). */ - for (decl = current_scope->remembered_decls; decl; decl = TREE_CHAIN (decl)) - { - if (TREE_CODE (decl) == ALIAS_DECL) - { - if (DECL_POSTFIX_ALL (decl)) - continue; - if (DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE) - { - tree val = lookup_name_for_seizing (decl); - if (val == NULL_TREE) - { - error_with_file_and_line - (DECL_SOURCE_FILE (decl), DECL_SOURCE_LINE (decl), - "cannot SEIZE `%s'", - IDENTIFIER_POINTER (DECL_OLD_NAME (decl))); - val = error_mark_node; - } - DECL_ABSTRACT_ORIGIN (decl) = val; - } - } - proclaim_decl (decl, quiet); - } - - pushdecllist (current_scope->granted_decls, quiet); - - /* Now handle SEIZE ALLs. */ - for (decl = current_scope->remembered_decls; decl; ) - { - tree next_decl = TREE_CHAIN (decl); - if (TREE_CODE (decl) == ALIAS_DECL - && DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE - && DECL_POSTFIX_ALL (decl)) - { - /* We saw a "SEIZE ALL". Replace it be a SEIZE for each - declaration visible in the surrounding scope. - Note that this complicates get_next_decl(). */ - tree candidate; - tree last_new_alias = decl; - DECL_ABSTRACT_ORIGIN (decl) = error_mark_node; - if (current_scope->enclosing == global_scope) - candidate = outer_decls; - else - candidate = current_scope->enclosing->decls; - for ( ; candidate; candidate = TREE_CHAIN (candidate)) - { - tree seizename = DECL_NAME (candidate); - tree new_name; - tree new_alias; - if (!seizename) - continue; - new_name = decl_check_rename (decl, seizename); - if (!new_name) - continue; - - /* Check if candidate is seizable. */ - if (lookup_name (new_name) != NULL_TREE) - continue; - - new_alias = build_alias_decl (NULL_TREE,NULL_TREE, new_name); - TREE_CHAIN (new_alias) = TREE_CHAIN (last_new_alias); - TREE_CHAIN (last_new_alias) = new_alias; - last_new_alias = new_alias; - DECL_ABSTRACT_ORIGIN (new_alias) = candidate; - DECL_SOURCE_LINE (new_alias) = 0; - - proclaim_decl (new_alias, quiet); - } - } - decl = next_decl; - } - - /* Link current_scope->remembered_decls at the head of the - current_scope->decls list (just like pushdecllist, but - without calling proclaim_decl, since we've already done that). */ - if ((decl = current_scope->remembered_decls) != NULL_TREE) - { - while (TREE_CHAIN (decl) != NULL_TREE) - decl = TREE_CHAIN (decl); - TREE_CHAIN (decl) = current_scope->decls; - current_scope->decls = current_scope->remembered_decls; - } -} - -static void -pop_scope_decls (decls_limit, shadowed_limit) - tree decls_limit, shadowed_limit; -{ - /* Remove the temporary bindings we made. */ - tree link = current_scope->shadowed; - tree decl = current_scope->decls; - if (decl != decls_limit) - { - while (decl != decls_limit) - { - tree next = TREE_CHAIN (decl); - if (DECL_NAME (decl)) - { - /* If the ident. was used or addressed via a local extern decl, - don't forget that fact. */ - if (DECL_EXTERNAL (decl)) - { - if (TREE_USED (decl)) - TREE_USED (DECL_NAME (decl)) = 1; - if (TREE_ADDRESSABLE (decl)) - TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (decl)) = 1; - } - IDENTIFIER_LOCAL_VALUE (DECL_NAME (decl)) = 0; - } - if (next == decls_limit) - { - TREE_CHAIN (decl) = NULL_TREE; - break; - } - decl = next; - } - current_scope->decls = decls_limit; - } - - /* Restore all name-meanings of the outer levels - that were shadowed by this level. */ - for ( ; link != shadowed_limit; link = TREE_CHAIN (link)) - IDENTIFIER_LOCAL_VALUE (TREE_PURPOSE (link)) = TREE_VALUE (link); - current_scope->shadowed = shadowed_limit; -} - -/* Return list of weak names (as ALIAS_DECLs) implied by IMPLIED_TYPES. */ - -static tree -build_implied_names (implied_types) - tree implied_types; -{ - tree aliases = NULL_TREE; - - for ( ; implied_types; implied_types = TREE_CHAIN (implied_types)) - { - tree enum_type = TREE_VALUE (implied_types); - tree link = TYPE_VALUES (enum_type); - if (TREE_CODE (enum_type) != ENUMERAL_TYPE) - abort (); - - for ( ; link; link = TREE_CHAIN (link)) - { - /* We don't handle renaming/prefixes (Blue Book p 163) FIXME */ - /* Note that before enum_type is laid out, TREE_VALUE (link) - is a CONST_DECL, while after it is laid out, - TREE_VALUE (link) is an INTEGER_CST. Either works. */ - tree alias - = build_alias_decl (NULL_TREE, NULL_TREE, TREE_PURPOSE (link)); - DECL_ABSTRACT_ORIGIN (alias) = TREE_VALUE (link); - DECL_WEAK_NAME (alias) = 1; - TREE_CHAIN (alias) = aliases; - aliases = alias; - /* Strictlt speaking, we should have a pointer from the alias - to the decl, so we can make sure that the alias is only - visible when the decl is. FIXME */ - } - } - return aliases; -} - -static void -bind_sub_modules (do_weak) - int do_weak; -{ - tree decl; - int save_module_nesting_level = current_module_nesting_level; - struct scope *saved_scope = current_scope; - struct scope *nested_module = current_scope->first_child_module; - - while (nested_module != NULL) - { - tree saved_shadowed = nested_module->shadowed; - tree saved_decls = nested_module->decls; - current_nesting_level++; - current_scope = nested_module; - current_module_nesting_level = current_nesting_level; - if (do_weak == 0) - push_scope_decls (1); - else - { - tree implied_types = NULL_TREE; - /* Push weak names implied by decls in current_scope. */ - for (decl = current_scope->remembered_decls; - decl; decl = TREE_CHAIN (decl)) - if (TREE_CODE (decl) == ALIAS_DECL) - implied_types = find_implied_types (decl, NULL, implied_types); - for (decl = current_scope->granted_decls; - decl; decl = TREE_CHAIN (decl)) - implied_types = find_implied_types (decl, NULL, implied_types); - current_scope->weak_decls = build_implied_names (implied_types); - pushdecllist (current_scope->weak_decls, 1); - } - - bind_sub_modules (do_weak); - for (decl = current_scope->remembered_decls; - decl; decl = TREE_CHAIN (decl)) - satisfy_decl (decl, 1); - pop_scope_decls (saved_decls, saved_shadowed); - current_nesting_level--; - nested_module = nested_module->next_sibling_module; - } - - current_scope = saved_scope; - current_module_nesting_level = save_module_nesting_level; -} - -/* Enter a new binding level. - If two_pass==0, assume we are called from non-Chill-specific parts - of the compiler. These parts assume a single pass. - If two_pass==1, we're called from Chill parts of the compiler. -*/ - -void -pushlevel (two_pass) - int two_pass; -{ - register struct scope *newlevel; - - current_nesting_level++; - if (!two_pass) - { - newlevel = (struct scope *)xmalloc (sizeof(struct scope)); - *newlevel = clear_scope; - newlevel->enclosing = current_scope; - current_scope = newlevel; - } - else if (pass < 2) - { - newlevel = (struct scope *)permalloc (sizeof(struct scope)); - *newlevel = clear_scope; - newlevel->tail_child_module = &newlevel->first_child_module; - newlevel->enclosing = current_scope; - current_scope = newlevel; - last_scope->next = newlevel; - last_scope = newlevel; - } - else /* pass == 2 */ - { - tree decl; - newlevel = current_scope = last_scope = last_scope->next; - - push_scope_decls (0); - pushdecllist (current_scope->weak_decls, 0); - - /* If this is not a module scope, scan ahead for locally nested - modules. (If this is a module, that's already done.) */ - if (!current_scope->module_flag) - { - bind_sub_modules (0); - bind_sub_modules (1); - } - - for (decl = current_scope->remembered_decls; - decl; decl = TREE_CHAIN (decl)) - satisfy_decl (decl, 0); - } - - /* Add this level to the front of the chain (stack) of levels that - are active. */ - - newlevel->level_chain = current_scope; - current_scope = newlevel; - - newlevel->two_pass = two_pass; -} - -/* Exit a binding level. - Pop the level off, and restore the state of the identifier-decl mappings - that were in effect when this level was entered. - - If KEEP is nonzero, this level had explicit declarations, so - and create a "block" (a BLOCK node) for the level - to record its declarations and subblocks for symbol table output. - - If FUNCTIONBODY is nonzero, this level is the body of a function, - so create a block as if KEEP were set and also clear out all - label names. - - If REVERSE is nonzero, reverse the order of decls before putting - them into the BLOCK. */ - -tree -poplevel (keep, reverse, functionbody) - int keep; - int reverse; - int functionbody; -{ - register tree link; - /* The chain of decls was accumulated in reverse order. - Put it into forward order, just for cleanliness. */ - tree decls; - tree subblocks; - tree block = 0; - tree decl; - int block_previously_created = 0; - - if (current_scope == NULL) - return error_mark_node; - - subblocks = current_scope->blocks; - - /* Get the decls in the order they were written. - Usually current_scope->decls is in reverse order. - But parameter decls were previously put in forward order. */ - - if (reverse) - current_scope->decls - = decls = nreverse (current_scope->decls); - else - decls = current_scope->decls; - - if (pass == 2) - { - /* Output any nested inline functions within this block - if they weren't already output. */ - - for (decl = decls; decl; decl = TREE_CHAIN (decl)) - if (TREE_CODE (decl) == FUNCTION_DECL - && ! TREE_ASM_WRITTEN (decl) - && DECL_INITIAL (decl) != 0 - && TREE_ADDRESSABLE (decl)) - { - /* If this decl was copied from a file-scope decl - on account of a block-scope extern decl, - propagate TREE_ADDRESSABLE to the file-scope decl. */ - if (DECL_ABSTRACT_ORIGIN (decl) != 0) - TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; - else - { - push_function_context (); - output_inline_function (decl); - pop_function_context (); - } - } - - /* Clear out the meanings of the local variables of this level. */ - pop_scope_decls (NULL_TREE, NULL_TREE); - - /* If there were any declarations or structure tags in that level, - or if this level is a function body, - create a BLOCK to record them for the life of this function. */ - - block = 0; - block_previously_created = (current_scope->this_block != 0); - if (block_previously_created) - block = current_scope->this_block; - else if (keep || functionbody) - block = make_node (BLOCK); - if (block != 0) - { - tree *ptr; - BLOCK_VARS (block) = decls; - - /* Splice out ALIAS_DECL and LABEL_DECLs, - since instantiate_decls can't handle them. */ - for (ptr = &BLOCK_VARS (block); *ptr; ) - { - decl = *ptr; - if (TREE_CODE (decl) == ALIAS_DECL - || TREE_CODE (decl) == LABEL_DECL) - *ptr = TREE_CHAIN (decl); - else - ptr = &TREE_CHAIN(*ptr); - } - - BLOCK_SUBBLOCKS (block) = subblocks; - } - - /* In each subblock, record that this is its superior. */ - - for (link = subblocks; link; link = TREE_CHAIN (link)) - BLOCK_SUPERCONTEXT (link) = block; - - } - - /* If the level being exited is the top level of a function, - check over all the labels, and clear out the current - (function local) meanings of their names. */ - - if (pass == 2 && functionbody) - { - /* If this is the top level block of a function, - the vars are the function's parameters. - Don't leave them in the BLOCK because they are - found in the FUNCTION_DECL instead. */ - - BLOCK_VARS (block) = 0; - -#if 0 - /* Clear out the definitions of all label names, - since their scopes end here, - and add them to BLOCK_VARS. */ - - for (link = named_labels; link; link = TREE_CHAIN (link)) - { - register tree label = TREE_VALUE (link); - - if (DECL_INITIAL (label) == 0) - { - error_with_decl (label, "label `%s' used but not defined"); - /* Avoid crashing later. */ - define_label (input_filename, lineno, - DECL_NAME (label)); - } - else if (warn_unused_label && !TREE_USED (label)) - warning_with_decl (label, "label `%s' defined but not used"); - IDENTIFIER_LABEL_VALUE (DECL_NAME (label)) = 0; - - /* Put the labels into the "variables" of the - top-level block, so debugger can see them. */ - TREE_CHAIN (label) = BLOCK_VARS (block); - BLOCK_VARS (block) = label; - } -#endif - } - - if (pass < 2) - { - current_scope->remembered_decls - = nreverse (current_scope->remembered_decls); - current_scope->granted_decls = nreverse (current_scope->granted_decls); - } - - current_scope = current_scope->enclosing; - current_nesting_level--; - - if (pass < 2) - { - return NULL_TREE; - } - - /* Dispose of the block that we just made inside some higher level. */ - if (functionbody) - DECL_INITIAL (current_function_decl) = block; - else if (block) - { - if (!block_previously_created) - current_scope->blocks - = chainon (current_scope->blocks, block); - } - /* If we did not make a block for the level just exited, - any blocks made for inner levels - (since they cannot be recorded as subblocks in that level) - must be carried forward so they will later become subblocks - of something else. */ - else if (subblocks) - current_scope->blocks - = chainon (current_scope->blocks, subblocks); - - if (block) - TREE_USED (block) = 1; - return block; -} - -/* Delete the node BLOCK from the current binding level. - This is used for the block inside a stmt expr ({...}) - so that the block can be reinserted where appropriate. */ - -void -delete_block (block) - tree block; -{ - tree t; - if (current_scope->blocks == block) - current_scope->blocks = TREE_CHAIN (block); - for (t = current_scope->blocks; t;) - { - if (TREE_CHAIN (t) == block) - TREE_CHAIN (t) = TREE_CHAIN (block); - else - t = TREE_CHAIN (t); - } - TREE_CHAIN (block) = NULL; - /* Clear TREE_USED which is always set by poplevel. - The flag is set again if insert_block is called. */ - TREE_USED (block) = 0; -} - -/* Insert BLOCK at the end of the list of subblocks of the - current binding level. This is used when a BIND_EXPR is expanded, - to handle the BLOCK node inside teh BIND_EXPR. */ - -void -insert_block (block) - tree block; -{ - TREE_USED (block) = 1; - current_scope->blocks - = chainon (current_scope->blocks, block); -} - -/* Set the BLOCK node for the innermost scope - (the one we are currently in). */ - -void -set_block (block) - register tree block; -{ - current_scope->this_block = block; -} - -/* Record a decl-node X as belonging to the current lexical scope. - Check for errors (such as an incompatible declaration for the same - name already seen in the same scope). - - Returns either X or an old decl for the same name. - If an old decl is returned, it may have been smashed - to agree with what X says. */ - -tree -pushdecl (x) - tree x; -{ - register tree name = DECL_NAME (x); - register struct scope *b = current_scope; - - DECL_CONTEXT (x) = current_function_decl; - /* A local extern declaration for a function doesn't constitute nesting. - A local auto declaration does, since it's a forward decl - for a nested function coming later. */ - if (TREE_CODE (x) == FUNCTION_DECL && DECL_INITIAL (x) == 0 - && DECL_EXTERNAL (x)) - DECL_CONTEXT (x) = 0; - - if (name) - proclaim_decl (x, 0); - - if (TREE_CODE (x) == TYPE_DECL && DECL_SOURCE_LINE (x) == 0 - && TYPE_NAME (TREE_TYPE (x)) == 0) - TYPE_NAME (TREE_TYPE (x)) = x; - - /* Put decls on list in reverse order. - We will reverse them later if necessary. */ - TREE_CHAIN (x) = b->decls; - b->decls = x; - - return x; -} - -/* Make DECLS (a chain of decls) visible in the current_scope. */ - -static void -pushdecllist (decls, quiet) - tree decls; - int quiet; -{ - tree last = NULL_TREE, decl; - - for (decl = decls; decl != NULL_TREE; - last = decl, decl = TREE_CHAIN (decl)) - { - proclaim_decl (decl, quiet); - } - - if (last) - { - TREE_CHAIN (last) = current_scope->decls; - current_scope->decls = decls; - } -} - -/* Like pushdecl, only it places X in GLOBAL_SCOPE, if appropriate. */ - -tree -pushdecl_top_level (x) - tree x; -{ - register tree t; - register struct scope *b = current_scope; - - current_scope = global_scope; - t = pushdecl (x); - current_scope = b; - return t; -} - -/* Define a label, specifying the location in the source file. - Return the LABEL_DECL node for the label, if the definition is valid. - Otherwise return 0. */ - -tree -define_label (filename, line, name) - const char *filename; - int line; - tree name; -{ - tree decl; - - if (pass == 1) - { - decl = build_decl (LABEL_DECL, name, void_type_node); - - /* A label not explicitly declared must be local to where it's ref'd. */ - DECL_CONTEXT (decl) = current_function_decl; - - DECL_MODE (decl) = VOIDmode; - - /* Say where one reference is to the label, - for the sake of the error if it is not defined. */ - DECL_SOURCE_LINE (decl) = line; - DECL_SOURCE_FILE (decl) = filename; - - /* Mark label as having been defined. */ - DECL_INITIAL (decl) = error_mark_node; - - DECL_ACTION_NESTING_LEVEL (decl) = action_nesting_level; - - save_decl (decl); - } - else - { - decl = get_next_decl (); - /* Make sure every label has an rtx. */ - - label_rtx (decl); - expand_label (decl); - } - return decl; -} - -/* Return the list of declarations of the current level. - Note that this list is in reverse order unless/until - you nreverse it; and when you do nreverse it, you must - store the result back using `storedecls' or you will lose. */ - -tree -getdecls () -{ - /* This is a kludge, so that dbxout_init can get the predefined types, - which are in the builtin_scope, though when it is called, - the current_scope is the global_scope.. */ - if (current_scope == global_scope) - return builtin_scope.decls; - return current_scope->decls; -} - -#if 0 -/* Store the list of declarations of the current level. - This is done for the parameter declarations of a function being defined, - after they are modified in the light of any missing parameters. */ - -static void -storedecls (decls) - tree decls; -{ - current_scope->decls = decls; -} -#endif - -/* Look up NAME in the current binding level and its superiors - in the namespace of variables, functions and typedefs. - Return a ..._DECL node of some kind representing its definition, - or return 0 if it is undefined. */ - -tree -lookup_name (name) - tree name; -{ - register tree val = IDENTIFIER_LOCAL_VALUE (name); - - if (val == NULL_TREE) - return NULL_TREE; - if (TREE_CODE_CLASS (TREE_CODE (val)) == 'c') - return val; - if (DECL_NESTING_LEVEL (val) > BUILTIN_NESTING_LEVEL - && DECL_NESTING_LEVEL (val) < current_module_nesting_level) - { - return NULL_TREE; - } - while (TREE_CODE (val) == ALIAS_DECL) - { - val = DECL_ABSTRACT_ORIGIN (val); - if (TREE_CODE (val) == ERROR_MARK) - return NULL_TREE; - } - if (TREE_CODE (val) == BASED_DECL) - { - return build_chill_indirect_ref (DECL_ABSTRACT_ORIGIN (val), - TREE_TYPE (val), 1); - } - if (TREE_CODE (val) == WITH_DECL) - return build_component_ref (DECL_ABSTRACT_ORIGIN (val), DECL_NAME (val)); - return val; -} - -#if 0 -/* Similar to `lookup_name' but look only at current binding level. */ - -static tree -lookup_name_current_level (name) - tree name; -{ - register tree val = IDENTIFIER_LOCAL_VALUE (name); - if (val && DECL_NESTING_LEVEL (val) == current_nesting_level) - return val; - return NULL_TREE; -} -#endif - -static tree -lookup_name_for_seizing (seize_decl) - tree seize_decl; -{ - tree name = DECL_OLD_NAME (seize_decl); - register tree val; - val = IDENTIFIER_LOCAL_VALUE (name); - if (val == NULL_TREE || DECL_NESTING_LEVEL (val) == BUILTIN_NESTING_LEVEL) - { - val = IDENTIFIER_OUTER_VALUE (name); - if (val == NULL_TREE) - return NULL_TREE; - if (TREE_CHAIN (val) && DECL_NAME (TREE_CHAIN (val)) == name) - { /* More than one decl with the same name has been granted - into the same global scope. Pick the one (we hope) that - came from a seizefile the matches the most recent - seizefile (as given by DECL_SEIZEFILE (seize_decl).) */ - tree d, best = NULL_TREE; - for (d = val; d != NULL_TREE && DECL_NAME (d) == name; - d = TREE_CHAIN (d)) - if (DECL_SEIZEFILE (d) == DECL_SEIZEFILE (seize_decl)) - { - if (best) - { - error_with_decl (seize_decl, - "ambiguous choice for seize `%s' -"); - error_with_decl (best, " - can seize this `%s' -"); - error_with_decl (d, " - or this granted decl `%s'"); - return NULL_TREE; - } - best = d; - } - if (best == NULL_TREE) - { - error_with_decl (seize_decl, - "ambiguous choice for seize `%s' -"); - error_with_decl (val, " - can seize this `%s' -"); - error_with_decl (TREE_CHAIN (val), - " - or this granted decl `%s'"); - return NULL_TREE; - } - val = best; - } - } -#if 0 - /* We don't need to handle this, as long as we - resolve the seize targets before pushing them. */ - if (DECL_NESTING_LEVEL (val) >= current_module_nesting_level) - { - /* VAL was declared inside current module. We need something - from the scope *enclosing* the current module, so search - through the shadowed declarations. */ - /* TODO - FIXME */ - } -#endif - if (current_module && current_module->prev_module - && DECL_NESTING_LEVEL (val) - < current_module->prev_module->nesting_level) - { - - /* It's declared in a scope enclosing the module enclosing - the current module. Hence it's not visible. */ - return NULL_TREE; - } - while (TREE_CODE (val) == ALIAS_DECL) - { - val = DECL_ABSTRACT_ORIGIN (val); - if (TREE_CODE (val) == ERROR_MARK) - return NULL_TREE; - } - return val; -} - -/* Create the predefined scalar types of C, - and some nodes representing standard constants (0, 1, (void *)0). - Initialize the global binding level. - Make definitions for built-in primitive functions. */ - -void -init_decl_processing () -{ - int wchar_type_size; - tree bool_ftype_int_ptr_int; - tree bool_ftype_int_ptr_int_int; - tree bool_ftype_luns_ptr_luns_long; - tree bool_ftype_luns_ptr_luns_long_ptr_int; - tree bool_ftype_ptr_int_ptr_int; - tree bool_ftype_ptr_int_ptr_int_int; - tree find_bit_ftype; - tree bool_ftype_ptr_ptr_int; - tree bool_ftype_ptr_ptr_luns; - tree bool_ftype_ptr_ptr_ptr_luns; - tree endlink; - tree int_ftype_int; - tree int_ftype_int_int; - tree int_ftype_int_ptr_int; - tree int_ftype_ptr; - tree int_ftype_ptr_int; - tree int_ftype_ptr_int_int_ptr_int; - tree int_ftype_ptr_luns_long_ptr_int; - tree int_ftype_ptr_ptr_int; - tree int_ftype_ptr_ptr_luns; - tree long_ftype_ptr_luns; - tree memcpy_ftype; - tree memcmp_ftype; - tree ptr_ftype_ptr_int_int; - tree ptr_ftype_ptr_ptr_int; - tree ptr_ftype_ptr_ptr_int_ptr_int; - tree real_ftype_real; - tree temp; - tree void_ftype_cptr_cptr_int; - tree void_ftype_long_int_ptr_int_ptr_int; - tree void_ftype_ptr; - tree void_ftype_ptr_int_int_int_int; - tree void_ftype_ptr_int_ptr_int_int_int; - tree void_ftype_ptr_int_ptr_int_ptr_int; - tree void_ftype_ptr_luns_long_long_bool_ptr_int; - tree void_ftype_ptr_luns_ptr_luns_luns_luns; - tree void_ftype_ptr_ptr_ptr_int; - tree void_ftype_ptr_ptr_ptr_luns; - tree void_ftype_refptr_int_ptr_int; - tree void_ftype_void; - tree void_ftype_ptr_ptr_int; - tree void_ftype_ptr_luns_luns_cptr_luns_luns_luns; - tree ptr_ftype_luns_ptr_int; - tree double_ftype_double; - - /* allow 0-255 enums to occupy only a byte */ - flag_short_enums = 1; - - current_function_decl = NULL; - - set_alignment = BITS_PER_UNIT; - - ALL_POSTFIX = get_identifier ("*"); - string_index_type_dummy = get_identifier("%string-index%"); - - var_length_id = get_identifier (VAR_LENGTH); - var_data_id = get_identifier (VAR_DATA); - - build_common_tree_nodes (1); - - if (CHILL_INT_IS_SHORT) - long_integer_type_node = integer_type_node; - else - long_integer_type_node = make_signed_type (LONG_TYPE_SIZE); - - /* `unsigned long' is the standard type for sizeof. - Note that stddef.h uses `unsigned long', - and this must agree, even of long and int are the same size. */ -#ifndef SIZE_TYPE - set_sizetype (long_unsigned_type_node); -#else - { - const char *size_type_c_name = SIZE_TYPE; - if (strncmp (size_type_c_name, "long long ", 10) == 0) - set_sizetype (long_long_unsigned_type_node); - else if (strncmp (size_type_c_name, "long ", 5) == 0) - set_sizetype (long_unsigned_type_node); - else - set_sizetype (unsigned_type_node); - } -#endif - - pushdecl (build_decl (TYPE_DECL, ridpointers[(int) RID_FLOAT], - float_type_node)); - pushdecl (build_decl (TYPE_DECL, ridpointers[(int) RID_DOUBLE], - double_type_node)); - - build_common_tree_nodes_2 (flag_short_double); - - pushdecl (build_decl (TYPE_DECL, - ridpointers[(int) RID_VOID], void_type_node)); - /* We are not going to have real types in C with less than byte alignment, - so we might as well not have any types that claim to have it. */ - TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; - TYPE_USER_ALIGN (void_type_node) = 0; - - /* This is for wide string constants. */ - wchar_type_node = short_unsigned_type_node; - wchar_type_size = TYPE_PRECISION (wchar_type_node); - signed_wchar_type_node = type_for_size (wchar_type_size, 0); - unsigned_wchar_type_node = type_for_size (wchar_type_size, 1); - - default_function_type - = build_function_type (integer_type_node, NULL_TREE); - - ptr_type_node = build_pointer_type (void_type_node); - const_ptr_type_node - = build_pointer_type (build_type_variant (void_type_node, 1, 0)); - - void_list_node = build_tree_list (NULL_TREE, void_type_node); - - boolean_type_node = make_node (BOOLEAN_TYPE); - TYPE_PRECISION (boolean_type_node) = 1; - fixup_unsigned_type (boolean_type_node); - boolean_false_node = TYPE_MIN_VALUE (boolean_type_node); - boolean_true_node = TYPE_MAX_VALUE (boolean_type_node); - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_BOOL], - boolean_type_node)); - - /* TRUE and FALSE have the BOOL derived class */ - CH_DERIVED_FLAG (boolean_true_node) = 1; - CH_DERIVED_FLAG (boolean_false_node) = 1; - - signed_boolean_type_node = make_node (BOOLEAN_TYPE); - temp = build_int_2 (-1, -1); - TREE_TYPE (temp) = signed_boolean_type_node; - TYPE_MIN_VALUE (signed_boolean_type_node) = temp; - temp = build_int_2 (0, 0); - TREE_TYPE (temp) = signed_boolean_type_node; - TYPE_MAX_VALUE (signed_boolean_type_node) = temp; - layout_type (signed_boolean_type_node); - - - bitstring_one_type_node = build_bitstring_type (integer_one_node); - bit_zero_node = build (CONSTRUCTOR, bitstring_one_type_node, NULL_TREE, - NULL_TREE); - bit_one_node = build (CONSTRUCTOR, bitstring_one_type_node, NULL_TREE, - build_tree_list (NULL_TREE, integer_zero_node)); - - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_CHAR], - char_type_node)); - - if (CHILL_INT_IS_SHORT) - { - chill_integer_type_node = short_integer_type_node; - chill_unsigned_type_node = short_unsigned_type_node; - } - else - { - chill_integer_type_node = integer_type_node; - chill_unsigned_type_node = unsigned_type_node; - } - - string_one_type_node = build_string_type (char_type_node, integer_one_node); - - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_BYTE], - signed_char_type_node)); - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_UBYTE], - unsigned_char_type_node)); - - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_INT], - chill_integer_type_node)); - - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_UINT], - chill_unsigned_type_node)); - - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_LONG], - long_integer_type_node)); - - set_sizetype (long_integer_type_node); -#if 0 - ptrdiff_type_node - = TREE_TYPE (IDENTIFIER_LOCAL_VALUE (get_identifier (PTRDIFF_TYPE))); -#endif - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_ULONG], - long_unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_REAL], - float_type_node)); - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_LONG_REAL], - double_type_node)); - pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_PTR], - ptr_type_node)); - - IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_TRUE]) = - boolean_true_node; - IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_FALSE]) = - boolean_false_node; - IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_NULL]) = - null_pointer_node; - - /* The second operand is set to non-NULL to distinguish - (ELSE) from (*). Used when writing grant files. */ - case_else_node = build (RANGE_EXPR, - NULL_TREE, NULL_TREE, boolean_false_node); - - pushdecl (temp = build_decl (TYPE_DECL, - get_identifier ("__tmp_initializer"), - build_init_struct ())); - DECL_SOURCE_LINE (temp) = 0; - initializer_type = TREE_TYPE (temp); - - memcpy (tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE, - chill_tree_code_type, - (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE) - * sizeof (char))); - memcpy (tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE, - chill_tree_code_length, - (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE) - * sizeof (int))); - memcpy (tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE, - chill_tree_code_name, - (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE) - * sizeof (char *))); - boolean_code_name = (const char **) xcalloc (sizeof (char *), - (int) LAST_CHILL_TREE_CODE); - - boolean_code_name[EQ_EXPR] = "="; - boolean_code_name[NE_EXPR] = "/="; - boolean_code_name[LT_EXPR] = "<"; - boolean_code_name[GT_EXPR] = ">"; - boolean_code_name[LE_EXPR] = "<="; - boolean_code_name[GE_EXPR] = ">="; - boolean_code_name[SET_IN_EXPR] = "in"; - boolean_code_name[TRUTH_ANDIF_EXPR] = "andif"; - boolean_code_name[TRUTH_ORIF_EXPR] = "orif"; - boolean_code_name[TRUTH_AND_EXPR] = "and"; - boolean_code_name[TRUTH_OR_EXPR] = "or"; - boolean_code_name[BIT_AND_EXPR] = "and"; - boolean_code_name[BIT_IOR_EXPR] = "or"; - boolean_code_name[BIT_XOR_EXPR] = "xor"; - - endlink = void_list_node; - - chill_predefined_function_type - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)); - - bool_ftype_int_ptr_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - bool_ftype_int_ptr_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - bool_ftype_int_ptr_int_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - bool_ftype_luns_ptr_luns_long - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - endlink))))); - bool_ftype_luns_ptr_luns_long_ptr_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))); - bool_ftype_ptr_ptr_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - bool_ftype_ptr_ptr_luns - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink)))); - bool_ftype_ptr_ptr_ptr_luns - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink))))); - bool_ftype_ptr_int_ptr_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - bool_ftype_ptr_int_ptr_int_int - = build_function_type (boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))); - find_bit_ftype - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - int_ftype_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)); - int_ftype_int_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))); - int_ftype_int_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - int_ftype_ptr - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - endlink)); - int_ftype_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))); - - long_ftype_ptr_luns - = build_function_type (long_integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink))); - - int_ftype_ptr_int_int_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))); - - int_ftype_ptr_luns_long_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))); - - int_ftype_ptr_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - int_ftype_ptr_ptr_luns - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink)))); - memcpy_ftype /* memcpy/memmove prototype */ - = build_function_type (ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, const_ptr_type_node, - tree_cons (NULL_TREE, sizetype, - endlink)))); - memcmp_ftype /* memcmp prototype */ - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, sizetype, - endlink)))); - - ptr_ftype_ptr_int_int - = build_function_type (ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - ptr_ftype_ptr_ptr_int - = build_function_type (ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - ptr_ftype_ptr_ptr_int_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))); - real_ftype_real - = build_function_type (float_type_node, - tree_cons (NULL_TREE, float_type_node, - endlink)); - - void_ftype_ptr - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, endlink)); - - void_ftype_cptr_cptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, const_ptr_type_node, - tree_cons (NULL_TREE, const_ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - - void_ftype_refptr_int_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, build_reference_type(ptr_type_node), - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - - void_ftype_ptr_ptr_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - void_ftype_ptr_ptr_ptr_luns - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink))))); - void_ftype_ptr_int_int_int_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))); - void_ftype_ptr_luns_long_long_bool_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - tree_cons (NULL_TREE, boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))))); - void_ftype_ptr_int_ptr_int_int_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))); - void_ftype_ptr_luns_ptr_luns_luns_luns - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink))))))); - void_ftype_ptr_int_ptr_int_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))); - void_ftype_long_int_ptr_int_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))); - void_ftype_void - = build_function_type (void_type_node, - tree_cons (NULL_TREE, void_type_node, - endlink)); - - void_ftype_ptr_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - - void_ftype_ptr_luns_luns_cptr_luns_luns_luns - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, const_ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - endlink)))))))); - - ptr_ftype_luns_ptr_int - = build_function_type (ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - - double_ftype_double - = build_function_type (double_type_node, - tree_cons (NULL_TREE, double_type_node, - endlink)); - -/* These are compiler-internal function calls, not intended - to be directly called by user code */ - builtin_function ("__allocate", ptr_ftype_luns_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("_allocate_global_memory", void_ftype_refptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("_allocate_memory", void_ftype_refptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__andpowerset", bool_ftype_ptr_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__bitsetpowerset", void_ftype_ptr_int_int_int_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__cardpowerset", long_ftype_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__cause_ex1", void_ftype_cptr_cptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__concatstring", ptr_ftype_ptr_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__continue", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__diffpowerset", void_ftype_ptr_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__eqpowerset", bool_ftype_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__ffsetclrpowerset", find_bit_ftype, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__flsetclrpowerset", find_bit_ftype, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__flsetpowerset", int_ftype_ptr_luns_long_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__ffsetpowerset", int_ftype_ptr_luns_long_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__inbitstring", bool_ftype_luns_ptr_luns_long_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__inpowerset", bool_ftype_luns_ptr_luns_long, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__lepowerset", bool_ftype_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__ltpowerset", bool_ftype_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - /* Currently under experimentation. */ - builtin_function ("memmove", memcpy_ftype, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("memcmp", memcmp_ftype, - 0, NOT_BUILT_IN, NULL_PTR); - - /* this comes from c-decl.c (init_decl_processing) */ - builtin_function ("__builtin_alloca", - build_function_type (ptr_type_node, - tree_cons (NULL_TREE, - sizetype, - endlink)), - BUILT_IN_ALLOCA, BUILT_IN_NORMAL, "alloca"); - - builtin_function ("memset", ptr_ftype_ptr_int_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__notpowerset", bool_ftype_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__orpowerset", bool_ftype_ptr_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__psslice", void_ftype_ptr_int_ptr_int_int_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__pscpy", void_ftype_ptr_luns_luns_cptr_luns_luns_luns, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("_return_memory", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__setbitpowerset", void_ftype_ptr_luns_long_long_bool_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__terminate", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__unhandled_ex", void_ftype_cptr_cptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__xorpowerset", bool_ftype_ptr_ptr_ptr_luns, - 0, NOT_BUILT_IN, NULL_PTR); - - /* declare floating point functions */ - builtin_function ("__sin", double_ftype_double, 0, NOT_BUILT_IN, "sin"); - builtin_function ("__cos", double_ftype_double, 0, NOT_BUILT_IN, "cos"); - builtin_function ("__tan", double_ftype_double, 0, NOT_BUILT_IN, "tan"); - builtin_function ("__asin", double_ftype_double, 0, NOT_BUILT_IN, "asin"); - builtin_function ("__acos", double_ftype_double, 0, NOT_BUILT_IN, "acos"); - builtin_function ("__atan", double_ftype_double, 0, NOT_BUILT_IN, "atan"); - builtin_function ("__exp", double_ftype_double, 0, NOT_BUILT_IN, "exp"); - builtin_function ("__log", double_ftype_double, 0, NOT_BUILT_IN, "log"); - builtin_function ("__log10", double_ftype_double, 0, NOT_BUILT_IN, "log10"); - builtin_function ("__sqrt", double_ftype_double, 0, NOT_BUILT_IN, "sqrt"); - - tasking_init (); - timing_init (); - inout_init (); - - /* These are predefined value builtin routine calls, built - by the compiler, but over-ridable by user procedures of - the same names. Note the lack of a leading underscore. */ - builtin_function ((ignore_case || ! special_UC) ? "abs" : "ABS", - chill_predefined_function_type, - BUILT_IN_CH_ABS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "abstime" : "ABSTIME", - chill_predefined_function_type, - BUILT_IN_ABSTIME, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "allocate" : "ALLOCATE", - chill_predefined_function_type, - BUILT_IN_ALLOCATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "allocate_memory" : "ALLOCATE_MEMORY", - chill_predefined_function_type, - BUILT_IN_ALLOCATE_MEMORY, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "addr" : "ADDR", - chill_predefined_function_type, - BUILT_IN_ADDR, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "allocate_global_memory" : "ALLOCATE_GLOBAL_MEMORY", - chill_predefined_function_type, - BUILT_IN_ALLOCATE_GLOBAL_MEMORY, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "arccos" : "ARCCOS", - chill_predefined_function_type, - BUILT_IN_ARCCOS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "arcsin" : "ARCSIN", - chill_predefined_function_type, - BUILT_IN_ARCSIN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "arctan" : "ARCTAN", - chill_predefined_function_type, - BUILT_IN_ARCTAN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "card" : "CARD", - chill_predefined_function_type, - BUILT_IN_CARD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "cos" : "COS", - chill_predefined_function_type, - BUILT_IN_CH_COS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "days" : "DAYS", - chill_predefined_function_type, - BUILT_IN_DAYS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "descr" : "DESCR", - chill_predefined_function_type, - BUILT_IN_DESCR, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "getstack" : "GETSTACK", - chill_predefined_function_type, - BUILT_IN_GETSTACK, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "exp" : "EXP", - chill_predefined_function_type, - BUILT_IN_EXP, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "hours" : "HOURS", - chill_predefined_function_type, - BUILT_IN_HOURS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "inttime" : "INTTIME", - chill_predefined_function_type, - BUILT_IN_INTTIME, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "length" : "LENGTH", - chill_predefined_function_type, - BUILT_IN_LENGTH, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "log" : "LOG", - chill_predefined_function_type, - BUILT_IN_LOG, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "lower" : "LOWER", - chill_predefined_function_type, - BUILT_IN_LOWER, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "ln" : "LN", - chill_predefined_function_type, - BUILT_IN_LN, BUILT_IN_NORMAL, NULL_PTR); - /* Note: these are *not* the C integer MAX and MIN. They're - for powerset arguments. */ - builtin_function ((ignore_case || ! special_UC) ? "max" : "MAX", - chill_predefined_function_type, - BUILT_IN_MAX, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "millisecs" : "MILLISECS", - chill_predefined_function_type, - BUILT_IN_MILLISECS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "min" : "MIN", - chill_predefined_function_type, - BUILT_IN_MIN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "minutes" : "MINUTES", - chill_predefined_function_type, - BUILT_IN_MINUTES, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "num" : "NUM", - chill_predefined_function_type, - BUILT_IN_NUM, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "pred" : "PRED", - chill_predefined_function_type, - BUILT_IN_PRED, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "return_memory" : "RETURN_MEMORY", - chill_predefined_function_type, - BUILT_IN_RETURN_MEMORY, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "secs" : "SECS", - chill_predefined_function_type, - BUILT_IN_SECS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "sin" : "SIN", - chill_predefined_function_type, - BUILT_IN_CH_SIN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "size" : "SIZE", - chill_predefined_function_type, - BUILT_IN_SIZE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "sqrt" : "SQRT", - chill_predefined_function_type, - BUILT_IN_SQRT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "succ" : "SUCC", - chill_predefined_function_type, - BUILT_IN_SUCC, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "tan" : "TAN", - chill_predefined_function_type, - BUILT_IN_TAN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "terminate" : "TERMINATE", - chill_predefined_function_type, - BUILT_IN_TERMINATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "upper" : "UPPER", - chill_predefined_function_type, - BUILT_IN_UPPER, BUILT_IN_NORMAL, NULL_PTR); - - build_chill_descr_type (); - build_chill_inttime_type (); - - endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); - - start_identifier_warnings (); - - pass = 1; -} - -/* Return a definition for a builtin function named NAME and whose data type - is TYPE. TYPE should be a function type with argument types. - FUNCTION_CODE tells later passes how to compile calls to this function. - See tree.h for its possible values. - - If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, - the name to be called if we can't opencode the function. */ - -tree -builtin_function (name, type, function_code, class, library_name) - const char *name; - tree type; - int function_code; - enum built_in_class class; - const char *library_name; -{ - tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - /* If -traditional, permit redefining a builtin function any way you like. - (Though really, if the program redefines these functions, - it probably won't work right unless compiled with -fno-builtin.) */ - if (flag_traditional && name[0] != '_') - DECL_BUILT_IN_NONANSI (decl) = 1; - if (library_name) - DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); - make_decl_rtl (decl, NULL_PTR, 1); - pushdecl (decl); - DECL_BUILT_IN_CLASS (decl) = class; - DECL_FUNCTION_CODE (decl) = function_code; - - return decl; -} - -/* Print a warning if a constant expression had overflow in folding. - Invoke this function on every expression that the language - requires to be a constant expression. */ - -void -constant_expression_warning (value) - tree value; -{ - if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST - || TREE_CODE (value) == COMPLEX_CST) - && TREE_CONSTANT_OVERFLOW (value) && pedantic) - pedwarn ("overflow in constant expression"); -} - - -/* Finish processing of a declaration; - If the length of an array type is not known before, - it must be determined now, from the initial value, or it is an error. */ - -void -finish_decl (decl) - tree decl; -{ - int was_incomplete = (DECL_SIZE (decl) == 0); - int temporary = allocation_temporary_p (); - - /* Pop back to the obstack that is current for this binding level. - This is because MAXINDEX, rtl, etc. to be made below - must go in the permanent obstack. But don't discard the - temporary data yet. */ - pop_obstacks (); -#if 0 /* pop_obstacks was near the end; this is what was here. */ - if (current_scope == global_scope && temporary) - end_temporary_allocation (); -#endif - - if (TREE_CODE (decl) == VAR_DECL) - { - if (DECL_SIZE (decl) == 0 - && TYPE_SIZE (TREE_TYPE (decl)) != 0) - layout_decl (decl, 0); - - if (DECL_SIZE (decl) == 0 && TREE_CODE (TREE_TYPE (decl)) != ERROR_MARK) - { - error_with_decl (decl, "storage size of `%s' isn't known"); - TREE_TYPE (decl) = error_mark_node; - } - - if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) - && DECL_SIZE (decl) != 0) - { - if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST) - constant_expression_warning (DECL_SIZE (decl)); - } - } - - /* Output the assembler code and/or RTL code for variables and functions, - unless the type is an undefined structure or union. - If not, it will get done when the type is completed. */ - - if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) - { - /* The last argument (at_end) is set to 1 as a kludge to force - assemble_variable to be called. */ - if (TREE_CODE (TREE_TYPE (decl)) != ERROR_MARK) - rest_of_decl_compilation (decl, (char*) 0, global_bindings_p (), 1); - - /* Compute the RTL of a decl if not yet set. - (For normal user variables, satisfy_decl sets it.) */ - if (! TREE_STATIC (decl) && ! DECL_EXTERNAL (decl)) - { - if (was_incomplete) - { - /* If we used it already as memory, it must stay in memory. */ - TREE_ADDRESSABLE (decl) = TREE_USED (decl); - /* If it's still incomplete now, no init will save it. */ - if (DECL_SIZE (decl) == 0) - DECL_INITIAL (decl) = 0; - expand_decl (decl); - } - } - } - - if (TREE_CODE (decl) == TYPE_DECL) - { - rest_of_decl_compilation (decl, NULL_PTR, - global_bindings_p (), 0); - } - - /* ??? After 2.3, test (init != 0) instead of TREE_CODE. */ - if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl)) - && temporary && TREE_PERMANENT (decl)) - { - /* We need to remember that this array HAD an initialization, - but discard the actual temporary nodes, - since we can't have a permanent node keep pointing to them. */ - /* We make an exception for inline functions, since it's - normal for a local extern redeclaration of an inline function - to have a copy of the top-level decl's DECL_INLINE. */ - if (DECL_INITIAL (decl) != 0) - DECL_INITIAL (decl) = error_mark_node; - } - -#if 0 - /* Resume permanent allocation, if not within a function. */ - /* The corresponding push_obstacks_nochange is in start_decl, - and in push_parm_decl and in grokfield. */ - pop_obstacks (); -#endif - - /* If we have gone back from temporary to permanent allocation, - actually free the temporary space that we no longer need. */ - if (temporary && !allocation_temporary_p ()) - permanent_allocation (0); - - /* At the end of a declaration, throw away any variable type sizes - of types defined inside that declaration. There is no use - computing them in the following function definition. */ - if (current_scope == global_scope) - get_pending_sizes (); -} - -/* If DECL has a cleanup, build and return that cleanup here. - This is a callback called by expand_expr. */ - -tree -maybe_build_cleanup (decl) - tree decl ATTRIBUTE_UNUSED; -{ - /* There are no cleanups in C. */ - return NULL_TREE; -} - -/* Make TYPE a complete type based on INITIAL_VALUE. - Return 0 if successful, 1 if INITIAL_VALUE can't be deciphered, - 2 if there was no information (in which case assume 1 if DO_DEFAULT). */ - -int -complete_array_type (type, initial_value, do_default) - tree type ATTRIBUTE_UNUSED, initial_value ATTRIBUTE_UNUSED; - int do_default ATTRIBUTE_UNUSED; -{ - /* Only needed so we can link with ../c-typeck.c. */ - abort (); -} - -/* Make sure that the tag NAME is defined *in the current binding level* - at least as a forward reference. - CODE says which kind of tag NAME ought to be. - - We also do a push_obstacks_nochange - whose matching pop is in finish_struct. */ - -tree -start_struct (code, name) - enum chill_tree_code code; - tree name ATTRIBUTE_UNUSED; -{ - /* If there is already a tag defined at this binding level - (as a forward reference), just return it. */ - - register tree ref = 0; - - push_obstacks_nochange (); - if (current_scope == global_scope) - end_temporary_allocation (); - - /* Otherwise create a forward-reference just so the tag is in scope. */ - - ref = make_node (code); -/* pushtag (name, ref); */ - return ref; -} - -#if 0 -/* Function to help qsort sort FIELD_DECLs by name order. */ - -static int -field_decl_cmp (x, y) - tree *x, *y; -{ - return (long)DECL_NAME (*x) - (long)DECL_NAME (*y); -} -#endif -/* Fill in the fields of a RECORD_TYPE or UNION_TYPE node, T. - FIELDLIST is a chain of FIELD_DECL nodes for the fields. - - We also do a pop_obstacks to match the push in start_struct. */ - -tree -finish_struct (t, fieldlist) - register tree t, fieldlist; -{ - register tree x; - - /* Install struct as DECL_CONTEXT of each field decl. */ - for (x = fieldlist; x; x = TREE_CHAIN (x)) - DECL_CONTEXT (x) = t; - - TYPE_FIELDS (t) = fieldlist; - - if (pass != 1) - t = layout_chill_struct_type (t); - - /* The matching push is in start_struct. */ - pop_obstacks (); - - return t; -} - -/* Lay out the type T, and its element type, and so on. */ - -static void -layout_array_type (t) - tree t; -{ - if (TYPE_SIZE (t) != 0) - return; - if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE) - layout_array_type (TREE_TYPE (t)); - layout_type (t); -} - -/* Begin compiling the definition of an enumeration type. - NAME is its name (or null if anonymous). - Returns the type object, as yet incomplete. - Also records info about it so that build_enumerator - may be used to declare the individual values as they are read. */ - -tree -start_enum (name) - tree name ATTRIBUTE_UNUSED; -{ - register tree enumtype; - - /* If this is the real definition for a previous forward reference, - fill in the contents in the same object that used to be the - forward reference. */ - -#if 0 - /* The corresponding pop_obstacks is in finish_enum. */ - push_obstacks_nochange (); - /* If these symbols and types are global, make them permanent. */ - if (current_scope == global_scope) - end_temporary_allocation (); -#endif - - enumtype = make_node (ENUMERAL_TYPE); -/* pushtag (name, enumtype); */ - return enumtype; -} - -/* Determine the precision this type needs. */ -unsigned -get_type_precision (minnode, maxnode) - tree minnode, maxnode; -{ - unsigned precision = 0; - - if (TREE_INT_CST_HIGH (minnode) >= 0 - ? tree_int_cst_lt (TYPE_MAX_VALUE (unsigned_type_node), maxnode) - : (tree_int_cst_lt (minnode, TYPE_MIN_VALUE (integer_type_node)) - || tree_int_cst_lt (TYPE_MAX_VALUE (integer_type_node), maxnode))) - precision = TYPE_PRECISION (long_long_integer_type_node); - else - { - HOST_WIDE_INT maxvalue = TREE_INT_CST_LOW (maxnode); - HOST_WIDE_INT minvalue = TREE_INT_CST_LOW (minnode); - - if (maxvalue > 0) - precision = floor_log2 (maxvalue) + 1; - if (minvalue < 0) - { - /* Compute number of bits to represent magnitude of a negative value. - Add one to MINVALUE since range of negative numbers - includes the power of two. */ - unsigned negprecision = floor_log2 (-minvalue - 1) + 1; - if (negprecision > precision) - precision = negprecision; - precision += 1; /* room for sign bit */ - } - - if (!precision) - precision = 1; - } - return precision; -} - -void -layout_enum (enumtype) - tree enumtype; -{ - register tree pair, tem; - tree minnode = 0, maxnode = 0; - unsigned precision = 0; - - /* Do arithmetic using double integers, but don't use fold/build. */ - union tree_node enum_next_node; - /* This is 1 plus the last enumerator constant value. */ - tree enum_next_value = &enum_next_node; - - /* Nonzero means that there was overflow computing enum_next_value. */ - int enum_overflow = 0; - - tree values = TYPE_VALUES (enumtype); - - if (TYPE_SIZE (enumtype) != NULL_TREE) - return; - - /* Initialize enum_next_value to zero. */ - TREE_TYPE (enum_next_value) = integer_type_node; - TREE_INT_CST_LOW (enum_next_value) = TREE_INT_CST_LOW (integer_zero_node); - TREE_INT_CST_HIGH (enum_next_value) = TREE_INT_CST_HIGH (integer_zero_node); - - /* After processing and defining all the values of an enumeration type, - install their decls in the enumeration type and finish it off. - - TYPE_VALUES currently contains a list of (purpose: NAME, value: DECL). - This gets converted to a list of (purpose: NAME, value: VALUE). */ - - - /* For each enumerator, calculate values, if defaulted. - Convert to correct type (the enumtype). - Also, calculate the minimum and maximum values. */ - - for (pair = values; pair; pair = TREE_CHAIN (pair)) - { - tree decl = TREE_VALUE (pair); - tree value = DECL_INITIAL (decl); - - /* Remove no-op casts from the value. */ - if (value != NULL_TREE) - STRIP_TYPE_NOPS (value); - - if (value != NULL_TREE) - { - if (TREE_CODE (value) == INTEGER_CST) - { - constant_expression_warning (value); - if (tree_int_cst_lt (value, integer_zero_node)) - { - error ("enumerator value for `%s' is less then 0", - IDENTIFIER_POINTER (DECL_NAME (decl))); - value = error_mark_node; - } - } - else - { - error ("enumerator value for `%s' not integer constant", - IDENTIFIER_POINTER (DECL_NAME (decl))); - value = error_mark_node; - } - } - - if (value != error_mark_node) - { - if (value == NULL_TREE) /* Default based on previous value. */ - { - value = enum_next_value; - if (enum_overflow) - error ("overflow in enumeration values"); - } - value = build_int_2 (TREE_INT_CST_LOW (value), - TREE_INT_CST_HIGH (value)); - TREE_TYPE (value) = enumtype; - DECL_INITIAL (decl) = value; - CH_DERIVED_FLAG (value) = 1; - - if (pair == values) - minnode = maxnode = value; - else - { - if (tree_int_cst_lt (maxnode, value)) - maxnode = value; - if (tree_int_cst_lt (value, minnode)) - minnode = value; - } - - /* Set basis for default for next value. */ - add_double (TREE_INT_CST_LOW (value), TREE_INT_CST_HIGH (value), 1, 0, - &TREE_INT_CST_LOW (enum_next_value), - &TREE_INT_CST_HIGH (enum_next_value)); - enum_overflow = tree_int_cst_lt (enum_next_value, value); - } - else - DECL_INITIAL (decl) = value; /* error_mark_node */ - } - - /* Fix all error_mark_nodes in enum. Increment maxnode and assign value. - This is neccessary to make a duplicate value check in the enum */ - for (pair = values; pair; pair = TREE_CHAIN (pair)) - { - tree decl = TREE_VALUE (pair); - if (DECL_INITIAL (decl) == error_mark_node) - { - tree value; - add_double (TREE_INT_CST_LOW (maxnode), TREE_INT_CST_HIGH (maxnode), 1, 0, - &TREE_INT_CST_LOW (enum_next_value), - &TREE_INT_CST_HIGH (enum_next_value)); - value = build_int_2 (TREE_INT_CST_LOW (enum_next_value), - TREE_INT_CST_HIGH (enum_next_value)); - TREE_TYPE (value) = enumtype; - CH_DERIVED_FLAG (value) = 1; - DECL_INITIAL (decl) = value; - - maxnode = value; - } - } - - /* Now check if we have duplicate values within the enum */ - for (pair = values; pair; pair = TREE_CHAIN (pair)) - { - tree succ; - tree decl1 = TREE_VALUE (pair); - tree val1 = DECL_INITIAL (decl1); - - for (succ = TREE_CHAIN (pair); succ; succ = TREE_CHAIN (succ)) - { - if (pair != succ) - { - tree decl2 = TREE_VALUE (succ); - tree val2 = DECL_INITIAL (decl2); - if (tree_int_cst_equal (val1, val2)) - error ("enumerators `%s' and `%s' have equal values", - IDENTIFIER_POINTER (DECL_NAME (decl1)), - IDENTIFIER_POINTER (DECL_NAME (decl2))); - } - } - } - - TYPE_MIN_VALUE (enumtype) = minnode; - TYPE_MAX_VALUE (enumtype) = maxnode; - - precision = get_type_precision (minnode, maxnode); - - if (flag_short_enums || precision > TYPE_PRECISION (integer_type_node)) - /* Use the width of the narrowest normal C type which is wide enough. */ - TYPE_PRECISION (enumtype) = TYPE_PRECISION (type_for_size (precision, 1)); - else - TYPE_PRECISION (enumtype) = TYPE_PRECISION (integer_type_node); - - layout_type (enumtype); - -#if 0 - /* An enum can have some negative values; then it is signed. */ - TREE_UNSIGNED (enumtype) = ! tree_int_cst_lt (minnode, integer_zero_node); -#else - /* Z200/1988 page 19 says: - For each pair of integer literal expression e1, e2 in the set list NUM (e1) - and NUM (e2) must deliver different non-negative results */ - TREE_UNSIGNED (enumtype) = 1; -#endif - - for (pair = values; pair; pair = TREE_CHAIN (pair)) - { - tree decl = TREE_VALUE (pair); - - DECL_SIZE (decl) = TYPE_SIZE (enumtype); - DECL_SIZE_UNIT (decl) = TYPE_SIZE_UNIT (enumtype); - DECL_ALIGN (decl) = TYPE_ALIGN (enumtype); - DECL_USER_ALIGN (decl) = TYPE_USER_ALIGN (enumtype); - - /* Set the TREE_VALUE to the name, rather than the decl, - since that is what the rest of the compiler expects. */ - TREE_VALUE (pair) = DECL_INITIAL (decl); - } - - /* Fix up all variant types of this enum type. */ - for (tem = TYPE_MAIN_VARIANT (enumtype); tem; tem = TYPE_NEXT_VARIANT (tem)) - { - TYPE_VALUES (tem) = TYPE_VALUES (enumtype); - TYPE_MIN_VALUE (tem) = TYPE_MIN_VALUE (enumtype); - TYPE_MAX_VALUE (tem) = TYPE_MAX_VALUE (enumtype); - TYPE_SIZE (tem) = TYPE_SIZE (enumtype); - TYPE_MODE (tem) = TYPE_MODE (enumtype); - TYPE_PRECISION (tem) = TYPE_PRECISION (enumtype); - TYPE_ALIGN (tem) = TYPE_ALIGN (enumtype); - TYPE_USER_ALIGN (tem) = TYPE_USER_ALIGN (enumtype); - TREE_UNSIGNED (tem) = TREE_UNSIGNED (enumtype); - } - -#if 0 - /* This matches a push in start_enum. */ - pop_obstacks (); -#endif -} - -tree -finish_enum (enumtype, values) - register tree enumtype, values; -{ - TYPE_VALUES (enumtype) = values = nreverse (values); - - /* If satisfy_decl is called on one of the enum CONST_DECLs, - this will make sure that the enumtype gets laid out then. */ - for ( ; values; values = TREE_CHAIN (values)) - TREE_TYPE (TREE_VALUE (values)) = enumtype; - - return enumtype; -} - - -/* Build and install a CONST_DECL for one value of the - current enumeration type (one that was begun with start_enum). - Return a tree-list containing the CONST_DECL and its value. - Assignment of sequential values by default is handled here. */ - -tree -build_enumerator (name, value) - tree name, value; -{ - register tree decl; - int named = name != NULL_TREE; - - if (pass == 2) - { - if (name) - (void) get_next_decl (); - return NULL_TREE; - } - - if (name == NULL_TREE) - { - static int unnamed_value_warned = 0; - static int next_dummy_enum_value = 0; - char buf[20]; - if (!unnamed_value_warned) - { - unnamed_value_warned = 1; - warning ("undefined value in SET mode is obsolete and deprecated."); - } - sprintf (buf, "__star_%d", next_dummy_enum_value++); - name = get_identifier (buf); - } - - decl = build_decl (CONST_DECL, name, integer_type_node); - CH_DECL_ENUM (decl) = 1; - DECL_INITIAL (decl) = value; - if (named) - { - if (pass == 0) - { - push_obstacks_nochange (); - pushdecl (decl); - finish_decl (decl); - } - else - save_decl (decl); - } - return build_tree_list (name, decl); - -#if 0 - tree old_value = lookup_name_current_level (name); - - if (old_value != NULL_TREE - && TREE_CODE (old_value)=!= CONST_DECL - && (value == NULL_TREE || operand_equal_p (value, old_value, 1))) - { - if (value == NULL_TREE) - { - if (TREE_CODE (old_value) == CONST_DECL) - value = DECL_INITIAL (old_value); - else - abort (); - } - return saveable_tree_cons (old_value, value, NULL_TREE); - } -#endif -} - -/* Record that this function is going to be a varargs function. - This is called before store_parm_decls, which is too early - to call mark_varargs directly. */ - -void -c_mark_varargs () -{ - c_function_varargs = 1; -} - -/* Function needed for CHILL interface. */ -tree -get_parm_decls () -{ - return current_function_parms; -} - -/* Save and restore the variables in this file and elsewhere - that keep track of the progress of compilation of the current function. - Used for nested functions. */ - -struct c_function -{ - struct c_function *next; - struct scope *scope; - tree chill_result_decl; - int result_never_set; -}; - -struct c_function *c_function_chain; - -/* Save and reinitialize the variables - used during compilation of a C function. */ - -void -push_chill_function_context () -{ - struct c_function *p - = (struct c_function *) xmalloc (sizeof (struct c_function)); - - push_function_context (); - - p->next = c_function_chain; - c_function_chain = p; - - p->scope = current_scope; - p->chill_result_decl = chill_result_decl; - p->result_never_set = result_never_set; -} - -/* Restore the variables used during compilation of a C function. */ - -void -pop_chill_function_context () -{ - struct c_function *p = c_function_chain; -#if 0 - tree link; - /* Bring back all the labels that were shadowed. */ - for (link = shadowed_labels; link; link = TREE_CHAIN (link)) - if (DECL_NAME (TREE_VALUE (link)) != 0) - IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link))) - = TREE_VALUE (link); -#endif - - pop_function_context (); - - c_function_chain = p->next; - - current_scope = p->scope; - chill_result_decl = p->chill_result_decl; - result_never_set = p->result_never_set; - - free (p); -} - -/* Following from Jukka Virtanen's GNU Pascal */ -/* To implement WITH statement: - - 1) Call shadow_record_fields for each record_type element in the WITH - element list. Each call creates a new binding level. - - 2) construct a component_ref for EACH field in the record, - and store it to the IDENTIFIER_LOCAL_VALUE after adding - the old value to the shadow list - - 3) let lookup_name do the rest - - 4) pop all of the binding levels after the WITH statement ends. - (restoring old local values) You have to keep track of the number - of times you called it. -*/ - -/* - * Save an arbitrary tree-expression as the IDENTIFIER_LOCAL_VALUE - * of a name. Save the name's previous value. Check for name - * collisions with another value under the same name at the same - * nesting level. This is used to implement the DO WITH construct - * and the temporary for the location iteration loop. - */ -void -save_expr_under_name (name, expr) - tree name, expr; -{ - tree alias = build_alias_decl (NULL_TREE, NULL_TREE, name); - - DECL_ABSTRACT_ORIGIN (alias) = expr; - TREE_CHAIN (alias) = NULL_TREE; - pushdecllist (alias, 0); -} - -static void -do_based_decl (name, mode, base_var) - tree name, mode, base_var; -{ - tree decl; - if (pass == 1) - { - push_obstacks (&permanent_obstack, &permanent_obstack); - decl = make_node (BASED_DECL); - DECL_NAME (decl) = name; - TREE_TYPE (decl) = mode; - DECL_ABSTRACT_ORIGIN (decl) = base_var; - save_decl (decl); - pop_obstacks (); - } - else - { - tree base_decl; - decl = get_next_decl (); - if (name != DECL_NAME (decl)) - abort(); - /* FIXME: This isn't a complete test */ - base_decl = lookup_name (base_var); - if (base_decl == NULL_TREE) - error ("BASE variable never declared"); - else if (TREE_CODE (base_decl) == FUNCTION_DECL) - error ("cannot BASE a variable on a PROC/PROCESS name"); - } -} - -void -do_based_decls (names, mode, base_var) - tree names, mode, base_var; -{ - if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST) - { - for (; names != NULL_TREE; names = TREE_CHAIN (names)) - do_based_decl (names, mode, base_var); - } - else if (TREE_CODE (names) != ERROR_MARK) - do_based_decl (names, mode, base_var); -} - -/* - * Declare the fields so that lookup_name() will find them as - * component refs for Pascal WITH or CHILL DO WITH. - * - * Proceeds to the inner layers of Pascal/CHILL variant record - * - * Internal routine of shadow_record_fields () - */ -static void -handle_one_level (parent, fields) - tree parent, fields; -{ - tree field, name; - - switch (TREE_CODE (TREE_TYPE (parent))) - { - case RECORD_TYPE: - case UNION_TYPE: - for (field = fields; field; field = TREE_CHAIN (field)) { - name = DECL_NAME (field); - if (name == NULL_TREE || name == ELSE_VARIANT_NAME) - /* proceed through variant part */ - handle_one_level (parent, TYPE_FIELDS (TREE_TYPE (field))); - else - { - tree field_alias = make_node (WITH_DECL); - DECL_NAME (field_alias) = name; - TREE_TYPE (field_alias) = TREE_TYPE (field); - DECL_ABSTRACT_ORIGIN (field_alias) = parent; - TREE_CHAIN (field_alias) = NULL_TREE; - pushdecllist (field_alias, 0); - } - } - break; - default: - error ("INTERNAL ERROR: handle_one_level is broken"); - } -} - -/* - * For each FIELD_DECL node in a RECORD_TYPE, we have to declare - * a name so that lookup_name will find a COMPONENT_REF node - * when the name is referenced. This happens in Pascal WITH statement. - */ -void -shadow_record_fields (struct_val) - tree struct_val; -{ - if (pass == 1 || struct_val == NULL_TREE) - return; - - handle_one_level (struct_val, TYPE_FIELDS (TREE_TYPE (struct_val))); -} - -static char exception_prefix [] = "__Ex_"; - -tree -build_chill_exception_decl (name) - const char *name; -{ - tree decl, ex_name, ex_init, ex_type; - int name_len = strlen (name); - char *ex_string = (char *) - alloca (strlen (exception_prefix) + name_len + 1); - - sprintf(ex_string, "%s%s", exception_prefix, name); - ex_name = get_identifier (ex_string); - decl = IDENTIFIER_LOCAL_VALUE (ex_name); - if (decl) - return decl; - - /* finish_decl is too eager about switching back to the - ambient context. This decl's rtl must live in the permanent_obstack. */ - push_obstacks (&permanent_obstack, &permanent_obstack); - push_obstacks_nochange (); - ex_type = build_array_type (char_type_node, - build_index_2_type (integer_zero_node, - build_int_2 (name_len, 0))); - decl = build_lang_decl (VAR_DECL, ex_name, ex_type); - ex_init = build_string (name_len, name); - TREE_TYPE (ex_init) = ex_type; - DECL_INITIAL (decl) = ex_init; - TREE_READONLY (decl) = 1; - TREE_STATIC (decl) = 1; - pushdecl_top_level (decl); - finish_decl (decl); - pop_obstacks (); /* Return to the ambient context. */ - return decl; -} - -extern tree module_init_list; - -/* - * This function is called from the parser to preface the entire - * compilation. It contains module-level actions and reach-bound - * initialization. - */ -void -start_outer_function () -{ - start_chill_function (pass < 2 ? get_identifier ("_GLOBAL_") - : DECL_NAME (global_function_decl), - void_type_node, NULL_TREE, NULL_TREE, NULL_TREE); - global_function_decl = current_function_decl; - global_scope = current_scope; - chill_at_module_level = 1; -} - -/* This function finishes the global_function_decl, and if it is non-empty - * (as indiacted by seen_action), adds it to module_init_list. - */ -void -finish_outer_function () -{ - /* If there was module-level code in this module (not just function - declarations), we allocate space for this module's init list entry, - and fill in the module's function's address. */ - - extern tree initializer_type; - const char *fname_str = IDENTIFIER_POINTER (DECL_NAME (current_function_decl)); - char *init_entry_name = (char *)xmalloc ((unsigned)(strlen (fname_str) + 20)); - tree init_entry_id; - tree init_entry_decl; - tree initializer; - - finish_chill_function (); - - chill_at_module_level = 0; - - - if (!seen_action) - return; - - sprintf (init_entry_name, "__tmp_%s_init_entry", fname_str); - init_entry_id = get_identifier (init_entry_name); - - init_entry_decl = build1 (ADDR_EXPR, - TREE_TYPE (TYPE_FIELDS (initializer_type)), - global_function_decl); - TREE_CONSTANT (init_entry_decl) = 1; - initializer = build (CONSTRUCTOR, initializer_type, NULL_TREE, - tree_cons (NULL_TREE, init_entry_decl, - build_tree_list (NULL_TREE, - null_pointer_node))); - TREE_CONSTANT (initializer) = 1; - init_entry_decl - = do_decl (init_entry_id, initializer_type, 1, 1, initializer, 0); - DECL_SOURCE_LINE (init_entry_decl) = 0; - if (pass == 1) - /* tell chill_finish_compile that there's - module-level code to be processed. */ - module_init_list = integer_one_node; - else if (build_constructor) - module_init_list = tree_cons (global_function_decl, - init_entry_decl, - module_init_list); - - make_decl_rtl (global_function_decl, NULL, 0); -} diff --git a/gcc/ch/except.c b/gcc/ch/except.c deleted file mode 100644 index b32dba60636..00000000000 --- a/gcc/ch/except.c +++ /dev/null @@ -1,707 +0,0 @@ -/* Exception support for GNU CHILL. - WARNING: Only works for native (needs setjmp.h)! FIXME! - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" - -/* On Suns this can get you to the right definition if you - set the right value for TARGET. */ -#include <setjmp.h> -#ifdef sequent -/* Can you believe they forgot this? */ -#ifndef _JBLEN -#define _JBLEN 11 -#endif -#endif - -#ifndef _JBLEN -#define _JBLEN (sizeof(jmp_buf)/sizeof(int)) -#define _JBLEN_2 _JBLEN+20 -#else -/* if we use i.e. posix threads, this buffer must be longer */ -#define _JBLEN_2 _JBLEN+20 -#endif - -/* On Linux setjmp is __setjmp FIXME: what is for CROSS */ -#ifndef SETJMP_LIBRARY_NAME -#ifdef __linux__ -#define SETJMP_LIBRARY_NAME "__setjmp" -#else -#define SETJMP_LIBRARY_NAME "setjmp" -#endif -#endif - -#include "tree.h" -#include "ch-tree.h" -#include "rtl.h" -#include "toplev.h" - -extern int expand_exit_needed; - -static tree link_handler_decl; -static tree handler_link_pointer_type; -static tree unlink_handler_decl; -static int exceptions_initialized = 0; -static void emit_setup_handler PARAMS ((void)); -static void initialize_exceptions PARAMS ((void)); -static tree start_handler_array PARAMS ((void)); -static void finish_handler_array PARAMS ((void)); -static tree char_pointer_type_for_handler; - -/* If this is 1, operations to push and pop on the __exceptionStack - are inline. The default is is to use a function call, to - allow for a per-thread exception stack. */ -static int inline_exception_stack_ops = 0; - -struct handler_state -{ - struct handler_state *next; - - /* Starts at 0, then incremented for every <on-alternative>. */ - int prev_on_alternative; - - /* If > 0: handler number for ELSE handler. */ - int else_handler; - - int action_number; - - char do_pushlevel; - - tree on_alt_list; - tree setjmp_expr; - - /* A decl for the static handler array (used to map exception name to int).*/ - tree handler_array_decl; - - rtx end_label; - - /* Used to pass a tree from emit_setup_handler to chill_start_on. */ - tree handler_ref; - - tree unlink_cleanup; - - tree function; - - /* flag to indicate that we are currently compiling this handler. - is_handled will need this to determine an unhandled exception */ - int compiling; -}; - -/* This is incremented by one each time we start an action which - might have an ON-handler. It is reset between passes. */ -static int action_number = 0; - -int action_nesting_level = 0; - -/* The global_handler_list is constructed in pass 1. It is not sorted. - It contains one element for each action that actually had an ON-handler. - An element's ACTION_NUMBER matches the action_number - of that action. The global_handler_list is eaten up during pass 2. */ -#define ACTION_NUMBER(HANDLER) ((HANDLER)->action_number) -struct handler_state *global_handler_list = NULL; - -/* This is a stack of handlers, one for each nested ON-handler. */ -static struct handler_state *current_handler = NULL; - -static struct handler_state *free_handlers = NULL; /* freelist */ - -static tree handler_element_type; -static tree handler_link_type; -static tree BISJ; -static tree jbuf_ident, prev_ident, handlers_ident; -static tree exception_stack_decl = 0; - -/* Chain of cleanups assocated with exception handlers. - The TREE_PURPOSE is an INTEGER_CST whose value is the - DECL_ACTION_NESTING_LEVEL (when the handled actions was entered). - The TREE_VALUE is an expression to expand when we exit that action. */ - -static tree cleanup_chain = NULL_TREE; - -#if 0 -/* Merge the current sequence onto the tail of the previous one. */ - -void -pop_sequence () -{ - rtx sequence_first = get_insns (); - - end_sequence (); - emit_insns (sequence_first); - -} -#endif - -/* Things we need to do at the beginning of pass 2. */ - -void -except_init_pass_2 () -{ - /* First sort the global_handler_list on ACTION_NUMBER. - This will already be in close to reverse order (the exception being - nested ON-handlers), so insertion sort should essentially linear. */ - - register struct handler_state *old_list = global_handler_list; - - /* First add a dummy final element. */ - if (free_handlers) - global_handler_list = free_handlers; - else - global_handler_list - = (struct handler_state*) permalloc (sizeof (struct handler_state)); - /* Make the final dummy "larger" than any other element. */ - ACTION_NUMBER (global_handler_list) = action_number + 1; - /* Now move all the elements in old_list over to global_handler_list. */ - while (old_list != NULL) - { - register struct handler_state **ptr = &global_handler_list; - /* Unlink from old_list. */ - register struct handler_state *current = old_list; - old_list = old_list->next; - - while (ACTION_NUMBER (current) > ACTION_NUMBER (*ptr)) - ptr = &(*ptr)->next; - /* Link into proper place in global_handler_list (new list). */ - current->next = *ptr; - *ptr = current; - } - - /* Don't forget to reset action_number. */ - action_number = 0; -} - -/* This function is called at the beginning of an action that might be - followed by an ON-handler. Chill syntax doesn't let us know if - we actually have an ON-handler until we see the ON, so we save - away during pass 1 that information for use during pass 2. */ - -void -push_handler () -{ - register struct handler_state *hstate; - - action_number++; - action_nesting_level++; - - if (pass == 1) - { - if (free_handlers) - { - hstate = free_handlers; - free_handlers = hstate->next; - } - else - { - hstate = - (struct handler_state*) permalloc (sizeof (struct handler_state)); - } - - hstate->next = current_handler; - current_handler = hstate; - hstate->prev_on_alternative = 0; - hstate->else_handler = 0; - hstate->on_alt_list = NULL_TREE; - hstate->compiling = 0; - - ACTION_NUMBER (hstate) = action_number; - return; - } - - if (ACTION_NUMBER (global_handler_list) != action_number) - return; - - /* OK. This action actually has an ON-handler. - Pop it from global_handler_list, and use it. */ - - hstate = global_handler_list; - global_handler_list = hstate->next; - - /* Since this is pass 2, let's generate prologue code for that. */ - - hstate->next = current_handler; - current_handler = hstate; - - hstate->prev_on_alternative = 0; - hstate->function = current_function_decl; - - emit_setup_handler (); -} - -static tree -start_handler_array () -{ - tree handler_array_type, decl; - - push_obstacks_nochange (); - end_temporary_allocation (); - handler_array_type = build_array_type (handler_element_type, NULL_TREE); - decl = build_lang_decl (VAR_DECL, - get_unique_identifier ("handler_table"), - handler_array_type); - -/* TREE_TYPE (decl) = handler_array_type;*/ - TREE_READONLY (decl) = 1; - TREE_STATIC (decl) = 1; - DECL_INITIAL (decl) = error_mark_node; - - pushdecl (decl); - make_decl_rtl (decl, NULL_PTR, 0); - current_handler->handler_array_decl = decl; - return decl; -} - -static void -finish_handler_array () -{ - tree decl = current_handler->handler_array_decl; - tree t; - tree handler_array_init = NULL_TREE; - int handlers_count = 1; - int nelts; - - /* Build the table mapping exceptions to handler(-number)s. - This is done in reverse order. */ - - /* First push the end of the list. This is either the ELSE - handler (current_handler->else_handler>0) or NULL handler to indicate - the end of the list (if current_handler->else-handler == 0). - The following works either way. */ - handler_array_init = build_tree_list - (NULL_TREE, chill_expand_tuple - (handler_element_type, - build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, - null_pointer_node, - build_tree_list (NULL_TREE, - build_int_2 (current_handler->else_handler, - 0)))))); - - for (t = current_handler->on_alt_list; t != NULL_TREE; t = TREE_CHAIN (t)) - { tree handler_number = TREE_PURPOSE(t); - tree elist = TREE_VALUE (t); - for ( ; elist != NULL_TREE; elist = TREE_CHAIN (elist)) - { - tree ex_decl = - build_chill_exception_decl (IDENTIFIER_POINTER(TREE_VALUE(elist))); - tree ex_addr = build1 (ADDR_EXPR, - char_pointer_type_for_handler, - ex_decl); - tree el = build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, - ex_addr, - build_tree_list (NULL_TREE, - handler_number))); - mark_addressable (ex_decl); - TREE_CONSTANT (ex_addr) = 1; - handler_array_init = - tree_cons (NULL_TREE, - chill_expand_tuple (handler_element_type, el), - handler_array_init); - handlers_count++; - } - } - -#if 1 - nelts = list_length (handler_array_init); - TYPE_DOMAIN (TREE_TYPE (decl)) - = build_index_type (build_int_2 (nelts - 1, - (nelts == 0))); - layout_type (TREE_TYPE (decl)); - DECL_INITIAL (decl) - = convert (TREE_TYPE (decl), - build_nt (CONSTRUCTOR, NULL_TREE, handler_array_init)); - - /* Pop back to the obstack that is current for this binding level. - This is because MAXINDEX, rtl, etc. to be made below - must go in the permanent obstack. But don't discard the - temporary data yet. */ - pop_obstacks (); - layout_decl (decl, 0); - /* To prevent make_decl_rtl (called indiectly by rest_of_decl_compilation) - throwing the existing RTL (which has already been used). */ - PUT_MODE (DECL_RTL (decl), DECL_MODE (decl)); - rest_of_decl_compilation (decl, (char*)0, 0, 0); - expand_decl_init (decl); -#else - /* To prevent make_decl_rtl (called indirectly by finish_decl) - altering the existing RTL. */ - GET_MODE (DECL_RTL (current_handler->handler_array_decl)) = - DECL_MODE (current_handler->handler_array_decl); - - finish_decl (current_handler->handler_array_decl, - build_nt (CONSTRUCTOR, NULL_TREE, handler_array_init), - NULL_TREE); -#endif -} - - -void -pop_handler (used) - int used; -{ - action_nesting_level--; - if (pass == 1) - { - struct handler_state *old = current_handler; - - if (old == NULL) - abort (); - current_handler = old->next; - - if (used) - { /* Push unto global_handler_list. */ - old->next = global_handler_list; - global_handler_list = old; - } - else - { - /* Push onto free_handlers free list. */ - old->next = free_handlers; - free_handlers = old; - } - } - else if (used) - { - current_handler = current_handler->next; - } -} - -/* Emit code before an action that has an ON-handler. */ - -static void -emit_setup_handler () -{ - tree handler_decl, handler_addr, t; - - /* Field references. */ - tree jbuf_ref, handlers_ref,prev_ref; - if (!exceptions_initialized) - { - /* We temporarily reset the maximum_field_alignment to zero so the - compiler's exception data structures can be compatible with the - run-time system, even when we're compiling with -fpack. */ - unsigned int save_maximum_field_alignment = maximum_field_alignment; - maximum_field_alignment = 0; - push_obstacks_nochange (); - end_temporary_allocation (); - initialize_exceptions (); - pop_obstacks (); - maximum_field_alignment = save_maximum_field_alignment; - } - - push_momentary (); - - handler_decl = build_lang_decl (VAR_DECL, - get_unique_identifier ("handler"), - handler_link_type); - push_obstacks_nochange (); - pushdecl(handler_decl); - expand_decl (handler_decl); - finish_decl (handler_decl); - - jbuf_ref = build_component_ref (handler_decl, jbuf_ident); - jbuf_ref = build_chill_arrow_expr (jbuf_ref, 1); - handlers_ref = build_component_ref (handler_decl, handlers_ident); - prev_ref = build_component_ref (handler_decl, prev_ident); - - /* Emit code to link in handler in __exceptionStack chain. */ - mark_addressable (handler_decl); - handler_addr = build1 (ADDR_EXPR, handler_link_pointer_type, handler_decl); - if (inline_exception_stack_ops) - { - expand_expr_stmt (build_chill_modify_expr (prev_ref, - exception_stack_decl)); - expand_expr_stmt (build_chill_modify_expr (exception_stack_decl, - handler_addr)); - current_handler->handler_ref = prev_ref; - } - else - { - expand_expr_stmt (build_chill_function_call (link_handler_decl, - build_tree_list (NULL_TREE, - handler_addr))); - current_handler->handler_ref = handler_addr; - } - - /* Expand: handler->__handlers = { <<array mapping names to ints } */ - t = build1 (NOP_EXPR, build_pointer_type (handler_element_type), - build_chill_arrow_expr (start_handler_array (), 1)); - expand_expr_stmt (build_chill_modify_expr (handlers_ref, t)); - - /* Emit code to unlink handler. */ - if (inline_exception_stack_ops) - current_handler->unlink_cleanup - = build_chill_modify_expr (exception_stack_decl, - current_handler->handler_ref); - else - current_handler->unlink_cleanup - = build_chill_function_call (unlink_handler_decl, - build_tree_list(NULL_TREE, - current_handler->handler_ref)); - cleanup_chain = tree_cons (build_int_2 (action_nesting_level, 0), - current_handler->unlink_cleanup, - cleanup_chain); - - /* Emit code for setjmp. */ - - current_handler->setjmp_expr = - build_chill_function_call (BISJ, build_tree_list (NULL_TREE, jbuf_ref)); - expand_start_case (1, current_handler->setjmp_expr, - integer_type_node, "on handler"); - - chill_handle_case_label (integer_zero_node, current_handler->setjmp_expr); -} - -/* Start emitting code for: <actions> ON <handlers> END. - Assume we've parsed <actions>, and the setup needed for it. */ - -void -chill_start_on () -{ - expand_expr_stmt (current_handler->unlink_cleanup); - - /* Emit code to jump past the handlers. */ - current_handler->end_label = gen_label_rtx (); - current_handler->compiling = 1; - emit_jump (current_handler->end_label); -} - -void -chill_finish_on () -{ - expand_end_case (current_handler->setjmp_expr); - - finish_handler_array (); - - emit_label (current_handler->end_label); - - pop_momentary (); - - cleanup_chain = TREE_CHAIN (cleanup_chain); -} - -void -chill_handle_on_labels (labels) - tree labels; -{ - unsigned int alternative = ++current_handler->prev_on_alternative; - if (pass == 1) - { - tree handler_number = build_int_2 (alternative, 0); - current_handler->on_alt_list = - tree_cons (handler_number, labels, current_handler->on_alt_list); - } - else - { - /* Find handler_number saved in pass 1. */ - tree tmp; - - for (tmp = current_handler->on_alt_list; - compare_tree_int (TREE_PURPOSE (tmp), alternative) != 0; - tmp = TREE_CHAIN (tmp)) - ; - - if (expand_exit_needed) - expand_exit_something (), expand_exit_needed = 0; - chill_handle_case_label (TREE_PURPOSE (tmp), - current_handler->setjmp_expr); - } -} - -void -chill_start_default_handler () -{ - current_handler->else_handler = ++current_handler->prev_on_alternative; - if (!ignoring) - { - chill_handle_case_default (); - } -} - -void -chill_check_no_handlers () -{ - if (current_handler != NULL) - abort (); -} - -static void -initialize_exceptions () -{ - tree jmp_buf_type = build_array_type (integer_type_node, - build_index_type (build_int_2 (_JBLEN_2-1, 0))); - tree setjmp_fndecl, link_ftype; - tree parmtypes - = tree_cons (NULL_TREE, build_pointer_type (jmp_buf_type), void_list_node); - - setjmp_fndecl = builtin_function ("setjmp", - build_function_type (integer_type_node, - parmtypes), - 0, NOT_BUILT_IN, - SETJMP_LIBRARY_NAME); - BISJ = build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (setjmp_fndecl)), - setjmp_fndecl); - - char_pointer_type_for_handler - = build_pointer_type (build_type_variant (char_type_node, 1, 0)); - handler_element_type = - build_chill_struct_type (chainon - (build_decl (FIELD_DECL, - get_identifier("__exceptid"), - char_pointer_type_for_handler), - build_decl (FIELD_DECL, - get_identifier("__handlerno"), - integer_type_node))); - - jbuf_ident = get_identifier("__jbuf"); - prev_ident = get_identifier("__prev"); - handlers_ident = get_identifier("__handlers"); - - handler_link_type = - build_chill_struct_type - (chainon - (build_decl (FIELD_DECL, prev_ident, ptr_type_node), - chainon - (build_decl (FIELD_DECL, handlers_ident, - build_pointer_type (handler_element_type)), - build_decl (FIELD_DECL, jbuf_ident, jmp_buf_type)))); - - handler_link_pointer_type = build_pointer_type (handler_link_type); - - if (inline_exception_stack_ops) - { - exception_stack_decl = - build_lang_decl (VAR_DECL, - get_identifier("__exceptionStack"), - handler_link_pointer_type); - TREE_STATIC (exception_stack_decl) = 1; - TREE_PUBLIC (exception_stack_decl) = 1; - DECL_EXTERNAL (exception_stack_decl) = 1; - push_obstacks_nochange (); - pushdecl(exception_stack_decl); - make_decl_rtl (exception_stack_decl, NULL_PTR, 1); - finish_decl (exception_stack_decl); - } - - link_ftype = build_function_type (void_type_node, - tree_cons (NULL_TREE, - handler_link_pointer_type, - void_list_node)); - link_handler_decl = builtin_function ("__ch_link_handler", link_ftype, - 0, NOT_BUILT_IN, NULL_PTR); - unlink_handler_decl = builtin_function ("__ch_unlink_handler", link_ftype, - 0, NOT_BUILT_IN, NULL_PTR); - - exceptions_initialized = 1; -} - -/* Do the cleanup(s) needed for a GOTO label. - We only need to do the last of the cleanups. */ - -void -expand_goto_except_cleanup (label_level) - int label_level; -{ - tree list = cleanup_chain; - tree last = NULL_TREE; - for ( ; list != NULL_TREE; list = TREE_CHAIN (list)) - { - if (compare_tree_int (TREE_PURPOSE (list), label_level) > 0) - last = list; - else - break; - } - if (last) - expand_expr_stmt (TREE_VALUE (last)); -} - -/* Returns true if there is a valid handler for EXCEPT_NAME - in the current static scope. - 0 ... no handler found - 1 ... local handler available - 2 ... function may propagate this exception -*/ - -int -is_handled (except_name) - tree except_name; -{ - tree t; - struct handler_state *h = current_handler; - - /* if we are are currently compiling this handler - we have to start at the next level */ - if (h && h->compiling) - h = h->next; - while (h != NULL) - { - if (h->function != current_function_decl) - break; - if (h->else_handler > 0) - return 1; - for (t = h->on_alt_list; t != NULL_TREE; t = TREE_CHAIN (t)) - { - if (value_member (except_name, TREE_VALUE (t))) - return 1; - } - h = h->next; - } - - t = TYPE_RAISES_EXCEPTIONS (TREE_TYPE (current_function_decl)); - - if (value_member (except_name, t)) - return 2; - return 0; -} - -/* function generates code to reraise exceptions - for PROC's propagating exceptions. */ - -void -chill_reraise_exceptions (exceptions) - tree exceptions; -{ - tree wrk; - - if (exceptions == NULL_TREE) - return; /* just in case */ - - if (pass == 1) - { - for (wrk = exceptions; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk)) - chill_handle_on_labels (build_tree_list (NULL_TREE, TREE_VALUE (wrk))); - } - else /* pass == 2 */ - { - chill_start_on (); - expand_exit_needed = 0; - - for (wrk = exceptions; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk)) - { - chill_handle_on_labels (TREE_VALUE (wrk)); - /* do a CAUSE exception */ - expand_expr_stmt (build_cause_exception (TREE_VALUE (wrk), 0)); - expand_exit_needed = 1; - } - chill_finish_on (); - } - pop_handler (1); -} diff --git a/gcc/ch/expr.c b/gcc/ch/expr.c deleted file mode 100644 index 59371e820db..00000000000 --- a/gcc/ch/expr.c +++ /dev/null @@ -1,4512 +0,0 @@ -/* Convert language-specific tree expression to rtl instructions, - for GNU CHILL compiler. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -#include "config.h" -#include "system.h" -#include "rtl.h" -#include "tree.h" -#include "flags.h" -#include "expr.h" -#include "ch-tree.h" -#include "assert.h" -#include "lex.h" -#include "convert.h" -#include "toplev.h" - -extern char **boolean_code_name; -extern int flag_old_strings; -extern int ignore_case; -extern int special_UC; - -/* definitions for duration built-ins */ -#define MILLISECS_MULTIPLIER 1 -#define SECS_MULTIPLIER MILLISECS_MULTIPLIER * 1000 -#define MINUTES_MULTIPLIER SECS_MULTIPLIER * 60 -#define HOURS_MULTIPLIER MINUTES_MULTIPLIER * 60 -#define DAYS_MULTIPLIER HOURS_MULTIPLIER * 24 - -/* the maximum value for each of the calls */ -#define MILLISECS_MAX 0xffffffff -#define SECS_MAX 4294967 -#define MINUTES_MAX 71582 -#define HOURS_MAX 1193 -#define DAYS_MAX 49 - -/* forward declarations */ -static rtx chill_expand_expr PARAMS ((tree, rtx, enum machine_mode, - enum expand_modifier)); -static tree chill_expand_case_expr PARAMS ((tree)); -static int check_arglist_length PARAMS ((tree, int, int, tree)); -static tree internal_build_compound_expr PARAMS ((tree, int)); -static int is_really_instance PARAMS ((tree)); -static int invalid_operand PARAMS ((enum chill_tree_code, - tree, int)); -static int invalid_right_operand PARAMS ((enum chill_tree_code, tree)); -static tree build_chill_abstime PARAMS ((tree)); -static tree build_allocate_memory_call PARAMS ((tree, tree)); -static tree build_allocate_global_memory_call PARAMS ((tree, tree)); -static tree build_return_memory PARAMS ((tree)); -static tree build_chill_duration PARAMS ((tree, unsigned long, - tree, unsigned long)); -static tree build_chill_floatcall PARAMS ((tree, const char *, - const char *)); -static tree build_allocate_getstack PARAMS ((tree, tree, const char *, - const char *, tree, tree)); -static tree build_chill_allocate PARAMS ((tree, tree)); -static tree build_chill_getstack PARAMS ((tree, tree)); -static tree build_chill_terminate PARAMS ((tree)); -static tree build_chill_inttime PARAMS ((tree, tree)); -static tree build_chill_lower_or_upper PARAMS ((tree, int)); -static tree build_max_min PARAMS ((tree, int)); -static tree build_chill_pred_or_succ PARAMS ((tree, enum tree_code)); -static tree expand_packed_set PARAMS ((const char *, int, tree)); -static tree fold_set_expr PARAMS ((enum chill_tree_code, - tree, tree)); -static tree build_compare_set_expr PARAMS ((enum tree_code, tree, tree)); -static tree scalar_to_string PARAMS ((tree)); -static tree build_concat_expr PARAMS ((tree, tree)); -static tree build_compare_string_expr PARAMS ((enum tree_code, tree, tree)); -static tree compare_records PARAMS ((tree, tree)); -static tree string_char_rep PARAMS ((int, tree)); -static tree build_boring_bitstring PARAMS ((long, int)); - -/* variable to hold the type the DESCR built-in returns */ -static tree descr_type = NULL_TREE; - - -/* called from ch-lex.l */ -void -init_chill_expand () -{ - lang_expand_expr = chill_expand_expr; -} - -/* Take the address of something that needs to be passed by reference. */ -tree -force_addr_of (value) - tree value; -{ - /* FIXME. Move to memory, if needed. */ - if (TREE_CODE (value) == INDIRECT_REF) - return convert_to_pointer (ptr_type_node, TREE_OPERAND (value, 0)); - mark_addressable (value); - return build1 (ADDR_EXPR, ptr_type_node, value); -} - -/* Check that EXP has a known type. */ - -tree -check_have_mode (exp, context) - tree exp; - const char *context; -{ - if (TREE_CODE (exp) != ERROR_MARK && TREE_TYPE (exp) == NULL_TREE) - { - if (TREE_CODE (exp) == CONSTRUCTOR) - error ("tuple without specified mode not allowed in %s", context); - else if (TREE_CODE (exp) == COND_EXPR || TREE_CODE (exp) == CASE_EXPR) - error ("conditional expression not allowed in %s", context); - else - error ("internal error: unknown expression mode in %s", context); - - return error_mark_node; - } - return exp; -} - -/* Check that EXP is discrete. Handle conversion if flag_old_strings. */ - -tree -check_case_selector (exp) - tree exp; -{ - if (exp != NULL_TREE && TREE_TYPE (exp) != NULL_TREE) - exp = convert_to_discrete (exp); - if (exp) - return exp; - error ("CASE selector is not a discrete expression"); - return error_mark_node; -} - -tree -check_case_selector_list (list) - tree list; -{ - tree selector, exp, return_list = NULL_TREE; - - for (selector = list; selector != NULL_TREE; selector = TREE_CHAIN (selector)) - { - exp = check_case_selector (TREE_VALUE (selector)); - if (exp == error_mark_node) - { - return_list = error_mark_node; - break; - } - return_list = tree_cons (TREE_PURPOSE (selector), exp, return_list); - } - - return nreverse(return_list); -} - -static tree -chill_expand_case_expr (expr) - tree expr; -{ - tree selector_list = TREE_OPERAND (expr, 0), selector; - tree alternatives = TREE_OPERAND (expr, 1); - tree type = TREE_TYPE (expr); - int else_seen = 0; - tree result; - - if (TREE_CODE (selector_list) != TREE_LIST - || TREE_CODE (alternatives) != TREE_LIST) - abort(); - if (TREE_CHAIN (selector_list) != NULL_TREE) - abort (); - - /* make a temp for the case result */ - result = decl_temp1 (get_unique_identifier ("CASE_EXPR"), - type, 0, NULL_TREE, 0, 0); - - selector = check_case_selector (TREE_VALUE (selector_list)); - - expand_start_case (1, selector, TREE_TYPE (selector), "CASE expression"); - - alternatives = nreverse (alternatives); - for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives)) - { - tree labels = TREE_PURPOSE (alternatives), t; - - if (labels == NULL_TREE) - { - chill_handle_case_default (); - else_seen++; - } - else - { - tree label; - if (labels != NULL_TREE) - { - for (label = TREE_VALUE (labels); - label != NULL_TREE; label = TREE_CHAIN (label)) - chill_handle_case_label (TREE_VALUE (label), selector); - labels = TREE_CHAIN (labels); - if (labels != NULL_TREE) - error ("The number of CASE selectors does not match the number of CASE label lists"); - - } - } - - t = build (MODIFY_EXPR, type, result, - convert (type, TREE_VALUE (alternatives))); - TREE_SIDE_EFFECTS (t) = 1; - expand_expr_stmt (t); - expand_exit_something (); - } - - if (!else_seen) - { - chill_handle_case_default (); - expand_exit_something (); -#if 0 - expand_raise (); -#endif - - check_missing_cases (TREE_TYPE (selector)); - } - - expand_end_case (selector); - return result; -} - -/* Hook used by expand_expr to expand CHILL-specific tree codes. */ - -static rtx -chill_expand_expr (exp, target, tmode, modifier) - tree exp; - rtx target; - enum machine_mode tmode; - enum expand_modifier modifier; -{ - tree type = TREE_TYPE (exp); - register enum machine_mode mode = TYPE_MODE (type); - register enum tree_code code = TREE_CODE (exp); - rtx original_target = target; - rtx op0, op1; - int ignore = target == const0_rtx; - const char *lib_func; /* name of library routine */ - - if (ignore) - target = 0, original_target = 0; - - /* No sense saving up arithmetic to be done - if it's all in the wrong mode to form part of an address. - And force_operand won't know whether to sign-extend or zero-extend. */ - - if (mode != Pmode && modifier == EXPAND_SUM) - modifier = EXPAND_NORMAL; - - switch (code) - { - case STRING_EQ_EXPR: - case STRING_LT_EXPR: - { - rtx func = gen_rtx (SYMBOL_REF, Pmode, - code == STRING_EQ_EXPR ? "__eqstring" - : "__ltstring"); - tree exp0 = TREE_OPERAND (exp, 0); - tree exp1 = TREE_OPERAND (exp, 1); - tree size0, size1; - rtx op0, op1, siz0, siz1; - if (chill_varying_type_p (TREE_TYPE (exp0))) - { - exp0 = save_if_needed (exp0); - size0 = convert (integer_type_node, - build_component_ref (exp0, var_length_id)); - exp0 = build_component_ref (exp0, var_data_id); - } - else - size0 = size_in_bytes (TREE_TYPE (exp0)); - if (chill_varying_type_p (TREE_TYPE (exp1))) - { - exp1 = save_if_needed (exp1); - size1 = convert (integer_type_node, - build_component_ref (exp1, var_length_id)); - exp1 = build_component_ref (exp1, var_data_id); - } - else - size1 = size_in_bytes (TREE_TYPE (exp1)); - - op0 = expand_expr (force_addr_of (exp0), - NULL_RTX, MEM, EXPAND_CONST_ADDRESS); - op1 = expand_expr (force_addr_of (exp1), - NULL_RTX, MEM, EXPAND_CONST_ADDRESS); - siz0 = expand_expr (size0, NULL_RTX, VOIDmode, 0); - siz1 = expand_expr (size1, NULL_RTX, VOIDmode, 0); - return emit_library_call_value (func, target, - 0, QImode, 4, - op0, GET_MODE (op0), - siz0, TYPE_MODE (sizetype), - op1, GET_MODE (op1), - siz1, TYPE_MODE (sizetype)); - } - - case CASE_EXPR: - return expand_expr (chill_expand_case_expr (exp), - NULL_RTX, VOIDmode, 0); - break; - - case SLICE_EXPR: - { - tree func_call; - tree array = TREE_OPERAND (exp, 0); - tree min_value = TREE_OPERAND (exp, 1); - tree length = TREE_OPERAND (exp, 2); - tree new_type = TREE_TYPE (exp); - tree temp = decl_temp1 (get_unique_identifier ("BITSTRING"), - new_type, 0, NULL_TREE, 0, 0); - if (! CH_REFERABLE (array) && TYPE_MODE (TREE_TYPE (array)) != BLKmode) - array = decl_temp1 (get_unique_identifier ("BSTRINGVAL"), - TREE_TYPE (array), 0, array, 0, 0); - func_call = build_chill_function_call ( - lookup_name (get_identifier ("__psslice")), - tree_cons (NULL_TREE, - build_chill_addr_expr (temp, (char *)0), - tree_cons (NULL_TREE, length, - tree_cons (NULL_TREE, - force_addr_of (array), - tree_cons (NULL_TREE, powersetlen (array), - tree_cons (NULL_TREE, convert (integer_type_node, min_value), - tree_cons (NULL_TREE, length, NULL_TREE))))))); - expand_expr (func_call, const0_rtx, VOIDmode, 0); - emit_queue (); - return expand_expr (temp, ignore ? const0_rtx : target, - VOIDmode, 0); - } - - /* void __concatstring (char *out, char *left, unsigned left_len, - char *right, unsigned right_len) */ - case CONCAT_EXPR: - { - tree exp0 = TREE_OPERAND (exp, 0); - tree exp1 = TREE_OPERAND (exp, 1); - rtx size0 = NULL_RTX, size1 = NULL_RTX; - rtx targetx; - - if (TREE_CODE (exp1) == UNDEFINED_EXPR) - { - if (TYPE_MODE (TREE_TYPE (exp0)) == BLKmode - && TYPE_MODE (TREE_TYPE (exp)) == BLKmode) - { - rtx temp = expand_expr (exp0, target, tmode, modifier); - if (temp == target || target == NULL_RTX) - return temp; - emit_block_move (target, temp, expr_size (exp0), - TYPE_ALIGN (TREE_TYPE(exp0))); - return target; - } - else - { - exp0 = force_addr_of (exp0); - exp0 = convert (build_pointer_type (TREE_TYPE (exp)), exp0); - exp0 = build1 (INDIRECT_REF, TREE_TYPE (exp), exp0); - return expand_expr (exp0, - NULL_RTX, Pmode, EXPAND_CONST_ADDRESS); - } - } - - if (TREE_CODE (type) == ARRAY_TYPE) - { - /* No need to handle scalars or varying strings here, since that - was done in convert or build_concat_expr. */ - size0 = expand_expr (size_in_bytes (TREE_TYPE (exp0)), - NULL_RTX, Pmode, EXPAND_CONST_ADDRESS); - - size1 = expand_expr (size_in_bytes (TREE_TYPE (exp1)), - NULL_RTX, Pmode, EXPAND_CONST_ADDRESS); - - /* build a temp for the result, target is its address */ - if (target == NULL_RTX) - { - tree type0 = TREE_TYPE (exp0); - tree type1 = TREE_TYPE (exp1); - HOST_WIDE_INT len0 = int_size_in_bytes (type0); - HOST_WIDE_INT len1 = int_size_in_bytes (type1); - - if (len0 < 0 && TYPE_ARRAY_MAX_SIZE (type0) - && host_integerp (TYPE_ARRAY_MAX_SIZE (type0), 1)) - len0 = tree_low_cst (TYPE_ARRAY_MAX_SIZE (type0), 1); - - if (len1 < 0 && TYPE_ARRAY_MAX_SIZE (type1) - && host_integerp (TYPE_ARRAY_MAX_SIZE (type1), 1)) - len1 = tree_low_cst (TYPE_ARRAY_MAX_SIZE (type1), 1); - - if (len0 < 0 || len1 < 0) - abort (); - - target = assign_stack_temp (mode, len0 + len1, 0); - preserve_temp_slots (target); - } - } - else if (TREE_CODE (type) == SET_TYPE) - { - if (target == NULL_RTX) - { - target = assign_stack_temp (mode, int_size_in_bytes (type), 0); - preserve_temp_slots (target); - } - } - else - abort (); - - if (GET_CODE (target) == MEM) - targetx = target; - else - targetx = assign_stack_temp (mode, GET_MODE_SIZE (mode), 0); - - /* expand 1st operand to a pointer to the array */ - op0 = expand_expr (force_addr_of (exp0), - NULL_RTX, MEM, EXPAND_CONST_ADDRESS); - - /* expand 2nd operand to a pointer to the array */ - op1 = expand_expr (force_addr_of (exp1), - NULL_RTX, MEM, EXPAND_CONST_ADDRESS); - - if (TREE_CODE (type) == SET_TYPE) - { - size0 = expand_expr (powersetlen (exp0), - NULL_RTX, VOIDmode, 0); - size1 = expand_expr (powersetlen (exp1), - NULL_RTX, VOIDmode, 0); - - emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__concatps"), - 0, Pmode, 5, XEXP (targetx, 0), Pmode, - op0, GET_MODE (op0), - convert_to_mode (TYPE_MODE (sizetype), - size0, TREE_UNSIGNED (sizetype)), - TYPE_MODE (sizetype), - op1, GET_MODE (op1), - convert_to_mode (TYPE_MODE (sizetype), - size1, TREE_UNSIGNED (sizetype)), - TYPE_MODE (sizetype)); - } - else - { - /* copy left, then right array to target */ - emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__concatstring"), - 0, Pmode, 5, XEXP (targetx, 0), Pmode, - op0, GET_MODE (op0), - convert_to_mode (TYPE_MODE (sizetype), - size0, TREE_UNSIGNED (sizetype)), - TYPE_MODE (sizetype), - op1, GET_MODE (op1), - convert_to_mode (TYPE_MODE (sizetype), - size1, TREE_UNSIGNED (sizetype)), - TYPE_MODE (sizetype)); - } - if (targetx != target) - emit_move_insn (target, targetx); - return target; - } - - /* FIXME: the set_length computed below is a compile-time constant; - you'll need to re-write that part for VARYING bit arrays, and - possibly the set pointer will need to be adjusted to point past - the word containing its dynamic length. */ - - /* void __notpowerset (char *out, char *src, - unsigned long bitlength) */ - case SET_NOT_EXPR: - { - - tree expr = TREE_OPERAND (exp, 0); - tree tsize = powersetlen (expr); - rtx targetx; - - if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE) - tsize = fold (build (MULT_EXPR, sizetype, tsize, - size_int (BITS_PER_UNIT))); - - /* expand 1st operand to a pointer to the set */ - op0 = expand_expr (force_addr_of (expr), - NULL_RTX, MEM, EXPAND_CONST_ADDRESS); - - /* build a temp for the result, target is its address */ - if (target == NULL_RTX) - { - target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)), - int_size_in_bytes (TREE_TYPE (exp)), - 0); - preserve_temp_slots (target); - } - if (GET_CODE (target) == MEM) - targetx = target; - else - targetx = assign_stack_temp (GET_MODE (target), - GET_MODE_SIZE (GET_MODE (target)), - 0); - emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__notpowerset"), - 0, VOIDmode, 3, XEXP (targetx, 0), Pmode, - op0, GET_MODE (op0), - expand_expr (tsize, NULL_RTX, MEM, - EXPAND_CONST_ADDRESS), - TYPE_MODE (long_unsigned_type_node)); - if (targetx != target) - emit_move_insn (target, targetx); - return target; - } - - case SET_DIFF_EXPR: - lib_func = "__diffpowerset"; - goto format_2; - - case SET_IOR_EXPR: - lib_func = "__orpowerset"; - goto format_2; - - case SET_XOR_EXPR: - lib_func = "__xorpowerset"; - goto format_2; - - /* void __diffpowerset (char *out, char *left, char *right, - unsigned bitlength) */ - case SET_AND_EXPR: - lib_func = "__andpowerset"; - format_2: - { - tree expr = TREE_OPERAND (exp, 0); - tree tsize = powersetlen (expr); - rtx targetx; - - if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE) - tsize = fold (build (MULT_EXPR, long_unsigned_type_node, - tsize, - size_int (BITS_PER_UNIT))); - - /* expand 1st operand to a pointer to the set */ - op0 = expand_expr (force_addr_of (expr), - NULL_RTX, MEM, EXPAND_CONST_ADDRESS); - - /* expand 2nd operand to a pointer to the set */ - op1 = expand_expr (force_addr_of (TREE_OPERAND (exp, 1)), - NULL_RTX, MEM, - EXPAND_CONST_ADDRESS); - -/* FIXME: re-examine this code - the unary operator code above has recently - (93/03/12) been changed a lot. Should this code also change? */ - /* build a temp for the result, target is its address */ - if (target == NULL_RTX) - { - target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)), - int_size_in_bytes (TREE_TYPE (exp)), - 0); - preserve_temp_slots (target); - } - if (GET_CODE (target) == MEM) - targetx = target; - else - targetx = assign_stack_temp (GET_MODE (target), - GET_MODE_SIZE (GET_MODE (target)), 0); - emit_library_call (gen_rtx(SYMBOL_REF, Pmode, lib_func), - 0, VOIDmode, 4, XEXP (targetx, 0), Pmode, - op0, GET_MODE (op0), op1, GET_MODE (op1), - expand_expr (tsize, NULL_RTX, MEM, - EXPAND_CONST_ADDRESS), - TYPE_MODE (long_unsigned_type_node)); - if (target != targetx) - emit_move_insn (target, targetx); - return target; - } - - case SET_IN_EXPR: - { - tree set = TREE_OPERAND (exp, 1); - tree pos = convert (long_unsigned_type_node, TREE_OPERAND (exp, 0)); - tree set_type = TREE_TYPE (set); - tree set_length = discrete_count (TYPE_DOMAIN (set_type)); - tree min_val = convert (long_integer_type_node, - TYPE_MIN_VALUE (TYPE_DOMAIN (set_type))); - tree fcall; - - /* FIXME: Function-call not needed if pos and width are constant! */ - if (! mark_addressable (set)) - { - error ("powerset is not addressable"); - return const0_rtx; - } - /* we use different functions for bitstrings and powersets */ - if (CH_BOOLS_TYPE_P (set_type)) - fcall = - build_chill_function_call ( - lookup_name (get_identifier ("__inbitstring")), - tree_cons (NULL_TREE, - convert (long_unsigned_type_node, pos), - tree_cons (NULL_TREE, - build1 (ADDR_EXPR, build_pointer_type (set_type), set), - tree_cons (NULL_TREE, - convert (long_unsigned_type_node, set_length), - tree_cons (NULL_TREE, min_val, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - build_tree_list (NULL_TREE, get_chill_linenumber ()))))))); - else - fcall = - build_chill_function_call ( - lookup_name (get_identifier ("__inpowerset")), - tree_cons (NULL_TREE, - convert (long_unsigned_type_node, pos), - tree_cons (NULL_TREE, - build1 (ADDR_EXPR, build_pointer_type (set_type), set), - tree_cons (NULL_TREE, - convert (long_unsigned_type_node, set_length), - build_tree_list (NULL_TREE, min_val))))); - return expand_expr (fcall, NULL_RTX, VOIDmode, 0); - } - - case PACKED_ARRAY_REF: - { - tree array = TREE_OPERAND (exp, 0); - tree pos = save_expr (TREE_OPERAND (exp, 1)); - tree array_type = TREE_TYPE (array); - tree array_length = discrete_count (TYPE_DOMAIN (array_type)); - tree min_val = convert (long_integer_type_node, - TYPE_MIN_VALUE (TYPE_DOMAIN (array_type))); - tree fcall; - - /* FIXME: Function-call not needed if pos and width are constant! */ - /* TODO: make sure this makes sense. */ - if (! mark_addressable (array)) - { - error ("array is not addressable"); - return const0_rtx; - } - fcall = - build_chill_function_call ( - lookup_name (get_identifier ("__inpowerset")), - tree_cons (NULL_TREE, - convert (long_unsigned_type_node, pos), - tree_cons (NULL_TREE, - build1 (ADDR_EXPR, build_pointer_type (array_type), array), - tree_cons (NULL_TREE, - convert (long_unsigned_type_node, array_length), - build_tree_list (NULL_TREE, min_val))))); - return expand_expr (fcall, NULL_RTX, VOIDmode, 0); - } - - case UNDEFINED_EXPR: - if (target == 0) - { - target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)), - int_size_in_bytes (TREE_TYPE (exp)), 0); - preserve_temp_slots (target); - } - /* We don't actually need to *do* anything ... */ - return target; - - default: - break; - } - - /* NOTREACHED */ - return NULL; -} - -/* Check that the argument list has a length in [min_length .. max_length]. - (max_length == -1 means "infinite".) - If so return the actual length. - Otherwise, return an error message and return -1. */ - -static int -check_arglist_length (args, min_length, max_length, name) - tree args; - int min_length; - int max_length; - tree name; -{ - int length = list_length (args); - if (length < min_length) - error ("Too few arguments in call to `%s'", IDENTIFIER_POINTER (name)); - else if (max_length != -1 && length > max_length) - error ("Too many arguments in call to `%s'", IDENTIFIER_POINTER (name)); - else - return length; - return -1; -} - -/* - * This is the code from c-typeck.c, with the C-specific cruft - * removed (possibly I just didn't understand it, but it was - * apparently simply discarding part of my LIST). - */ -static tree -internal_build_compound_expr (list, first_p) - tree list; - int first_p ATTRIBUTE_UNUSED; -{ - register tree rest; - - if (TREE_CHAIN (list) == 0) - return TREE_VALUE (list); - - rest = internal_build_compound_expr (TREE_CHAIN (list), FALSE); - - if (! TREE_SIDE_EFFECTS (TREE_VALUE (list))) - return rest; - - return build (COMPOUND_EXPR, TREE_TYPE (rest), TREE_VALUE (list), rest); -} - - -/* Given a list of expressions, return a compound expression - that performs them all and returns the value of the last of them. */ -/* FIXME: this should be merged with the C version */ -tree -build_chill_compound_expr (list) - tree list; -{ - return internal_build_compound_expr (list, TRUE); -} - -/* Given an expression PTR for a pointer, return an expression - for the value pointed to. - do_empty_check is 0, don't perform a NULL pointer check, - else do it. */ - -tree -build_chill_indirect_ref (ptr, mode, do_empty_check) - tree ptr; - tree mode; - int do_empty_check; -{ - register tree type; - - if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK) - return ptr; - if (mode != NULL_TREE && TREE_CODE (mode) == ERROR_MARK) - return error_mark_node; - - type = TREE_TYPE (ptr); - - if (TREE_CODE (type) == REFERENCE_TYPE) - { - type = TREE_TYPE (type); - ptr = convert (type, ptr); - } - - /* check for ptr is really a POINTER */ - if (TREE_CODE (type) != POINTER_TYPE) - { - error ("cannot dereference, not a pointer."); - return error_mark_node; - } - - if (mode && TREE_CODE (mode) == IDENTIFIER_NODE) - { - tree decl = lookup_name (mode); - if (decl == NULL_TREE || TREE_CODE (decl) != TYPE_DECL) - { - if (pass == 2) - error ("missing '.' operator or undefined mode name `%s'.", - IDENTIFIER_POINTER (mode)); -#if 0 - error ("You have forgotten the '.' operator which must"); - error (" precede a STRUCT field reference, or `%s' is an undefined mode", - IDENTIFIER_POINTER (mode)); -#endif - return error_mark_node; - } - } - - if (mode) - { - mode = get_type_of (mode); - ptr = convert (build_pointer_type (mode), ptr); - } - else if (type == ptr_type_node) - { - error ("Can't dereference PTR value using unary `->'."); - return error_mark_node; - } - - if (do_empty_check) - ptr = check_non_null (ptr); - - type = TREE_TYPE (ptr); - - if (TREE_CODE (type) == POINTER_TYPE) - { - if (TREE_CODE (ptr) == ADDR_EXPR - && !flag_volatile - && (TREE_TYPE (TREE_OPERAND (ptr, 0)) - == TREE_TYPE (type))) - return TREE_OPERAND (ptr, 0); - else - { - tree t = TREE_TYPE (type); - register tree ref = build1 (INDIRECT_REF, - TYPE_MAIN_VARIANT (t), ptr); - - if (TYPE_SIZE (t) == 0 && TREE_CODE (t) != ARRAY_TYPE) - { - error ("dereferencing pointer to incomplete type"); - return error_mark_node; - } - if (TREE_CODE (t) == VOID_TYPE) - warning ("dereferencing `void *' pointer"); - - /* We *must* set TREE_READONLY when dereferencing a pointer to const, - so that we get the proper error message if the result is used - to assign to. Also, &* is supposed to be a no-op. - And ANSI C seems to specify that the type of the result - should be the const type. */ - /* A de-reference of a pointer to const is not a const. It is valid - to change it via some other pointer. */ - TREE_READONLY (ref) = TYPE_READONLY (t); - TREE_SIDE_EFFECTS (ref) - = TYPE_VOLATILE (t) || TREE_SIDE_EFFECTS (ptr) || flag_volatile; - TREE_THIS_VOLATILE (ref) = TYPE_VOLATILE (t) || flag_volatile; - return ref; - } - } - else if (TREE_CODE (ptr) != ERROR_MARK) - error ("invalid type argument of `->'"); - return error_mark_node; -} - -/* NODE is a COMPONENT_REF whose mode is an IDENTIFIER, - which is replaced by the proper FIELD_DECL. - Also do the right thing for variant records. */ - -tree -resolve_component_ref (node) - tree node; -{ - tree datum = TREE_OPERAND (node, 0); - tree field_name = TREE_OPERAND (node, 1); - tree type = TREE_TYPE (datum); - tree field; - if (TREE_CODE (datum) == ERROR_MARK) - return error_mark_node; - if (TREE_CODE (type) == REFERENCE_TYPE) - { - type = TREE_TYPE (type); - TREE_OPERAND (node, 0) = datum = convert (type, datum); - } - if (TREE_CODE (type) != RECORD_TYPE) - { - error ("operand of '.' is not a STRUCT"); - return error_mark_node; - } - - TREE_READONLY (node) = TREE_READONLY (datum); - TREE_SIDE_EFFECTS (node) = TREE_SIDE_EFFECTS (datum); - - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - { - if (TREE_CODE (TREE_TYPE (field)) == UNION_TYPE) - { - tree variant; - for (variant = TYPE_FIELDS (TREE_TYPE (field)); - variant; variant = TREE_CHAIN (variant)) - { - tree vfield; - for (vfield = TYPE_FIELDS (TREE_TYPE (variant)); - vfield; vfield = TREE_CHAIN (vfield)) - { - if (DECL_NAME (vfield) == field_name) - { /* Found a variant field */ - datum = build (COMPONENT_REF, TREE_TYPE (field), - datum, field); - datum = build (COMPONENT_REF, TREE_TYPE (variant), - datum, variant); - TREE_OPERAND (node, 0) = datum; - TREE_OPERAND (node, 1) = vfield; - TREE_TYPE (node) = TREE_TYPE (vfield); - TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node)); -#if 0 - if (flag_testing_tags) - { - tree tagtest = NOT IMPLEMENTED; - tree tagf = ridpointers[(int) RID_RANGEFAIL]; - node = check_expression (node, tagtest, - tagf); - } -#endif - return node; - } - } - } - } - - if (DECL_NAME (field) == field_name) - { /* Found a fixed field */ - TREE_OPERAND (node, 1) = field; - TREE_TYPE (node) = TREE_TYPE (field); - TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node)); - return fold (node); - } - } - - error ("No field named `%s'", IDENTIFIER_POINTER (field_name)); - return error_mark_node; -} - -tree -build_component_ref (datum, field_name) - tree datum, field_name; -{ - tree node = build_nt (COMPONENT_REF, datum, field_name); - if (pass != 1) - node = resolve_component_ref (node); - return node; -} - -/* - function checks (for build_chill_component_ref) if a given - type is really an instance type. CH_IS_INSTANCE_MODE is not - strict enough in this case, i.e. SYNMODE foo = STRUCT (a, b UINT) - is compatible to INSTANCE. */ - -static int -is_really_instance (type) - tree type; -{ - tree decl = TYPE_NAME (type); - - if (decl == NULL_TREE) - /* this is not an instance */ - return 0; - - if (DECL_NAME (decl) == ridpointers[(int)RID_INSTANCE]) - /* this is an instance */ - return 1; - - if (TYPE_FIELDS (type) == TYPE_FIELDS (instance_type_node)) - /* we have a NEWMODE'd instance */ - return 1; - - return 0; -} - -/* This function is called by the parse. - Here we check if the user tries to access a field in a type which is - layouted as a structure but isn't like INSTANCE, BUFFER, EVENT, ASSOCIATION, - ACCESS, TEXT, or VARYING array or character string. - We don't do this in build_component_ref cause this function gets - called from the compiler to access fields in one of the above mentioned - modes. */ -tree -build_chill_component_ref (datum, field_name) - tree datum, field_name; -{ - tree type = TREE_TYPE (datum); - if ((type != NULL_TREE && TREE_CODE (type) == RECORD_TYPE) && - ((CH_IS_INSTANCE_MODE (type) && is_really_instance (type)) || - CH_IS_BUFFER_MODE (type) || - CH_IS_EVENT_MODE (type) || CH_IS_ASSOCIATION_MODE (type) || - CH_IS_ACCESS_MODE (type) || CH_IS_TEXT_MODE (type) || - chill_varying_type_p (type))) - { - error ("operand of '.' is not a STRUCT"); - return error_mark_node; - } - return build_component_ref (datum, field_name); -} - -/* - * Check for invalid binary operands & unary operands - * RIGHT is 1 if checking right operand or unary operand; - * it is 0 if checking left operand. - * - * return 1 if the given operand is NOT compatible as the - * operand of the given operator - * - * return 0 if they might be compatible - */ -static int -invalid_operand (code, type, right) - enum chill_tree_code code; - tree type; - int right; /* 1 if right operand */ -{ - switch ((int)code) - { - case ADDR_EXPR: - break; - case BIT_AND_EXPR: - case BIT_IOR_EXPR: - case BIT_NOT_EXPR: - case BIT_XOR_EXPR: - goto relationals; - case CASE_EXPR: - break; - case CEIL_MOD_EXPR: - goto numerics; - case CONCAT_EXPR: /* must be static or varying char array */ - if (TREE_CODE (type) == CHAR_TYPE) - return 0; - if (TREE_CODE (type) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE) - return 0; - if (!chill_varying_type_p (type)) - return 1; - if (TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type))) - == CHAR_TYPE) - return 0; - else - return 1; - /* note: CHILL conditional expressions (COND_EXPR) won't come - * through here; they're routed straight to C-specific code */ - case EQ_EXPR: - return 0; /* ANYTHING can be compared equal */ - case FLOOR_MOD_EXPR: - if (TREE_CODE (type) == REAL_TYPE) - return 1; - goto numerics; - case GE_EXPR: - case GT_EXPR: - goto relatables; - case SET_IN_EXPR: - if (TREE_CODE (type) == SET_TYPE) - return 0; - else - return 1; - case PACKED_ARRAY_REF: - if (TREE_CODE (type) == ARRAY_TYPE) - return 0; - else - return 1; - case LE_EXPR: - case LT_EXPR: - relatables: - switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */ - { - case ARRAY_TYPE: - if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE) - return 0; - else - return 1; - case BOOLEAN_TYPE: - case CHAR_TYPE: - case COMPLEX_TYPE: - case ENUMERAL_TYPE: - case INTEGER_TYPE: - case OFFSET_TYPE: - case POINTER_TYPE: - case REAL_TYPE: - case SET_TYPE: - return 0; - case FILE_TYPE: - case FUNCTION_TYPE: - case GRANT_TYPE: - case LANG_TYPE: - case METHOD_TYPE: - return 1; - case RECORD_TYPE: - if (chill_varying_type_p (type) - && TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type))) == CHAR_TYPE) - return 0; - else - return 1; - case REFERENCE_TYPE: - case SEIZE_TYPE: - case UNION_TYPE: - case VOID_TYPE: - return 1; - } - break; - case MINUS_EXPR: - case MULT_EXPR: - goto numerics; - case NEGATE_EXPR: - if (TREE_CODE (type) == BOOLEAN_TYPE) - return 0; - else - goto numerics; - case NE_EXPR: - return 0; /* ANYTHING can be compared unequal */ - case NOP_EXPR: - return 0; /* ANYTHING can be converted */ - case PLUS_EXPR: - numerics: - switch ((int)TREE_CODE(type)) /* left operand must be discrete type */ - { - case ARRAY_TYPE: - if (right || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE) - return 1; - else - return 0; - case CHAR_TYPE: - return right; - case BOOLEAN_TYPE: - case COMPLEX_TYPE: - case FILE_TYPE: - case FUNCTION_TYPE: - case GRANT_TYPE: - case LANG_TYPE: - case METHOD_TYPE: - case RECORD_TYPE: - case REFERENCE_TYPE: - case SEIZE_TYPE: - case UNION_TYPE: - case VOID_TYPE: - return 1; - case ENUMERAL_TYPE: - case INTEGER_TYPE: - case OFFSET_TYPE: - case POINTER_TYPE: - case REAL_TYPE: - case SET_TYPE: - return 0; - } - break; - case RANGE_EXPR: - break; - - case REPLICATE_EXPR: - switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */ - { - case COMPLEX_TYPE: - case FILE_TYPE: - case FUNCTION_TYPE: - case GRANT_TYPE: - case LANG_TYPE: - case METHOD_TYPE: - case OFFSET_TYPE: - case POINTER_TYPE: - case RECORD_TYPE: - case REAL_TYPE: - case SEIZE_TYPE: - case UNION_TYPE: - case VOID_TYPE: - return 1; - case ARRAY_TYPE: - case BOOLEAN_TYPE: - case CHAR_TYPE: - case ENUMERAL_TYPE: - case INTEGER_TYPE: - case REFERENCE_TYPE: - case SET_TYPE: - return 0; - } - - case TRUNC_DIV_EXPR: - goto numerics; - case TRUNC_MOD_EXPR: - if (TREE_CODE (type) == REAL_TYPE) - return 1; - goto numerics; - case TRUTH_ANDIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_NOT_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_OR_EXPR: - relationals: - switch ((int)TREE_CODE(type)) /* left operand must be discrete type */ - { - case ARRAY_TYPE: - case CHAR_TYPE: - case COMPLEX_TYPE: - case ENUMERAL_TYPE: - case FILE_TYPE: - case FUNCTION_TYPE: - case GRANT_TYPE: - case INTEGER_TYPE: - case LANG_TYPE: - case METHOD_TYPE: - case OFFSET_TYPE: - case POINTER_TYPE: - case REAL_TYPE: - case RECORD_TYPE: - case REFERENCE_TYPE: - case SEIZE_TYPE: - case UNION_TYPE: - case VOID_TYPE: - return 1; - case BOOLEAN_TYPE: - case SET_TYPE: - return 0; - } - break; - - default: - return 1; /* perhaps you forgot to add a new DEFTREECODE? */ - } - return 1; -} - - -static int -invalid_right_operand (code, type) - enum chill_tree_code code; - tree type; -{ - return invalid_operand (code, type, 1); -} - -tree -build_chill_abs (expr) - tree expr; -{ - tree temp; - - if (TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE - || discrete_type_p (TREE_TYPE (expr))) - temp = fold (build1 (ABS_EXPR, TREE_TYPE (expr), expr)); - else - { - error("ABS argument must be discrete or real mode"); - return error_mark_node; - } - /* FIXME: should call - * cond_type_range_exception (temp); - */ - return temp; -} - -static tree -build_chill_abstime (exprlist) - tree exprlist; -{ - int mask = 0, i, numargs; - tree args = NULL_TREE; - tree filename, lineno; - int had_errors = 0; - tree tmp; - - if (exprlist != NULL_TREE && TREE_CODE (exprlist) == ERROR_MARK) - return error_mark_node; - - /* check for integer expressions */ - i = 1; - tmp = exprlist; - while (tmp != NULL_TREE) - { - tree exp = TREE_VALUE (tmp); - - if (exp == NULL_TREE || TREE_CODE (exp) == ERROR_MARK) - had_errors = 1; - else if (TREE_CODE (TREE_TYPE (exp)) != INTEGER_TYPE) - { - error ("argument %d to ABSTIME must be of integer type.", i); - had_errors = 1; - } - tmp = TREE_CHAIN (tmp); - i++; - } - if (had_errors) - return error_mark_node; - - numargs = list_length (exprlist); - for (i = 0; i < numargs; i++) - mask |= (1 << i); - - /* make it all arguments */ - for (i = numargs; i < 6; i++) - exprlist = tree_cons (NULL_TREE, integer_zero_node, exprlist); - - args = tree_cons (NULL_TREE, build_int_2 (mask, 0), exprlist); - - filename = force_addr_of (get_chill_filename ()); - lineno = get_chill_linenumber (); - args = chainon (args, tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, lineno, NULL_TREE))); - - return build_chill_function_call ( - lookup_name (get_identifier ("_abstime")), args); -} - - -static tree -build_allocate_memory_call (ptr, size) - tree ptr, size; -{ - int err = 0; - - /* check for ptr is referable */ - if (! CH_REFERABLE (ptr)) - { - error ("parameter 1 must be referable."); - err++; - } - /* check for pointer */ - else if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE) - { - error ("mode mismatch in parameter 1."); - err++; - } - - /* check for size > 0 if it is a constant */ - if (TREE_CODE (size) == INTEGER_CST && TREE_INT_CST_LOW (size) <= 0) - { - error ("parameter 2 must be a positive integer."); - err++; - } - if (err) - return error_mark_node; - - if (TREE_TYPE (ptr) != ptr_type_node) - ptr = build_chill_cast (ptr_type_node, ptr); - - return build_chill_function_call ( - lookup_name (get_identifier ("_allocate_memory")), - tree_cons (NULL_TREE, ptr, - tree_cons (NULL_TREE, size, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), - NULL_TREE))))); -} - - -static tree -build_allocate_global_memory_call (ptr, size) - tree ptr, size; -{ - int err = 0; - - /* check for ptr is referable */ - if (! CH_REFERABLE (ptr)) - { - error ("parameter 1 must be referable."); - err++; - } - /* check for pointer */ - else if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE) - { - error ("mode mismatch in parameter 1."); - err++; - } - - /* check for size > 0 if it is a constant */ - if (TREE_CODE (size) == INTEGER_CST && TREE_INT_CST_LOW (size) <= 0) - { - error ("parameter 2 must be a positive integer."); - err++; - } - if (err) - return error_mark_node; - - if (TREE_TYPE (ptr) != ptr_type_node) - ptr = build_chill_cast (ptr_type_node, ptr); - - return build_chill_function_call ( - lookup_name (get_identifier ("_allocate_global_memory")), - tree_cons (NULL_TREE, ptr, - tree_cons (NULL_TREE, size, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), - NULL_TREE))))); -} - - -static tree -build_return_memory (ptr) - tree ptr; -{ - /* check input */ - if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK) - return error_mark_node; - - /* check for pointer */ - if (TREE_CODE (TREE_TYPE (ptr)) != POINTER_TYPE) - { - error ("mode mismatch in parameter 1."); - return error_mark_node; - } - - if (TREE_TYPE (ptr) != ptr_type_node) - ptr = build_chill_cast (ptr_type_node, ptr); - - return build_chill_function_call ( - lookup_name (get_identifier ("_return_memory")), - tree_cons (NULL_TREE, ptr, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), - NULL_TREE)))); -} - - -/* Compute the number of runtime members of the - * given powerset. - */ -tree -build_chill_card (powerset) - tree powerset; -{ - if (pass == 2) - { - tree temp; - tree card_func = lookup_name (get_identifier ("__cardpowerset")); - - if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (powerset) == IDENTIFIER_NODE) - powerset = lookup_name (powerset); - - if (TREE_CODE (TREE_TYPE(powerset)) == SET_TYPE) - { int size; - - /* Do constant folding, if possible. */ - if (TREE_CODE (powerset) == CONSTRUCTOR - && TREE_CONSTANT (powerset) - && (size = int_size_in_bytes (TREE_TYPE (powerset))) >= 0) - { - int bit_size = size * BITS_PER_UNIT; - char* buffer = (char*) alloca (bit_size); - temp = get_set_constructor_bits (powerset, buffer, bit_size); - if (!temp) - { int i; - int count = 0; - for (i = 0; i < bit_size; i++) - if (buffer[i]) - count++; - temp = build_int_2 (count, 0); - TREE_TYPE (temp) = TREE_TYPE (TREE_TYPE (card_func)); - return temp; - } - } - temp = build_chill_function_call (card_func, - tree_cons (NULL_TREE, force_addr_of (powerset), - tree_cons (NULL_TREE, powersetlen (powerset), NULL_TREE))); - /* FIXME: should call - * cond_type_range_exception (op0); - */ - return temp; - } - error("CARD argument must be powerset mode"); - return error_mark_node; - } - return NULL_TREE; -} - -/* function to build the type needed for the DESCR-built-in - */ - -void build_chill_descr_type () -{ - tree decl1, decl2; - - if (descr_type != NULL_TREE) - /* already done */ - return; - - decl1 = build_decl (FIELD_DECL, get_identifier ("datap"), ptr_type_node); - decl2 = build_decl (FIELD_DECL, get_identifier ("len"), - TREE_TYPE (lookup_name ( - get_identifier ((ignore_case || ! special_UC) ? "ulong" : "ULONG")))); - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - decl2 = build_chill_struct_type (decl1); - descr_type = build_decl (TYPE_DECL, get_identifier ("__tmp_DESCR_type"), decl2); - pushdecl (descr_type); - DECL_SOURCE_LINE (descr_type) = 0; - satisfy_decl (descr_type, 0); -} - -/* build a pointer to a descriptor. - * descriptor = STRUCT (datap PTR, - * len ULONG); - * This descriptor is build in variable descr_type. - */ - -tree -build_chill_descr (expr) - tree expr; -{ - if (pass == 2) - { - tree tuple, decl, descr_var, datap, len, tmp; - int is_static; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - /* check for expression is referable */ - if (! CH_REFERABLE (expr)) - { - error ("expression for DESCR-builtin must be referable."); - return error_mark_node; - } - - mark_addressable (expr); -#if 0 - datap = build1 (ADDR_EXPR, build_chill_pointer_type (descr_type), expr); -#else - datap = build_chill_arrow_expr (expr, 1); -#endif - len = size_in_bytes (TREE_TYPE (expr)); - - descr_var = get_unique_identifier ("DESCR"); - tuple = build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, datap, - tree_cons (NULL_TREE, len, NULL_TREE))); - - is_static = (current_function_decl == global_function_decl) && TREE_STATIC (expr); - decl = decl_temp1 (descr_var, TREE_TYPE (descr_type), is_static, - tuple, 0, 0); -#if 0 - tmp = force_addr_of (decl); -#else - tmp = build_chill_arrow_expr (decl, 1); -#endif - return tmp; - } - return NULL_TREE; -} - -/* this function process the builtin's - MILLISECS, SECS, MINUTES, HOURS and DAYS. - The built duration value is in milliseconds. */ - -static tree -build_chill_duration (expr, multiplier, fnname, maxvalue) - tree expr; - unsigned long multiplier; - tree fnname; - unsigned long maxvalue; -{ - tree temp; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE) - { - error ("argument to `%s' must be of integer type.", IDENTIFIER_POINTER (fnname)); - return error_mark_node; - } - - temp = convert (duration_timing_type_node, expr); - temp = fold (build (MULT_EXPR, duration_timing_type_node, - temp, build_int_2 (multiplier, 0))); - - if (range_checking) - temp = check_range (temp, expr, integer_zero_node, build_int_2 (maxvalue, 0)); - - return temp; -} - -/* build function call to one of the floating point functions */ -static tree -build_chill_floatcall (expr, chillname, funcname) - tree expr; - const char *chillname; - const char *funcname; -{ - tree result; - tree type; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - /* look if expr is a REAL_TYPE */ - type = TREE_TYPE (expr); - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - if (TREE_CODE (type) != REAL_TYPE) - { - error ("argument 1 to `%s' must be of floating point mode", chillname); - return error_mark_node; - } - result = build_chill_function_call ( - lookup_name (get_identifier (funcname)), - tree_cons (NULL_TREE, expr, NULL_TREE)); - return result; -} - -/* common function for ALLOCATE and GETSTACK */ -static tree -build_allocate_getstack (mode, value, chill_name, fnname, filename, linenumber) - tree mode; - tree value; - const char *chill_name; - const char *fnname; - tree filename; - tree linenumber; -{ - tree type, result; - tree expr = NULL_TREE; - tree args, tmpvar, fncall, ptr, outlist = NULL_TREE; - - if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (mode) == TYPE_DECL) - type = TREE_TYPE (mode); - else - type = mode; - - /* check if we have a mode */ - if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') - { - error ("First argument to `%s' must be a mode", chill_name); - return error_mark_node; - } - - /* check if we have a value if type is READonly */ - if (TYPE_READONLY_PROPERTY (type) && value == NULL_TREE) - { - error ("READonly modes for %s must have a value", chill_name); - return error_mark_node; - } - - if (value != NULL_TREE) - { - if (TREE_CODE (value) == ERROR_MARK) - return error_mark_node; - expr = chill_convert_for_assignment (type, value, "assignment"); - } - - /* build function arguments */ - if (filename == NULL_TREE) - args = tree_cons (NULL_TREE, size_in_bytes (type), NULL_TREE); - else - args = tree_cons (NULL_TREE, size_in_bytes (type), - tree_cons (NULL_TREE, force_addr_of (filename), - tree_cons (NULL_TREE, linenumber, NULL_TREE))); - - ptr = build_chill_pointer_type (type); - tmpvar = decl_temp1 (get_unique_identifier (chill_name), - ptr, 0, NULL_TREE, 0, 0); - fncall = build_chill_function_call ( - lookup_name (get_identifier (fnname)), args); - outlist = tree_cons (NULL_TREE, - build_chill_modify_expr (tmpvar, fncall), outlist); - if (expr == NULL_TREE) - { - /* set allocated memory to 0 */ - fncall = build_chill_function_call ( - lookup_name (get_identifier ("memset")), - tree_cons (NULL_TREE, convert (ptr_type_node, tmpvar), - tree_cons (NULL_TREE, integer_zero_node, - tree_cons (NULL_TREE, size_in_bytes (type), NULL_TREE)))); - outlist = tree_cons (NULL_TREE, fncall, outlist); - } - else - { - /* write the init value to allocated memory */ - outlist = tree_cons (NULL_TREE, - build_chill_modify_expr (build_chill_indirect_ref (tmpvar, NULL_TREE, 0), - expr), - outlist); - } - outlist = tree_cons (NULL_TREE, tmpvar, outlist); - result = build_chill_compound_expr (nreverse (outlist)); - return result; -} - -/* process the ALLOCATE built-in */ -static tree -build_chill_allocate (mode, value) - tree mode; - tree value; -{ - return build_allocate_getstack (mode, value, "ALLOCATE", "__allocate", - get_chill_filename (), get_chill_linenumber ()); -} - -/* process the GETSTACK built-in */ -static tree -build_chill_getstack (mode, value) - tree mode; - tree value; -{ - return build_allocate_getstack (mode, value, "GETSTACK", "__builtin_alloca", - NULL_TREE, NULL_TREE); -} - -/* process the TERMINATE built-in */ -static tree -build_chill_terminate (ptr) - tree ptr; -{ - tree result; - tree type; - - if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK) - return error_mark_node; - - type = TREE_TYPE (ptr); - if (type == NULL_TREE || TREE_CODE (type) != POINTER_TYPE) - { - error ("argument to TERMINATE must be a reference primitive value"); - return error_mark_node; - } - result = build_chill_function_call ( - lookup_name (get_identifier ("__terminate")), - tree_cons (NULL_TREE, convert (ptr_type_node, ptr), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - return result; -} - -/* build the type passed to _inttime function */ -void -build_chill_inttime_type () -{ - tree idxlist; - tree arrtype; - tree decl; - - idxlist = build_tree_list (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_zero_node, - build_int_2 (5, 0))); - arrtype = build_chill_array_type (ptr_type_node, idxlist, 0, NULL_TREE); - - decl = build_decl (TYPE_DECL, get_identifier ("__tmp_INTTIME_type"), arrtype); - pushdecl (decl); - DECL_SOURCE_LINE (decl) = 0; - satisfy_decl (decl, 0); -} - -static tree -build_chill_inttime (t, loclist) - tree t, loclist; -{ - int had_errors = 0, cnt; - tree tmp; - tree init = NULL_TREE; - int numargs; - tree tuple, var; - - if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK) - return error_mark_node; - if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK) - return error_mark_node; - - /* check first argument to be NEWMODE TIME */ - if (TREE_TYPE (t) != abs_timing_type_node) - { - error ("argument 1 to INTTIME must be of mode TIME."); - had_errors = 1; - } - - cnt = 2; - tmp = loclist; - while (tmp != NULL_TREE) - { - tree loc = TREE_VALUE (tmp); - char errmsg[200]; - char *p, *p1; - int write_error = 0; - - sprintf (errmsg, "argument %d to INTTIME must be ", cnt); - p = errmsg + strlen (errmsg); - p1 = p; - - if (loc == NULL_TREE || TREE_CODE (loc) == ERROR_MARK) - had_errors = 1; - else - { - if (! CH_REFERABLE (loc)) - { - strcpy (p, "referable"); - p += strlen (p); - write_error = 1; - had_errors = 1; - } - if (TREE_CODE (TREE_TYPE (loc)) != INTEGER_TYPE) - { - if (p != p1) - { - strcpy (p, " and "); - p += strlen (p); - } - strcpy (p, "of integer type"); - write_error = 1; - had_errors = 1; - } - /* FIXME: what's about ranges can't hold the result ?? */ - if (write_error) - error ("%s.", errmsg); - } - /* next location */ - tmp = TREE_CHAIN (tmp); - cnt++; - } - - if (had_errors) - return error_mark_node; - - /* make it always 6 arguments */ - numargs = list_length (loclist); - for (cnt = numargs; cnt < 6; cnt++) - init = tree_cons (NULL_TREE, null_pointer_node, init); - - /* append the given one's */ - tmp = loclist; - while (tmp != NULL_TREE) - { - init = chainon (init, - build_tree_list (NULL_TREE, - build_chill_descr (TREE_VALUE (tmp)))); - tmp = TREE_CHAIN (tmp); - } - - tuple = build_nt (CONSTRUCTOR, NULL_TREE, init); - var = decl_temp1 (get_unique_identifier ("INTTIME"), - TREE_TYPE (lookup_name (get_identifier ("__tmp_INTTIME_type"))), - 0, tuple, 0, 0); - - return build_chill_function_call ( - lookup_name (get_identifier ("_inttime")), - tree_cons (NULL_TREE, t, - tree_cons (NULL_TREE, force_addr_of (var), - NULL_TREE))); -} - - -/* Compute the runtime length of the given string variable - * or expression. - */ -tree -build_chill_length (expr) - tree expr; -{ - if (pass == 2) - { - tree type; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (expr) == IDENTIFIER_NODE) - expr = lookup_name (expr); - - type = TREE_TYPE (expr); - - if (TREE_CODE(type) == ERROR_MARK) - return type; - if (chill_varying_type_p (type)) - { - tree temp = convert (integer_type_node, - build_component_ref (expr, var_length_id)); - /* FIXME: should call - * cond_type_range_exception (temp); - */ - return temp; - } - - if ((TREE_CODE (type) == ARRAY_TYPE || - /* should work for a bitstring too */ - (TREE_CODE (type) == SET_TYPE && TREE_CODE (TREE_TYPE (type)) == BOOLEAN_TYPE)) && - integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (type)))) - { - tree temp = fold (build (PLUS_EXPR, chill_integer_type_node, - integer_one_node, - TYPE_MAX_VALUE (TYPE_DOMAIN (type)))); - return convert (chill_integer_type_node, temp); - } - - if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) - { - tree len = max_queue_size (type); - - if (len == NULL_TREE) - len = integer_minus_one_node; - return len; - } - - if (CH_IS_TEXT_MODE (type)) - { - if (TREE_CODE (expr) == TYPE_DECL) - { - /* text mode name */ - return text_length (type); - } - else - { - /* text location */ - tree temp = build_component_ref ( - build_component_ref (expr, get_identifier ("tloc")), - var_length_id); - return convert (integer_type_node, temp); - } - } - - error("LENGTH argument must be string, buffer, event mode, text location or mode"); - return error_mark_node; - } - return NULL_TREE; -} - -/* Compute the declared minimum/maximum value of the variable, - * expression or declared type - */ -static tree -build_chill_lower_or_upper (what, is_upper) - tree what; - int is_upper; /* o -> LOWER; 1 -> UPPER */ -{ - if (pass == 2) - { - tree type; - struct ch_class class; - - if (what == NULL_TREE || TREE_CODE (what) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE_CLASS (TREE_CODE (what)) == 't') - type = what; - else - type = TREE_TYPE (what); - if (type == NULL_TREE) - { - if (is_upper) - error ("UPPER argument must have a mode, or be a mode"); - else - error ("LOWER argument must have a mode, or be a mode"); - return error_mark_node; - } - while (TREE_CODE (type) == REFERENCE_TYPE) - type = TREE_TYPE (type); - if (chill_varying_type_p (type)) - type = CH_VARYING_ARRAY_TYPE (type); - - if (discrete_type_p (type)) - { - tree val = is_upper ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type); - class.kind = CH_VALUE_CLASS; - class.mode = type; - return convert_to_class (class, val); - } - else if (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == SET_TYPE) - { - if (TYPE_STRING_FLAG (type)) - { - class.kind = CH_DERIVED_CLASS; - class.mode = integer_type_node; - } - else - { - class.kind = CH_VALUE_CLASS; - class.mode = TYPE_DOMAIN (type); - } - type = TYPE_DOMAIN (type); - return convert_to_class (class, - is_upper - ? TYPE_MAX_VALUE (type) - : TYPE_MIN_VALUE (type)); - } - if (is_upper) - error("UPPER argument must be string, array, mode or integer"); - else - error("LOWER argument must be string, array, mode or integer"); - return error_mark_node; - } - return NULL_TREE; -} - -tree -build_chill_lower (what) - tree what; -{ - return build_chill_lower_or_upper (what, 0); -} - -static tree -build_max_min (expr, max_min) - tree expr; - int max_min; /* 0: calculate MIN; 1: calculate MAX */ -{ - if (pass == 2) - { - tree type, temp, setminval; - tree set_base_type; - int size_in_bytes; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (expr) == IDENTIFIER_NODE) - expr = lookup_name (expr); - - type = TREE_TYPE (expr); - set_base_type = TYPE_DOMAIN (type); - setminval = TYPE_MIN_VALUE (set_base_type); - - if (TREE_CODE (type) != SET_TYPE) - { - error("%s argument must be POWERSET mode", - max_min ? "MAX" : "MIN"); - return error_mark_node; - } - - /* find max/min of constant powerset at compile time */ - if (TREE_CODE (expr) == CONSTRUCTOR && TREE_CONSTANT (expr) - && (size_in_bytes = int_size_in_bytes (type)) >= 0) - { - HOST_WIDE_INT min_val = -1, max_val = -1; - HOST_WIDE_INT i, i_hi = 0; - HOST_WIDE_INT size_in_bits = size_in_bytes * BITS_PER_UNIT; - char *buffer = (char*) alloca (size_in_bits); - if (buffer == NULL - || get_set_constructor_bits (expr, buffer, size_in_bits)) - abort (); - for (i = 0; i < size_in_bits; i++) - { - if (buffer[i]) - { - if (min_val < 0) - min_val = i; - max_val = i; - } - } - if (min_val < 0) - error ("%s called for empty POWERSET", max_min ? "MAX" : "MIN"); - i = max_min ? max_val : min_val; - temp = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))); - add_double (i, i_hi, - TREE_INT_CST_LOW (temp), TREE_INT_CST_HIGH (temp), - &i, &i_hi); - temp = build_int_2 (i, i_hi); - TREE_TYPE (temp) = set_base_type; - return temp; - } - else - { - tree parmlist, filename, lineno; - const char *funcname; - - /* set up to call appropriate runtime function */ - if (max_min) - funcname = "__flsetpowerset"; - else - funcname = "__ffsetpowerset"; - - setminval = convert (long_integer_type_node, setminval); - filename = force_addr_of (get_chill_filename()); - lineno = get_chill_linenumber(); - parmlist = tree_cons (NULL_TREE, force_addr_of (expr), - tree_cons (NULL_TREE, powersetlen (expr), - tree_cons (NULL_TREE, setminval, - tree_cons (NULL_TREE, filename, - build_tree_list (NULL_TREE, lineno))))); - temp = lookup_name (get_identifier (funcname)); - temp = build_chill_function_call (temp, parmlist); - TREE_TYPE (temp) = set_base_type; - return temp; - } - } - return NULL_TREE; -} - - -/* Compute the current runtime maximum value of the powerset - */ -tree -build_chill_max (expr) - tree expr; -{ - return build_max_min (expr, 1); -} - - -/* Compute the current runtime minimum value of the powerset - */ -tree -build_chill_min (expr) - tree expr; -{ - return build_max_min (expr, 0); -} - - -/* Build a conversion from the given expression to an INT, - * but only when the expression's type is the same size as - * an INT. - */ -tree -build_chill_num (expr) - tree expr; -{ - if (pass == 2) - { - tree temp; - int need_unsigned; - - if (expr == NULL_TREE || TREE_CODE(expr) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (expr) == IDENTIFIER_NODE) - expr = lookup_name (expr); - - expr = convert_to_discrete (expr); - if (expr == NULL_TREE) - { - error ("argument to NUM is not discrete"); - return error_mark_node; - } - - /* enumeral types and string slices of length 1 must be kept unsigned */ - need_unsigned = (TREE_CODE (TREE_TYPE (expr)) == ENUMERAL_TYPE) - || TREE_UNSIGNED (TREE_TYPE (expr)); - - temp = type_for_size (TYPE_PRECISION (TREE_TYPE (expr)), - need_unsigned); - if (temp == NULL_TREE) - { - error ("No integer mode which matches expression's mode"); - return integer_zero_node; - } - temp = convert (temp, expr); - - if (TREE_CONSTANT (temp)) - { - if (tree_int_cst_lt (temp, - TYPE_MIN_VALUE (TREE_TYPE (temp)))) - error ("NUM's parameter is below its mode range"); - if (tree_int_cst_lt (TYPE_MAX_VALUE (TREE_TYPE (temp)), - temp)) - error ("NUM's parameter is above its mode range"); - } -#if 0 - else - { - if (range_checking) - cond_overflow_exception (temp, - TYPE_MIN_VALUE (TREE_TYPE (temp)), - TYPE_MAX_VALUE (TREE_TYPE (temp))); - } -#endif - - /* NUM delivers the INT derived class */ - CH_DERIVED_FLAG (temp) = 1; - - return temp; - } - return NULL_TREE; -} - - -static tree -build_chill_pred_or_succ (expr, op) - tree expr; - enum tree_code op; /* PLUS_EXPR for SUCC; MINUS_EXPR for PRED. */ -{ - struct ch_class class; - tree etype, cond; - - if (pass == 1) - return NULL_TREE; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - /* disallow numbered SETs */ - if (TREE_CODE (TREE_TYPE (expr)) == ENUMERAL_TYPE - && CH_ENUM_IS_NUMBERED (TREE_TYPE (expr))) - { - error ("Cannot take SUCC or PRED of a numbered SET"); - return error_mark_node; - } - - if (TREE_CODE (TREE_TYPE (expr)) == POINTER_TYPE) - { - if (TREE_TYPE (TREE_TYPE (expr)) == void_type_node) - { - error ("SUCC or PRED must not be done on a PTR."); - return error_mark_node; - } - pedwarn ("SUCC or PRED for a reference type is not standard."); - return fold (build (op, TREE_TYPE (expr), - expr, - size_in_bytes (TREE_TYPE (TREE_TYPE (expr))))); - } - - expr = convert_to_discrete (expr); - - if (expr == NULL_TREE) - { - error ("SUCC or PRED argument must be a discrete mode"); - return error_mark_node; - } - - class = chill_expr_class (expr); - if (class.mode) - class.mode = CH_ROOT_MODE (class.mode); - etype = class.mode; - expr = convert (etype, expr); - - /* Exception if expression is already at the - min (PRED)/max(SUCC) valid value for its type. */ - cond = fold (build (op == PLUS_EXPR ? GE_EXPR : LE_EXPR, - boolean_type_node, - expr, - convert (etype, - op == PLUS_EXPR ? TYPE_MAX_VALUE (etype) - : TYPE_MIN_VALUE (etype)))); - if (TREE_CODE (cond) == INTEGER_CST - && tree_int_cst_equal (cond, integer_one_node)) - { - error ("Taking the %s of a value already at its %s value", - op == PLUS_EXPR ? "SUCC" : "PRED", - op == PLUS_EXPR ? "maximum" : "minimum"); - return error_mark_node; - } - - if (range_checking) - expr = check_expression (expr, cond, - ridpointers[(int) RID_OVERFLOW]); - - expr = fold (build (op, etype, expr, - convert (etype, integer_one_node))); - return convert_to_class (class, expr); -} - -/* Compute the value of the CHILL `size' operator just - * like the C 'sizeof' operator (code stolen from c-typeck.c) - * TYPE may be a location or mode tree. In pass 1, we build - * a function-call syntax tree; in pass 2, we evaluate it. - */ -tree -build_chill_sizeof (type) - tree type; -{ - if (pass == 2) - { - tree temp; - struct ch_class class; - enum tree_code code; - tree signame = NULL_TREE; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (type) == IDENTIFIER_NODE) - type = lookup_name (type); - - code = TREE_CODE (type); - if (code == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') - { - if (TREE_CODE (type) == TYPE_DECL && CH_DECL_SIGNAL (type)) - signame = DECL_NAME (type); - type = TREE_TYPE (type); - } - - if (code == FUNCTION_TYPE) - { - if (pedantic || warn_pointer_arith) - pedwarn ("size applied to a function mode"); - return error_mark_node; - } - if (code == VOID_TYPE) - { - if (pedantic || warn_pointer_arith) - pedwarn ("sizeof applied to a void mode"); - return error_mark_node; - } - if (TYPE_SIZE (type) == 0) - { - error ("sizeof applied to an incomplete mode"); - return error_mark_node; - } - - temp = size_binop (CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type), - size_int (TYPE_PRECISION (char_type_node) - / BITS_PER_UNIT)); - if (signame != NULL_TREE) - { - /* we have a signal definition. This signal may have no - data items specified. The definition however says that - there are data, cause we cannot build a structure without - fields. In this case return 0. */ - if (IDENTIFIER_SIGNAL_DATA (signame) == 0) - temp = integer_zero_node; - } - - /* FIXME: should call - * cond_type_range_exception (temp); - */ - class.kind = CH_DERIVED_CLASS; - class.mode = integer_type_node; - return convert_to_class (class, temp); - } - return NULL_TREE; -} - -/* Compute the declared maximum value of the variable, - * expression or declared type - */ -tree -build_chill_upper (what) - tree what; -{ - return build_chill_lower_or_upper (what, 1); -} - -/* - * Here at the site of a function/procedure call.. We need to build - * temps for the INOUT and OUT parameters, and copy the actual parameters - * into the temps. After the call, we 'copy back' the values from the - * temps to the actual parameter variables. This somewhat verbose pol- - * icy meets the requirement that the actual parameters are undisturbed - * if the function/procedure causes an exception. They are updated only - * upon a normal return from the function. - * - * Note: the expr_list, which collects all of the above assignments, etc, - * is built in REVERSE execution order. The list is corrected by nreverse - * inside the build_chill_compound_expr call. - */ -tree -build_chill_function_call (function, expr) - tree function, expr; -{ - register tree typetail, valtail, typelist; - register tree temp, actual_args = NULL_TREE; - tree name = NULL_TREE; - tree function_call; - tree fntype; - int parmno = 1; /* parameter number for error message */ - int callee_raise_exception = 0; - - /* list of assignments to run after the actual call, - copying from the temps back to the user's variables. */ - tree copy_back = NULL_TREE; - - /* list of expressions to run before the call, copying from - the user's variable to the temps that are passed to the function */ - tree expr_list = NULL_TREE; - - if (function == NULL_TREE || TREE_CODE (function) == ERROR_MARK) - return error_mark_node; - - if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - if (pass < 2) - return error_mark_node; - - fntype = TREE_TYPE (function); - if (TREE_CODE (function) == FUNCTION_DECL) - { - callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE; - - /* Differs from default_conversion by not setting TREE_ADDRESSABLE - (because calling an inline function does not mean the function - needs to be separately compiled). */ - fntype = build_type_variant (fntype, - TREE_READONLY (function), - TREE_THIS_VOLATILE (function)); - name = DECL_NAME (function); - - /* check that function is not a PROCESS */ - if (CH_DECL_PROCESS (function)) - { - error ("cannot call a PROCESS, you START a PROCESS"); - return error_mark_node; - } - - function = build1 (ADDR_EXPR, build_pointer_type (fntype), function); - } - else if (TREE_CODE (fntype) == POINTER_TYPE) - { - fntype = TREE_TYPE (fntype); - callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE; - - /* Z.200 6.7 Call Action: - "A procedure call causes the EMPTY exception if the - procedure primitive value delivers NULL. */ - if (TREE_CODE (function) != ADDR_EXPR - || TREE_CODE (TREE_OPERAND (function, 0)) != FUNCTION_DECL) - function = check_non_null (function); - } - - typelist = TYPE_ARG_TYPES (fntype); - if (callee_raise_exception) - { - /* remove last two arguments from list for subsequent checking. - They will get added automatically after checking */ - int len = list_length (typelist); - int i; - tree newtypelist = NULL_TREE; - tree wrk = typelist; - - for (i = 0; i < len - 3; i++) - { - newtypelist = tree_cons (TREE_PURPOSE (wrk), TREE_VALUE (wrk), newtypelist); - wrk = TREE_CHAIN (wrk); - } - /* add the void_type_node */ - newtypelist = tree_cons (NULL_TREE, void_type_node, newtypelist); - typelist = nreverse (newtypelist); - } - - /* Scan the given expressions and types, producing individual - converted arguments and pushing them on ACTUAL_ARGS in - reverse order. */ - for (valtail = expr, typetail = typelist; - valtail != NULL_TREE && typetail != NULL_TREE; parmno++, - valtail = TREE_CHAIN (valtail), typetail = TREE_CHAIN (typetail)) - { - register tree actual = TREE_VALUE (valtail); - register tree attr = TREE_PURPOSE (typetail) - ? TREE_PURPOSE (typetail) : ridpointers[(int) RID_IN]; - register tree type = TREE_VALUE (typetail); - char place[30]; - sprintf (place, "parameter %d", parmno); - - /* if we have reached void_type_node in typelist we are at the - end of formal parameters and then we have too many actual - parameters */ - if (type == void_type_node) - break; - - /* check if actual is a TYPE_DECL. FIXME: what else ? */ - if (TREE_CODE (actual) == TYPE_DECL) - { - error ("invalid %s", place); - actual = error_mark_node; - } - /* INOUT or OUT param to handle? */ - else if (attr == ridpointers[(int) RID_OUT] - || attr == ridpointers[(int)RID_INOUT]) - { - char temp_name[20]; - tree parmtmp; - tree in_actual = NULL_TREE, out_actual; - - /* actual parameter must be a location so we can - build a reference to it */ - if (!CH_LOCATION_P (actual)) - { - error ("%s parameter %d must be a location", - (attr == ridpointers[(int) RID_OUT]) ? - "OUT" : "INOUT", parmno); - continue; - } - if (TYPE_READONLY_PROPERTY (TREE_TYPE (actual)) - || TREE_READONLY (actual)) - { - error ("%s parameter %d is READ-only", - (attr == ridpointers[(int) RID_OUT]) ? - "OUT" : "INOUT", parmno); - continue; - } - - sprintf (temp_name, "PARM_%d_%s", parmno, - (attr == ridpointers[(int)RID_OUT]) ? - "OUT" : "INOUT"); - parmtmp = decl_temp1 (get_unique_identifier (temp_name), - TREE_TYPE (type), 0, NULL_TREE, 0, 0); - /* this temp *must not* be optimized into a register */ - mark_addressable (parmtmp); - - if (attr == ridpointers[(int)RID_INOUT]) - { - tree in_actual = chill_convert_for_assignment (TREE_TYPE (type), - actual, place); - tree tmp = build_chill_modify_expr (parmtmp, in_actual); - expr_list = tree_cons (NULL_TREE, tmp, expr_list); - } - if (in_actual != error_mark_node) - { - /* list of copy back assignments to perform, from the temp - back to the actual parameter */ - out_actual = chill_convert_for_assignment (TREE_TYPE (actual), - parmtmp, place); - copy_back = tree_cons (NULL_TREE, - build_chill_modify_expr (actual, - out_actual), - copy_back); - } - /* we can do this because build_chill_function_type - turned these parameters into REFERENCE_TYPEs. */ - actual = build1 (ADDR_EXPR, type, parmtmp); - } - else if (attr == ridpointers[(int) RID_LOC]) - { - int is_location = chill_location (actual); - if (is_location) - { - if (is_location == 1) - { - error ("LOC actual parameter %d is a non-referable location", - parmno); - actual = error_mark_node; - } - else if (! CH_READ_COMPATIBLE (type, TREE_TYPE (actual))) - { - error ("mode mismatch in parameter %d", parmno); - actual = error_mark_node; - } - else - actual = convert (type, actual); - } - else - { - sprintf (place, "parameter_%d", parmno); - actual = decl_temp1 (get_identifier (place), - TREE_TYPE (type), 0, actual, 0, 0); - actual = convert (type, actual); - } - mark_addressable (actual); - } - else - actual = chill_convert_for_assignment (type, actual, place); - - actual_args = tree_cons (NULL_TREE, actual, actual_args); - } - - if (valtail != 0 && TREE_VALUE (valtail) != void_type_node) - { - if (name) - error ("too many arguments to procedure `%s'", - IDENTIFIER_POINTER (name)); - else - error ("too many arguments to procedure"); - return error_mark_node; - } - else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node) - { - if (name) - error ("too few arguments to procedure `%s'", - IDENTIFIER_POINTER (name)); - else - error ("too few arguments to procedure"); - return error_mark_node; - } - - if (callee_raise_exception) - { - /* add linenumber and filename of the caller as arguments */ - actual_args = tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - actual_args); - actual_args = tree_cons (NULL_TREE, get_chill_linenumber (), actual_args); - } - - function_call = build (CALL_EXPR, TREE_TYPE (fntype), - function, nreverse (actual_args), NULL_TREE); - TREE_SIDE_EFFECTS (function_call) = 1; - - if (copy_back == NULL_TREE && expr_list == NULL_TREE) - return function_call; /* no copying to do, either way */ - else - { - tree result_type = TREE_TYPE (fntype); - tree result_tmp = NULL_TREE; - - /* no result wanted from procedure call */ - if (result_type == NULL_TREE || result_type == void_type_node) - expr_list = tree_cons (NULL_TREE, function_call, expr_list); - else - { - /* create a temp for the function's result. this is so that we can - evaluate this temp as the last expression in the list, which will - make the function's return value the value of the whole list of - expressions (by the C rules for compound expressions) */ - result_tmp = decl_temp1 (get_unique_identifier ("FUNC_RESULT"), - result_type, 0, NULL_TREE, 0, 0); - expr_list = tree_cons (NULL_TREE, - build_chill_modify_expr (result_tmp, function_call), - expr_list); - } - - expr_list = chainon (copy_back, expr_list); - - /* last, but not least, the function's result */ - if (result_tmp != NULL_TREE) - expr_list = tree_cons (NULL_TREE, result_tmp, expr_list); - temp = build_chill_compound_expr (nreverse (expr_list)); - return temp; - } -} - -/* We saw something that looks like a function call, - but if it's pass 1, we're not sure. */ - -tree -build_generalized_call (func, args) - tree func, args; -{ - tree type = TREE_TYPE (func); - - if (pass == 1) - return build (CALL_EXPR, NULL_TREE, func, args, NULL_TREE); - - /* Handle string repetition */ - if (TREE_CODE (func) == INTEGER_CST) - { - if (args == NULL_TREE || TREE_CHAIN (args) != NULL_TREE) - { - error ("syntax error (integer used as function)"); - return error_mark_node; - } - if (TREE_CODE (args) == TREE_LIST) - args = TREE_VALUE (args); - return build_chill_repetition_op (func, args); - } - - if (args != NULL_TREE) - { - if (TREE_CODE (args) == RANGE_EXPR) - { - tree lo = TREE_OPERAND (args, 0), hi = TREE_OPERAND (args, 1); - if (TREE_CODE_CLASS (TREE_CODE (func)) == 't') - return build_chill_range_type (func, lo, hi); - else - return build_chill_slice_with_range (func, lo, hi); - } - else if (TREE_CODE (args) != TREE_LIST) - { - error ("syntax error - missing operator, comma, or '('?"); - return error_mark_node; - } - } - - if (TREE_CODE (func) == TYPE_DECL) - { - if (CH_DECL_SIGNAL (func)) - return build_signal_descriptor (func, args); - func = TREE_TYPE (func); - } - - if (TREE_CODE_CLASS (TREE_CODE (func)) == 't' - && args != NULL_TREE && TREE_CHAIN (args) == NULL_TREE) - return build_chill_cast (func, TREE_VALUE (args)); - - if (TREE_CODE (type) == FUNCTION_TYPE - || (TREE_CODE (type) == POINTER_TYPE - && TREE_TYPE (type) != NULL_TREE - && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)) - { - /* Check for a built-in Chill function. */ - if (TREE_CODE (func) == FUNCTION_DECL - && DECL_BUILT_IN (func) - && DECL_FUNCTION_CODE (func) > END_BUILTINS) - { - tree fnname = DECL_NAME (func); - switch ((enum chill_built_in_function)DECL_FUNCTION_CODE (func)) - { - case BUILT_IN_CH_ABS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_abs (TREE_VALUE (args)); - case BUILT_IN_ABSTIME: - if (check_arglist_length (args, 0, 6, fnname) < 0) - return error_mark_node; - return build_chill_abstime (args); - case BUILT_IN_ADDR: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; -#if 0 - return build_chill_addr_expr (TREE_VALUE (args), (char *)0); -#else - return build_chill_arrow_expr (TREE_VALUE (args), 0); -#endif - case BUILT_IN_ALLOCATE_GLOBAL_MEMORY: - if (check_arglist_length (args, 2, 2, fnname) < 0) - return error_mark_node; - return build_allocate_global_memory_call - (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_ALLOCATE: - if (check_arglist_length (args, 1, 2, fnname) < 0) - return error_mark_node; - return build_chill_allocate (TREE_VALUE (args), - TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_ALLOCATE_MEMORY: - if (check_arglist_length (args, 2, 2, fnname) < 0) - return error_mark_node; - return build_allocate_memory_call - (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_ASSOCIATE: - if (check_arglist_length (args, 2, 3, fnname) < 0) - return error_mark_node; - return build_chill_associate - (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args)), - TREE_CHAIN (TREE_CHAIN (args))); - case BUILT_IN_ARCCOS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__acos"); - case BUILT_IN_ARCSIN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__asin"); - case BUILT_IN_ARCTAN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__atan"); - case BUILT_IN_CARD: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_card (TREE_VALUE (args)); - case BUILT_IN_CONNECT: - if (check_arglist_length (args, 3, 5, fnname) < 0) - return error_mark_node; - return build_chill_connect - (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args)), - TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))), - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))); - case BUILT_IN_COPY_NUMBER: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_copy_number (TREE_VALUE (args)); - case BUILT_IN_CH_COS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__cos"); - case BUILT_IN_CREATE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_create (TREE_VALUE (args)); - case BUILT_IN_DAYS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_duration (TREE_VALUE (args), DAYS_MULTIPLIER, - fnname, DAYS_MAX); - case BUILT_IN_CH_DELETE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_delete (TREE_VALUE (args)); - case BUILT_IN_DESCR: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_descr (TREE_VALUE (args)); - case BUILT_IN_DISCONNECT: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_disconnect (TREE_VALUE (args)); - case BUILT_IN_DISSOCIATE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_dissociate (TREE_VALUE (args)); - case BUILT_IN_EOLN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_eoln (TREE_VALUE (args)); - case BUILT_IN_EXISTING: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_existing (TREE_VALUE (args)); - case BUILT_IN_EXP: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__exp"); - case BUILT_IN_GEN_CODE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_gen_code (TREE_VALUE (args)); - case BUILT_IN_GEN_INST: - if (check_arglist_length (args, 2, 2, fnname) < 0) - return error_mark_node; - return build_gen_inst (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_GEN_PTYPE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_gen_ptype (TREE_VALUE (args)); - case BUILT_IN_GETASSOCIATION: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_getassociation (TREE_VALUE (args)); - case BUILT_IN_GETSTACK: - if (check_arglist_length (args, 1, 2, fnname) < 0) - return error_mark_node; - return build_chill_getstack (TREE_VALUE (args), - TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_GETTEXTACCESS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_gettextaccess (TREE_VALUE (args)); - case BUILT_IN_GETTEXTINDEX: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_gettextindex (TREE_VALUE (args)); - case BUILT_IN_GETTEXTRECORD: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_gettextrecord (TREE_VALUE (args)); - case BUILT_IN_GETUSAGE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_getusage (TREE_VALUE (args)); - case BUILT_IN_HOURS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_duration (TREE_VALUE (args), HOURS_MULTIPLIER, - fnname, HOURS_MAX); - case BUILT_IN_INDEXABLE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_indexable (TREE_VALUE (args)); - case BUILT_IN_INTTIME: - if (check_arglist_length (args, 2, 7, fnname) < 0) - return error_mark_node; - return build_chill_inttime (TREE_VALUE (args), - TREE_CHAIN (args)); - case BUILT_IN_ISASSOCIATED: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_isassociated (TREE_VALUE (args)); - case BUILT_IN_LENGTH: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_length (TREE_VALUE (args)); - case BUILT_IN_LN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__log"); - case BUILT_IN_LOG: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__log10"); - case BUILT_IN_LOWER: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_lower (TREE_VALUE (args)); - case BUILT_IN_MAX: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_max (TREE_VALUE (args)); - case BUILT_IN_MILLISECS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_duration (TREE_VALUE (args), MILLISECS_MULTIPLIER, - fnname, MILLISECS_MAX); - case BUILT_IN_MIN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_min (TREE_VALUE (args)); - case BUILT_IN_MINUTES: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_duration (TREE_VALUE (args), MINUTES_MULTIPLIER, - fnname, MINUTES_MAX); - case BUILT_IN_MODIFY: - if (check_arglist_length (args, 1, -1, fnname) < 0) - return error_mark_node; - return build_chill_modify (TREE_VALUE (args), TREE_CHAIN (args)); - case BUILT_IN_NUM: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_num (TREE_VALUE (args)); - case BUILT_IN_OUTOFFILE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_outoffile (TREE_VALUE (args)); - case BUILT_IN_PRED: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_pred_or_succ (TREE_VALUE (args), MINUS_EXPR); - case BUILT_IN_PROC_TYPE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_proc_type (TREE_VALUE (args)); - case BUILT_IN_QUEUE_LENGTH: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_queue_length (TREE_VALUE (args)); - case BUILT_IN_READABLE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_readable (TREE_VALUE (args)); - case BUILT_IN_READRECORD: - if (check_arglist_length (args, 1, 3, fnname) < 0) - return error_mark_node; - return build_chill_readrecord (TREE_VALUE (args), TREE_CHAIN (args)); - case BUILT_IN_READTEXT: - if (check_arglist_length (args, 2, -1, fnname) < 0) - return error_mark_node; - return build_chill_readtext (TREE_VALUE (args), - TREE_CHAIN (args)); - case BUILT_IN_RETURN_MEMORY: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_return_memory (TREE_VALUE (args)); - case BUILT_IN_SECS: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_duration (TREE_VALUE (args), SECS_MULTIPLIER, - fnname, SECS_MAX); - case BUILT_IN_SEQUENCIBLE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_sequencible (TREE_VALUE (args)); - case BUILT_IN_SETTEXTACCESS: - if (check_arglist_length (args, 2, 2, fnname) < 0) - return error_mark_node; - return build_chill_settextaccess (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_SETTEXTINDEX: - if (check_arglist_length (args, 2, 2, fnname) < 0) - return error_mark_node; - return build_chill_settextindex (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_SETTEXTRECORD: - if (check_arglist_length (args, 2, 2, fnname) < 0) - return error_mark_node; - return build_chill_settextrecord (TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args))); - case BUILT_IN_CH_SIN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__sin"); - case BUILT_IN_SIZE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_sizeof (TREE_VALUE (args)); - case BUILT_IN_SQRT: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__sqrt"); - case BUILT_IN_SUCC: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_pred_or_succ (TREE_VALUE (args), PLUS_EXPR); - case BUILT_IN_TAN: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_floatcall (TREE_VALUE (args), - IDENTIFIER_POINTER (fnname), - "__tan"); - case BUILT_IN_TERMINATE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_terminate (TREE_VALUE (args)); - case BUILT_IN_UPPER: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_upper (TREE_VALUE (args)); - case BUILT_IN_VARIABLE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_variable (TREE_VALUE (args)); - case BUILT_IN_WRITEABLE: - if (check_arglist_length (args, 1, 1, fnname) < 0) - return error_mark_node; - return build_chill_writeable (TREE_VALUE (args)); - case BUILT_IN_WRITERECORD: - if (check_arglist_length (args, 2, 3, fnname) < 0) - return error_mark_node; - return build_chill_writerecord (TREE_VALUE (args), TREE_CHAIN (args)); - case BUILT_IN_WRITETEXT: - if (check_arglist_length (args, 2, -1, fnname) < 0) - return error_mark_node; - return build_chill_writetext (TREE_VALUE (args), - TREE_CHAIN (args)); - - case BUILT_IN_EXPIRED: - case BUILT_IN_WAIT: - sorry ("unimplemented builtin function `%s'", - IDENTIFIER_POINTER (fnname)); - break; - default: - error ("internal error - bad builtin function `%s'", - IDENTIFIER_POINTER (fnname)); - } - } - return build_chill_function_call (func, args); - } - - if (chill_varying_type_p (TREE_TYPE (func))) - type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); - - if (CH_STRING_TYPE_P (type)) - { - if (args == NULL_TREE) - { - error ("empty expression in string index"); - return error_mark_node; - } - if (TREE_CHAIN (args) != NULL) - { - error ("only one expression allowed in string index"); - return error_mark_node; - } - if (flag_old_strings) - return build_chill_slice_with_length (func, - TREE_VALUE (args), - integer_one_node); - else if (CH_BOOLS_TYPE_P (type)) - return build_chill_bitref (func, args); - else - return build_chill_array_ref (func, args); - } - - else if (TREE_CODE (type) == ARRAY_TYPE) - return build_chill_array_ref (func, args); - - if (TREE_CODE (func) != ERROR_MARK) - error ("invalid: primval ( untyped_exprlist )"); - return error_mark_node; -} - -/* Given a set stored as one bit per char (in BUFFER[0 .. BIT_SIZE-1]), - return a CONTRUCTOR, of type TYPE (a SET_TYPE). */ -static tree -expand_packed_set (buffer, bit_size, type) - const char *buffer; - int bit_size; - tree type; -{ - /* The ordinal number corresponding to the first stored bit. */ - HOST_WIDE_INT first_bit_no = - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (type))); - tree list = NULL_TREE; - int i; - - for (i = 0; i < bit_size; i++) - if (buffer[i]) - { - int next_0; - for (next_0 = i + 1; - next_0 < bit_size && buffer[next_0]; next_0++) - ; - if (next_0 == i + 1) - list = tree_cons (NULL_TREE, - build_int_2 (i + first_bit_no, 0), list); - else - { - list = tree_cons (build_int_2 (i + first_bit_no, 0), - build_int_2 (next_0 - 1 + first_bit_no, 0), list); - /* advance i past the range of 1-bits */ - i = next_0; - } - } - list = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list)); - TREE_CONSTANT (list) = 1; - return list; -} - -/* - * fold a set represented as a CONSTRUCTOR list. - * An empty set has a NULL_TREE in its TREE_OPERAND (set, 1) slot. - */ -static tree -fold_set_expr (code, op0, op1) - enum chill_tree_code code; - tree op0, op1; -{ - tree temp; - char *buffer0, *buffer1 = NULL, *bufferr; - int i, size0, size1, first_unused_bit; - - if (! TREE_CONSTANT (op0) || TREE_CODE (op0) != CONSTRUCTOR) - return NULL_TREE; - - if (op1 - && (! TREE_CONSTANT (op1) || TREE_CODE (op1) != CONSTRUCTOR)) - return NULL_TREE; - - size0 = int_size_in_bytes (TREE_TYPE (op0)) * BITS_PER_UNIT; - if (size0 < 0) - { - error ("operand is variable-size bitstring/power-set"); - return error_mark_node; - } - buffer0 = (char*) alloca (size0); - - temp = get_set_constructor_bits (op0, buffer0, size0); - if (temp) - return NULL_TREE; - - if (op0 && op1) - { - size1 = int_size_in_bytes (TREE_TYPE (op1)) * BITS_PER_UNIT; - if (size1 < 0) - { - error ("operand is variable-size bitstring/power-set"); - return error_mark_node; - } - if (size0 != size1) - return NULL_TREE; - buffer1 = (char*) alloca (size1); - temp = get_set_constructor_bits (op1, buffer1, size1); - if (temp) - return NULL_TREE; - } - - bufferr = (char*) alloca (size0); /* result buffer */ - - switch ((int)code) - { - case SET_NOT_EXPR: - case BIT_NOT_EXPR: - for (i = 0; i < size0; i++) - bufferr[i] = 1 & ~buffer0[i]; - goto build_result; - case SET_AND_EXPR: - case BIT_AND_EXPR: - for (i = 0; i < size0; i++) - bufferr[i] = buffer0[i] & buffer1[i]; - goto build_result; - case SET_IOR_EXPR: - case BIT_IOR_EXPR: - for (i = 0; i < size0; i++) - bufferr[i] = buffer0[i] | buffer1[i]; - goto build_result; - case SET_XOR_EXPR: - case BIT_XOR_EXPR: - for (i = 0; i < size0; i++) - bufferr[i] = (buffer0[i] ^ buffer1[i]) & 1; - goto build_result; - case SET_DIFF_EXPR: - case MINUS_EXPR: - for (i = 0; i < size0; i++) - bufferr[i] = buffer0[i] & ~buffer1[i]; - goto build_result; - build_result: - /* mask out unused bits. Same as runtime library does. */ - first_unused_bit = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (op0)))) - - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (op0)))) + 1; - for (i = first_unused_bit; i < size0 ; i++) - bufferr[i] = 0; - return expand_packed_set (bufferr, size0, TREE_TYPE (op0)); - case EQ_EXPR: - for (i = 0; i < size0; i++) - if (buffer0[i] != buffer1[i]) - return boolean_false_node; - return boolean_true_node; - - case NE_EXPR: - for (i = 0; i < size0; i++) - if (buffer0[i] != buffer1[i]) - return boolean_true_node; - return boolean_false_node; - - default: - return NULL_TREE; - } -} - -/* - * build a set or bit-array expression. Type-checking is - * done elsewhere. - */ -static tree -build_compare_set_expr (code, op0, op1) - enum tree_code code; - tree op0, op1; -{ - tree result_type = NULL_TREE; - const char *fnname; - tree x; - - /* These conversions are needed if -fold-strings. */ - if (TREE_CODE (TREE_TYPE (op0)) == BOOLEAN_TYPE) - { - if (CH_BOOLS_ONE_P (TREE_TYPE (op1))) - return build_compare_discrete_expr (code, - op0, - convert (boolean_type_node, op1)); - else - op0 = convert (bitstring_one_type_node, op0); - } - if (TREE_CODE (TREE_TYPE (op1)) == BOOLEAN_TYPE) - { - if (CH_BOOLS_ONE_P (TREE_TYPE (op0))) - return build_compare_discrete_expr (code, - convert (boolean_type_node, op0), - op1); - else - op1 = convert (bitstring_one_type_node, op1); - } - - switch ((int)code) - { - case EQ_EXPR: - { - tree temp = fold_set_expr (EQ_EXPR, op0, op1); - if (temp) - return temp; - fnname = "__eqpowerset"; - goto compare_powerset; - } - break; - - case GE_EXPR: - /* switch operands and fall thru */ - x = op0; - op0 = op1; - op1 = x; - - case LE_EXPR: - fnname = "__lepowerset"; - goto compare_powerset; - - case GT_EXPR: - /* switch operands and fall thru */ - x = op0; - op0 = op1; - op1 = x; - - case LT_EXPR: - fnname = "__ltpowerset"; - goto compare_powerset; - - case NE_EXPR: - return invert_truthvalue (build_compare_set_expr (EQ_EXPR, op0, op1)); - - compare_powerset: - { - tree tsize = powersetlen (op0); - - if (TREE_CODE (TREE_TYPE (op0)) != SET_TYPE) - tsize = fold (build (MULT_EXPR, sizetype, tsize, - size_int (BITS_PER_UNIT))); - - return build_chill_function_call (lookup_name (get_identifier (fnname)), - tree_cons (NULL_TREE, force_addr_of (op0), - tree_cons (NULL_TREE, force_addr_of (op1), - tree_cons (NULL_TREE, tsize, NULL_TREE)))); - } - break; - - default: - if ((int) code >= (int)LAST_AND_UNUSED_TREE_CODE) - { - error ("tree code `%s' unhandled in build_compare_set_expr", - tree_code_name[(int)code]); - return error_mark_node; - } - break; - } - - return build ((enum tree_code)code, result_type, - op0, op1); -} - -/* Convert a varying string (or array) to dynamic non-varying string: - EXP becomes EXP.var_data(0 UP EXP.var_length). */ - -tree -varying_to_slice (exp) - tree exp; -{ - if (!chill_varying_type_p (TREE_TYPE (exp))) - return exp; - else - { tree size, data, data_domain, min; - tree novelty = CH_NOVELTY (TREE_TYPE (exp)); - exp = save_if_needed (exp); - size = build_component_ref (exp, var_length_id); - data = build_component_ref (exp, var_data_id); - TREE_TYPE (data) = copy_novelty (novelty, TREE_TYPE (data)); - data_domain = TYPE_DOMAIN (TREE_TYPE (data)); - if (data_domain != NULL_TREE - && TYPE_MIN_VALUE (data_domain) != NULL_TREE) - min = TYPE_MIN_VALUE (data_domain); - else - min = integer_zero_node; - return build_chill_slice (data, min, size); - } -} - -/* Convert a scalar argument to a string or array type. This is a subroutine - of `build_concat_expr'. */ - -static tree -scalar_to_string (exp) - tree exp; -{ - tree type = TREE_TYPE (exp); - - if (SCALAR_P (type)) - { - int was_const = TREE_CONSTANT (exp); - if (TREE_TYPE (exp) == char_type_node) - exp = convert (string_one_type_node, exp); - else if (TREE_TYPE (exp) == boolean_type_node) - exp = convert (bitstring_one_type_node, exp); - else - exp = convert (build_array_type_for_scalar (type), exp); - TREE_CONSTANT (exp) = was_const; - return exp; - } - return varying_to_slice (exp); -} - -/* FIXME: Generalize this to general arrays (not just strings), - at least for the compiler-generated case of padding fixed-length arrays. */ - -static tree -build_concat_expr (op0, op1) - tree op0, op1; -{ - tree orig_op0 = op0, orig_op1 = op1; - tree type0, type1, size0, size1, res; - - op0 = scalar_to_string (op0); - type0 = TREE_TYPE (op0); - op1 = scalar_to_string (op1); - type1 = TREE_TYPE (op1); - size1 = size_in_bytes (type1); - - /* try to fold constant string literals */ - if (TREE_CODE (op0) == STRING_CST - && (TREE_CODE (op1) == STRING_CST - || TREE_CODE (op1) == UNDEFINED_EXPR) - && TREE_CODE (size1) == INTEGER_CST) - { - int len0 = TREE_STRING_LENGTH (op0); - int len1 = TREE_INT_CST_LOW (size1); - char *result = xmalloc (len0 + len1 + 1); - memcpy (result, TREE_STRING_POINTER (op0), len0); - if (TREE_CODE (op1) == UNDEFINED_EXPR) - memset (&result[len0], '\0', len1); - else - memcpy (&result[len0], TREE_STRING_POINTER (op1), len1); - return build_chill_string (len0 + len1, result); - } - else if (TREE_CODE (type0) == TREE_CODE (type1)) - { - tree result_size; - struct ch_class result_class; - struct ch_class class0; - struct ch_class class1; - - class0 = chill_expr_class (orig_op0); - class1 = chill_expr_class (orig_op1); - - if (TREE_CODE (type0) == SET_TYPE) - { - result_size = fold (build (PLUS_EXPR, integer_type_node, - discrete_count (TYPE_DOMAIN (type0)), - discrete_count (TYPE_DOMAIN (type1)))); - result_class.mode = build_bitstring_type (result_size); - } - else - { - tree max0 = TYPE_MAX_VALUE (type0); - tree max1 = TYPE_MAX_VALUE (type1); - - /* new array's dynamic size (in bytes). */ - size0 = size_in_bytes (type0); - /* size1 was computed above. */ - - result_size = size_binop (PLUS_EXPR, size0, size1); - /* new array's type. */ - result_class.mode = build_string_type (char_type_node, result_size); - - if (max0 || max1) - { - max0 = max0 == 0 ? size0 : convert (sizetype, max0); - max1 = max1 == 0 ? size1 : convert (sizetype, max1); - TYPE_MAX_VALUE (result_class.mode) - = size_binop (PLUS_EXPR, max0, max1); - } - } - - if (class0.kind == CH_VALUE_CLASS || class1.kind == CH_VALUE_CLASS) - { - tree novelty0 = CH_NOVELTY (TREE_TYPE (orig_op0)); - result_class.kind = CH_VALUE_CLASS; - if (class0.kind == CH_VALUE_CLASS && novelty0 != NULL_TREE) - SET_CH_NOVELTY_NONNIL (result_class.mode, novelty0); - else if (class1.kind == CH_VALUE_CLASS) - SET_CH_NOVELTY (result_class.mode, - CH_NOVELTY (TREE_TYPE (orig_op1))); - } - else - result_class.kind = CH_DERIVED_CLASS; - - if (TREE_CODE (result_class.mode) == SET_TYPE - && TREE_CONSTANT (op0) && TREE_CONSTANT (op1) - && TREE_CODE (op0) == CONSTRUCTOR && TREE_CODE (op1) == CONSTRUCTOR) - { - HOST_WIDE_INT size0, size1; char *buffer; - size0 = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type0))) + 1; - size1 = TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type1))) + 1; - buffer = (char*) alloca (size0 + size1); - if (size0 < 0 || size1 < 0 - || get_set_constructor_bits (op0, buffer, size0) - || get_set_constructor_bits (op1, buffer + size0, size1)) - abort (); - res = expand_packed_set (buffer, size0 + size1, result_class.mode); - } - else - res = build (CONCAT_EXPR, result_class.mode, op0, op1); - return convert_to_class (result_class, res); - } - else - { - error ("incompatible modes in concat expression"); - return error_mark_node; - } -} - -/* - * handle varying and fixed array compare operations - */ -static tree -build_compare_string_expr (code, op0, op1) - enum tree_code code; - tree op0, op1; -{ - if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK) - return error_mark_node; - if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK) - return error_mark_node; - - if (tree_int_cst_equal (TYPE_SIZE (TREE_TYPE (op0)), - TYPE_SIZE (TREE_TYPE (op1))) - && ! chill_varying_type_p (TREE_TYPE (op0)) - && ! chill_varying_type_p (TREE_TYPE (op1))) - { - tree size = size_in_bytes (TREE_TYPE (op0)); - tree temp = lookup_name (get_identifier ("memcmp")); - temp = build_chill_function_call (temp, - tree_cons (NULL_TREE, force_addr_of (op0), - tree_cons (NULL_TREE, force_addr_of (op1), - tree_cons (NULL_TREE, size, NULL_TREE)))); - return build_compare_discrete_expr (code, temp, integer_zero_node); - } - - switch ((int)code) - { - case EQ_EXPR: - code = STRING_EQ_EXPR; - break; - case GE_EXPR: - return invert_truthvalue (build_compare_string_expr (LT_EXPR, op0, op1)); - case LE_EXPR: - return invert_truthvalue (build_compare_string_expr (LT_EXPR, op1, op0)); - case GT_EXPR: - return build_compare_string_expr (LT_EXPR, op1, op0); - case LT_EXPR: - code = STRING_LT_EXPR; - break; - case NE_EXPR: - return invert_truthvalue (build_compare_string_expr (EQ_EXPR, op0, op1)); - default: - error ("Invalid operation on array of chars"); - return error_mark_node; - } - - return build (code, boolean_type_node, op0, op1); -} - -static tree -compare_records (exp0, exp1) - tree exp0, exp1; -{ - tree type = TREE_TYPE (exp0); - tree field; - int have_variants = 0; - - tree result = boolean_true_node; - - if (TREE_CODE (type) != RECORD_TYPE) - abort (); - - exp0 = save_if_needed (exp0); - exp1 = save_if_needed (exp1); - - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - { - if (DECL_NAME (field) == NULL_TREE) - { - have_variants = 1; - break; - } - } - - /* in case of -fpack we always do a memcmp */ - if (maximum_field_alignment != 0) - { - tree memcmp_func = lookup_name (get_identifier ("memcmp")); - tree arg1 = force_addr_of (exp0); - tree arg2 = force_addr_of (exp1); - tree arg3 = size_in_bytes (type); - tree fcall = build_chill_function_call (memcmp_func, - tree_cons (NULL_TREE, arg1, - tree_cons (NULL_TREE, arg2, - tree_cons (NULL_TREE, arg3, NULL_TREE)))); - - if (have_variants) - warning ("comparison of variant structures is unsafe"); - result = build_chill_binary_op (EQ_EXPR, fcall, integer_zero_node); - return result; - } - - if (have_variants) - { - sorry ("compare with variant records"); - return error_mark_node; - } - - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - { - tree exp0fld = build_component_ref (exp0, DECL_NAME (field)); - tree exp1fld = build_component_ref (exp1, DECL_NAME (field)); - tree eq_flds = build_chill_binary_op (EQ_EXPR, exp0fld, exp1fld); - result = build_chill_binary_op (TRUTH_AND_EXPR, result, eq_flds); - } - return result; -} - -int -compare_int_csts (op, val1, val2) - enum tree_code op; - tree val1, val2; -{ - int result; - tree tmp; - tree type1 = TREE_TYPE (val1); - tree type2 = TREE_TYPE (val2); - switch (op) - { - case GT_EXPR: - case GE_EXPR: - tmp = val1; val1 = val2; val2 = tmp; - tmp = type1; type1 = type2; type2 = tmp; - op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR; - /* ... fall through ... */ - case LT_EXPR: - case LE_EXPR: - if (!TREE_UNSIGNED (type1)) - { - if (!TREE_UNSIGNED (type2)) - result = INT_CST_LT (val1, val2); - else if (TREE_INT_CST_HIGH (val1) < 0) - result = 1; - else - result = INT_CST_LT_UNSIGNED (val1, val2); - } - else - { - if (!TREE_UNSIGNED (type2) && TREE_INT_CST_HIGH (val2) < 0) - result = 0; - else - result = INT_CST_LT_UNSIGNED (val1, val2); - } - if (op == LT_EXPR || result == 1) - break; - /* else fall through ... */ - case NE_EXPR: - case EQ_EXPR: - if (TREE_INT_CST_LOW (val1) == TREE_INT_CST_LOW (val2) - && TREE_INT_CST_HIGH (val1) == TREE_INT_CST_HIGH (val2) - /* They're bitwise equal. - Check for one being negative and the other unsigned. */ - && (TREE_INT_CST_HIGH (val2) >= 0 - || TREE_UNSIGNED (TREE_TYPE (val1)) - == TREE_UNSIGNED (TREE_TYPE (val2)))) - result = 1; - else - result = 0; - if (op == NE_EXPR) - result = !result; - break; - default: - abort(); - } - return result; -} - -/* Build an expression to compare discrete values VAL1 and VAL2. - This does not check that they are discrete, nor that they are - compatible; if you need such checks use build_compare_expr. */ - -tree -build_compare_discrete_expr (op, val1, val2) - enum tree_code op; - tree val1, val2; -{ - tree type1 = TREE_TYPE (val1); - tree type2 = TREE_TYPE (val2); - tree tmp; - - if (TREE_CODE (val1) == INTEGER_CST && TREE_CODE (val2) == INTEGER_CST) - { - if (compare_int_csts (op, val1, val2)) - return boolean_true_node; - else - return boolean_false_node; - } - - if (TREE_UNSIGNED (type1) != TREE_UNSIGNED (type2)) - { - switch (op) - { - case GT_EXPR: - case GE_EXPR: - tmp = val1; val1 = val2; val2 = tmp; - tmp = type1; type1 = type2; type2 = tmp; - op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR; - /* ... fall through ... */ - case LT_EXPR: - case LE_EXPR: - if (TREE_UNSIGNED (type2)) - { - tmp = build_int_2_wide (0, 0); - TREE_TYPE (tmp) = type1; - val1 = save_expr (val1); - tmp = fold (build (LT_EXPR, boolean_type_node, val1, tmp)); - if (TYPE_PRECISION (type2) < TYPE_PRECISION (type1)) - { - type2 = unsigned_type (type1); - val2 = convert_to_integer (type2, val2); - } - val1 = convert_to_integer (type2, val1); - return fold (build (TRUTH_OR_EXPR, boolean_type_node, - tmp, - fold (build (op, boolean_type_node, - val1, val2)))); - } - unsigned_vs_signed: /* val1 is unsigned, val2 is signed */ - tmp = build_int_2_wide (0, 0); - TREE_TYPE (tmp) = type2; - val2 = save_expr (val2); - tmp = fold (build (GE_EXPR, boolean_type_node, val2, tmp)); - if (TYPE_PRECISION (type1) < TYPE_PRECISION (type2)) - { - type1 = unsigned_type (type2); - val1 = convert_to_integer (type1, val1); - } - val2 = convert_to_integer (type1, val2); - return fold (build (TRUTH_AND_EXPR, boolean_type_node, tmp, - fold (build (op, boolean_type_node, - val1, val2)))); - case EQ_EXPR: - if (TREE_UNSIGNED (val2)) - { - tmp = val1; val1 = val2; val2 = tmp; - tmp = type1; type1 = type2; type2 = tmp; - } - goto unsigned_vs_signed; - case NE_EXPR: - tmp = build_compare_expr (EQ_EXPR, val1, val2); - return build_chill_unary_op (TRUTH_NOT_EXPR, tmp); - default: - abort(); - } - } - if (TYPE_PRECISION (type1) > TYPE_PRECISION (type2)) - val2 = convert (type1, val2); - else if (TYPE_PRECISION (type1) < TYPE_PRECISION (type2)) - val1 = convert (type2, val1); - return fold (build (op, boolean_type_node, val1, val2)); -} - -tree -build_compare_expr (op, val1, val2) - enum tree_code op; - tree val1, val2; -{ - tree tmp; - tree type1, type2; - val1 = check_have_mode (val1, "relational expression"); - val2 = check_have_mode (val2, "relational expression"); - if (val1 == NULL_TREE || TREE_CODE (val1) == ERROR_MARK) - return error_mark_node; - if (val2 == NULL_TREE || TREE_CODE (val2) == ERROR_MARK) - return error_mark_node; - - if (pass == 1) - return build (op, NULL_TREE, val1, val2); - - if (!CH_COMPATIBLE_CLASSES (val1, val2)) - { - error ("incompatible operands to %s", boolean_code_name [op]); - return error_mark_node; - } - - tmp = CH_ROOT_MODE (TREE_TYPE (val1)); - if (tmp != TREE_TYPE (val1)) - val1 = convert (tmp, val1); - tmp = CH_ROOT_MODE (TREE_TYPE (val2)); - if (tmp != TREE_TYPE (val2)) - val2 = convert (tmp, val2); - - type1 = TREE_TYPE (val1); - type2 = TREE_TYPE (val2); - - if (TREE_CODE (type1) == SET_TYPE) - tmp = build_compare_set_expr (op, val1, val2); - - else if (discrete_type_p (type1)) - tmp = build_compare_discrete_expr (op, val1, val2); - - else if (chill_varying_type_p (type1) || chill_varying_type_p (type2) - || (TREE_CODE (type1) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (type1)) == CHAR_TYPE) - || (TREE_CODE (type2) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (type2)) == CHAR_TYPE) ) - tmp = build_compare_string_expr (op, val1, val2); - - else if ((TREE_CODE (type1) == RECORD_TYPE - || TREE_CODE (type2) == RECORD_TYPE) - && (op == EQ_EXPR || op == NE_EXPR)) - { - /* This is for handling INSTANCEs being compared against NULL. */ - if (val1 == null_pointer_node) - val1 = convert (type2, val1); - if (val2 == null_pointer_node) - val2 = convert (type1, val2); - - tmp = compare_records (val1, val2); - if (op == NE_EXPR) - tmp = build_chill_unary_op (TRUTH_NOT_EXPR, tmp); - } - - else if (TREE_CODE (type1) == REAL_TYPE || TREE_CODE (type2) == REAL_TYPE - || (op == EQ_EXPR || op == NE_EXPR)) - { - tmp = build (op, boolean_type_node, val1, val2); - CH_DERIVED_FLAG (tmp) = 1; /* Optimization to avoid copy_node. */ - tmp = fold (tmp); - } - - else - { - error ("relational operator not allowed for this mode"); - return error_mark_node; - } - - if (!CH_DERIVED_FLAG (tmp)) - { - tmp = copy_node (tmp); - CH_DERIVED_FLAG (tmp) = 1; - } - return tmp; -} - -tree -finish_chill_binary_op (node) - tree node; -{ - tree op0 = check_have_mode (TREE_OPERAND (node, 0), "binary expression"); - tree op1 = check_have_mode (TREE_OPERAND (node, 1), "binary expression"); - tree type0 = TREE_TYPE (op0); - tree type1 = TREE_TYPE (op1); - tree folded; - - if (TREE_CODE (op0) == ERROR_MARK || TREE_CODE (op1) == ERROR_MARK) - return error_mark_node; - - if (UNSATISFIED (op0) || UNSATISFIED (op1)) - { - UNSATISFIED_FLAG (node) = 1; - return node; - } -#if 0 - /* assure that both operands have a type */ - if (! type0 && type1) - { - op0 = convert (type1, op0); - type0 = TREE_TYPE (op0); - } - if (! type1 && type0) - { - op1 = convert (type0, op1); - type1 = TREE_TYPE (op1); - } -#endif - UNSATISFIED_FLAG (node) = 0; -#if 0 - - { int op0f = TREE_CODE (op0) == FUNCTION_DECL; - int op1f = TREE_CODE (op1) == FUNCTION_DECL; - if (op0f) - op0 = convert (build_pointer_type (TREE_TYPE (op0)), op0); - if (op1f) - op1 = convert (build_pointer_type (TREE_TYPE (op1)), op1); - if ((op0f || op1f) - && code != EQ_EXPR && code != NE_EXPR) - error ("Cannot use %s operator on PROC mode variable", - tree_code_name[(int)code]); - } - - if (invalid_left_operand (type0, code)) - { - error ("invalid left operand of %s", tree_code_name[(int)code]); - return error_mark_node; - } - if (invalid_right_operand (code, type1)) - { - error ("invalid right operand of %s", tree_code_name[(int)code]); - return error_mark_node; - } -#endif - - switch (TREE_CODE (node)) - { - case CONCAT_EXPR: - return build_concat_expr (op0, op1); - - case REPLICATE_EXPR: - op0 = fold (op0); - if (!TREE_CONSTANT (op0) || !TREE_CONSTANT (op1)) - { - error ("repetition expression must be constant"); - return error_mark_node; - } - else - return build_chill_repetition_op (op0, op1); - - case FLOOR_MOD_EXPR: - case TRUNC_MOD_EXPR: - if (TREE_CODE (type0) != INTEGER_TYPE) - { - error ("left argument to MOD/REM operator must be integral"); - return error_mark_node; - } - if (TREE_CODE (type1) != INTEGER_TYPE) - { - error ("right argument to MOD/REM operator must be integral"); - return error_mark_node; - } - break; - - case MINUS_EXPR: - if (TREE_CODE (type1) == SET_TYPE) - { - tree temp = fold_set_expr (MINUS_EXPR, op0, op1); - - if (temp) - return temp; - if (TYPE_MODE (type1) == BLKmode) - TREE_SET_CODE (node, SET_DIFF_EXPR); - else - { - op1 = build_chill_unary_op (BIT_NOT_EXPR, op1); - TREE_OPERAND (node, 1) = op1; - TREE_SET_CODE (node, BIT_AND_EXPR); - } - } - break; - - case TRUNC_DIV_EXPR: - if (TREE_CODE (type0) == REAL_TYPE || TREE_CODE (type1) == REAL_TYPE) - TREE_SET_CODE (node, RDIV_EXPR); - break; - - case BIT_AND_EXPR: - if (TYPE_MODE (type1) == BLKmode) - TREE_SET_CODE (node, SET_AND_EXPR); - goto fold_set_binop; - case BIT_IOR_EXPR: - if (TYPE_MODE (type1) == BLKmode) - TREE_SET_CODE (node, SET_IOR_EXPR); - goto fold_set_binop; - case BIT_XOR_EXPR: - if (TYPE_MODE (type1) == BLKmode) - TREE_SET_CODE (node, SET_XOR_EXPR); - goto fold_set_binop; - case SET_AND_EXPR: - case SET_IOR_EXPR: - case SET_XOR_EXPR: - case SET_DIFF_EXPR: - fold_set_binop: - if (TREE_CODE (type0) == SET_TYPE) - { - tree temp = fold_set_expr (TREE_CODE (node), op0, op1); - - if (temp) - return temp; - } - break; - - case SET_IN_EXPR: - if (TREE_CODE (type1) != SET_TYPE || CH_BOOLS_TYPE_P (type1)) - { - error ("right operand of IN is not a powerset"); - return error_mark_node; - } - if (!CH_COMPATIBLE (op0, TYPE_DOMAIN (type1))) - { - error ("left operand of IN incompatible with right operand"); - return error_mark_node; - } - type0 = CH_ROOT_MODE (type0); - if (type0 != TREE_TYPE (op0)) - TREE_OPERAND (node, 0) = op0 = convert (type0, op0); - TREE_TYPE (node) = boolean_type_node; - CH_DERIVED_FLAG (node) = 1; - node = fold (node); - if (!CH_DERIVED_FLAG (node)) - { - node = copy_node (node); - CH_DERIVED_FLAG (node) = 1; - } - return node; - case NE_EXPR: - case EQ_EXPR: - case GE_EXPR: - case GT_EXPR: - case LE_EXPR: - case LT_EXPR: - return build_compare_expr (TREE_CODE (node), op0, op1); - default: - ; - } - - if (!CH_COMPATIBLE_CLASSES (op0, op1)) - { - error ("incompatible operands to %s", tree_code_name[(int) TREE_CODE (node)]); - return error_mark_node; - } - - if (TREE_TYPE (node) == NULL_TREE) - { - struct ch_class class; - class = CH_ROOT_RESULTING_CLASS (op0, op1); - TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0); - type0 = TREE_TYPE (op0); - TREE_OPERAND (node, 1) = op1 = convert_to_class (class, op1); - type1 = TREE_TYPE (op1); - TREE_TYPE (node) = class.mode; - folded = convert_to_class (class, fold (node)); - } - else - folded = fold (node); -#if 0 - if (folded == node) - TREE_CONSTANT (folded) = TREE_CONSTANT (op0) & TREE_CONSTANT (op1); -#endif - if (TREE_CODE (node) == TRUNC_DIV_EXPR) - { - if (TREE_CONSTANT (op1)) - { - if (tree_int_cst_equal (op1, integer_zero_node)) - { - error ("division by zero"); - return integer_zero_node; - } - } - else if (range_checking) - { -#if 0 - tree test = - build (EQ_EXPR, boolean_type_node, op1, integer_zero_node); - /* Should this be overflow? */ - folded = check_expression (folded, test, - ridpointers[(int) RID_RANGEFAIL]); -#endif - } - } - return folded; -} - -/* - * This implements the '->' operator, which, like the '&' in C, - * returns a pointer to an object, which has the type of - * pointer-to-that-object. - * - * FORCE is 0 when we're evaluating a user-level syntactic construct, - * and 1 when we're calling from inside the compiler. - */ -tree -build_chill_arrow_expr (ref, force) - tree ref; - int force; -{ - tree addr_type; - tree result; - - if (pass == 1) - { - error ("-> operator not allow in constant expression"); - return error_mark_node; - } - - if (ref == NULL_TREE || TREE_CODE (ref) == ERROR_MARK) - return ref; - - while (TREE_CODE (TREE_TYPE (ref)) == REFERENCE_TYPE) - ref = convert (TREE_TYPE (TREE_TYPE (ref)), ref); - - if (!force && ! CH_LOCATION_P (ref)) - { - if (TREE_CODE (ref) == STRING_CST) - pedwarn ("taking the address of a string literal is non-standard"); - else if (TREE_CODE (TREE_TYPE (ref)) == FUNCTION_TYPE) - pedwarn ("taking the address of a function is non-standard"); - else - { - error ("ADDR requires a LOCATION argument"); - return error_mark_node; - } - /* FIXME: Should we be sure that ref isn't a - function if we're being pedantic? */ - } - - addr_type = build_pointer_type (TREE_TYPE (ref)); - -#if 0 - /* This transformation makes chill_expr_class return CH_VALUE_CLASS - when it should return CH_REFERENCE_CLASS. That could be fixed, - but we probably don't want this transformation anyway. */ - if (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */ - { - tree addr; - while (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */ - ref = TREE_OPERAND (ref, 0); - mark_addressable (ref); - addr = build1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (ref)), ref); - return build1 (NOP_EXPR, /* RETYPE_EXPR */ - addr_type, - addr); - } - else -#endif - { - if (! mark_addressable (ref)) - { - error ("-> expression is not addressable"); - return error_mark_node; - } - result = build1 (ADDR_EXPR, addr_type, ref); - if (staticp (ref) - && ! (TREE_CODE (ref) == FUNCTION_DECL - && DECL_CONTEXT (ref) != 0)) - TREE_CONSTANT (result) = 1; - return result; - } -} - -/* - * This implements the ADDR builtin function, which returns a - * free reference, analogous to the C 'void *'. - */ -tree -build_chill_addr_expr (ref, errormsg) - tree ref; - const char *errormsg; -{ - if (ref == error_mark_node) - return ref; - - if (! CH_LOCATION_P (ref) - && TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE) - { - error ("ADDR parameter must be a LOCATION"); - return error_mark_node; - } - ref = build_chill_arrow_expr (ref, 1); - - if (ref != NULL_TREE && TREE_CODE (ref) != ERROR_MARK) - TREE_TYPE (ref) = ptr_type_node; - else if (errormsg == NULL) - { - error ("possible internal error in build_chill_arrow_expr"); - return error_mark_node; - } - else - { - error ("%s is not addressable", errormsg); - return error_mark_node; - } - return ref; -} - -tree -build_chill_binary_op (code, op0, op1) - enum chill_tree_code code; - tree op0, op1; -{ - register tree result; - - if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK) - return error_mark_node; - if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK) - return error_mark_node; - - result = build (code, NULL_TREE, op0, op1); - - if (pass != 1) - result = finish_chill_binary_op (result); - return result; -} - -/* - * process a string repetition phrase '(' COUNT ')' STRING - */ -static tree -string_char_rep (count, string) - int count; - tree string; -{ - int slen, charindx, repcnt; - char ch; - char *temp; - const char *inp; - char *outp; - tree type; - - if (string == NULL_TREE || TREE_CODE (string) == ERROR_MARK) - return error_mark_node; - - type = TREE_TYPE (string); - slen = int_size_in_bytes (type); - temp = xmalloc (slen * count); - inp = &ch; - outp = temp; - if (TREE_CODE (string) == STRING_CST) - inp = TREE_STRING_POINTER (string); - else /* single character */ - ch = (char)TREE_INT_CST_LOW (string); - - /* copy the string/char COUNT times into the output buffer */ - for (outp = temp, repcnt = 0; repcnt < count; repcnt++) - for (charindx = 0; charindx < slen; charindx++) - *outp++ = inp[charindx]; - return build_chill_string (slen * count, temp); -} - -/* Build a bit-string constant containing with the given LENGTH - containing all ones (if VALUE is true), or all zeros (if VALUE is false). */ - -static tree -build_boring_bitstring (length, value) - long length; - int value; -{ - tree result; - tree list; /* Value of CONSTRUCTOR_ELTS in the result. */ - if (value && length > 0) - list = tree_cons (integer_zero_node, size_int (length - 1), NULL_TREE); - else - list = NULL_TREE; - - result = build (CONSTRUCTOR, - build_bitstring_type (size_int (length)), - NULL_TREE, - list); - TREE_CONSTANT (result) = 1; - CH_DERIVED_FLAG (result) = 1; - return result; -} - -/* - * handle a string repetition, with the syntax: - * ( COUNT ) 'STRING' - * COUNT is required to be constant, positive and folded. - */ -tree -build_chill_repetition_op (count_op, string) - tree count_op; - tree string; -{ - int count; - tree type = TREE_TYPE (string); - - if (TREE_CODE (count_op) != INTEGER_CST) - { - error ("repetition count is not an integer constant"); - return error_mark_node; - } - - count = TREE_INT_CST_LOW (count_op); - - if (count < 0) - { - error ("repetition count < 0"); - return error_mark_node; - } - if (! TREE_CONSTANT (string)) - { - error ("repetition value not constant"); - return error_mark_node; - } - - if (TREE_CODE (string) == STRING_CST) - return string_char_rep (count, string); - - switch ((int)TREE_CODE (type)) - { - case BOOLEAN_TYPE: - if (TREE_CODE (string) == INTEGER_CST) - return build_boring_bitstring (count, TREE_INT_CST_LOW (string)); - error ("bitstring repetition of non-constant boolean"); - return error_mark_node; - - case CHAR_TYPE: - return string_char_rep (count, string); - - case SET_TYPE: - { int i, tree_const = 1; - tree new_list = NULL_TREE; - tree vallist; - tree result; - tree domain = TYPE_DOMAIN (type); - tree orig_length; - HOST_WIDE_INT orig_len; - - if (!CH_BOOLS_TYPE_P (type)) /* cannot replicate a powerset */ - break; - - orig_length = discrete_count (domain); - - if (TREE_CODE (string) != CONSTRUCTOR || !TREE_CONSTANT (string) - || TREE_CODE (orig_length) != INTEGER_CST) - { - error ("string repetition operand is non-constant bitstring"); - return error_mark_node; - } - - - orig_len = TREE_INT_CST_LOW (orig_length); - - /* if the set is empty, this is NULL */ - vallist = TREE_OPERAND (string, 1); - - if (vallist == NULL_TREE) /* No bits are set. */ - return build_boring_bitstring (count * orig_len, 0); - else if (TREE_CHAIN (vallist) == NULL_TREE - && (TREE_PURPOSE (vallist) == NULL_TREE - ? (orig_len == 1 - && tree_int_cst_equal (TYPE_MIN_VALUE (domain), - TREE_VALUE (vallist))) - : (tree_int_cst_equal (TYPE_MIN_VALUE (domain), - TREE_PURPOSE (vallist)) - && tree_int_cst_equal (TYPE_MAX_VALUE (domain), - TREE_VALUE (vallist))))) - return build_boring_bitstring (count * orig_len, 1); - - for (i = 0; i < count; i++) - { - tree origin = build_int_2 (i * orig_len, 0); - tree temp; - - /* scan down the given value list, building - new bit-positions */ - for (temp = vallist; temp; temp = TREE_CHAIN (temp)) - { - tree new_value - = fold (build (PLUS_EXPR, TREE_TYPE (origin), - TREE_VALUE (temp))); - tree new_purpose = NULL_TREE; - - if (! TREE_CONSTANT (TREE_VALUE (temp))) - tree_const = 0; - if (TREE_PURPOSE (temp)) - { - new_purpose = fold (build (PLUS_EXPR, TREE_TYPE (origin), - origin, TREE_PURPOSE (temp))); - if (! TREE_CONSTANT (TREE_PURPOSE (temp))) - tree_const = 0; - } - - new_list = tree_cons (new_purpose, - new_value, new_list); - } - } - result = build (CONSTRUCTOR, - build_bitstring_type (size_int (count * orig_len)), - NULL_TREE, nreverse (new_list)); - TREE_CONSTANT (result) = tree_const; - CH_DERIVED_FLAG (result) = CH_DERIVED_FLAG (string); - return result; - } - - default: - error ("non-char, non-bit string repetition"); - return error_mark_node; - } - return error_mark_node; -} - -tree -finish_chill_unary_op (node) - tree node; -{ - enum chill_tree_code code = TREE_CODE (node); - tree op0 = check_have_mode (TREE_OPERAND (node, 0), "unary expression"); - tree type0 = TREE_TYPE (op0); - struct ch_class class; - - if (TREE_CODE (op0) == ERROR_MARK) - return error_mark_node; - /* The expression codes of the data types of the arguments tell us - whether the arguments are integers, floating, pointers, etc. */ - - if (TREE_CODE (type0) == REFERENCE_TYPE) - { - op0 = convert (TREE_TYPE (type0), op0); - type0 = TREE_TYPE (op0); - } - - if (invalid_right_operand (code, type0)) - { - error ("invalid operand of %s", - tree_code_name[(int)code]); - return error_mark_node; - } - switch ((int)TREE_CODE (type0)) - { - case ARRAY_TYPE: - if (TREE_CODE ( TREE_TYPE (type0)) == BOOLEAN_TYPE) - code = SET_NOT_EXPR; - else - { - error ("right operand of %s is not array of boolean", - tree_code_name[(int)code]); - return error_mark_node; - } - break; - case BOOLEAN_TYPE: - switch ((int)code) - { - case BIT_NOT_EXPR: - case TRUTH_NOT_EXPR: - return invert_truthvalue (truthvalue_conversion (op0)); - - default: - error ("%s operator applied to boolean variable", - tree_code_name[(int)code]); - return error_mark_node; - } - break; - - case SET_TYPE: - switch ((int)code) - { - case BIT_NOT_EXPR: - case NEGATE_EXPR: - { - tree temp = fold_set_expr (BIT_NOT_EXPR, op0, NULL_TREE); - - if (temp) - return temp; - - code = SET_NOT_EXPR; - } - break; - - default: - error ("invalid right operand of %s", tree_code_name[(int)code]); - return error_mark_node; - } - - } - - class = chill_expr_class (op0); - if (class.mode) - class.mode = CH_ROOT_MODE (class.mode); - TREE_SET_CODE (node, code); - TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0); - TREE_TYPE (node) = TREE_TYPE (op0); - - node = convert_to_class (class, fold (node)); - - /* FIXME: should call - * cond_type_range_exception (op0); - */ - return node; -} - -/* op is TRUTH_NOT_EXPR, BIT_NOT_EXPR, or NEGATE_EXPR */ - -tree -build_chill_unary_op (code, op0) - enum chill_tree_code code; - tree op0; -{ - register tree result = NULL_TREE; - - if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK) - return error_mark_node; - - result = build1 (code, NULL_TREE, op0); - - if (pass != 1) - result = finish_chill_unary_op (result); - return result; -} - -tree -truthvalue_conversion (expr) - tree expr; -{ - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - -#if 0 /* what about a LE_EXPR (integer_type, integer_type ) */ - if (TREE_CODE (TREE_TYPE (expr)) != BOOLEAN_TYPE) - error ("non-boolean mode in conditional expression"); -#endif - - switch ((int)TREE_CODE (expr)) - { - /* It is simpler and generates better code to have only TRUTH_*_EXPR - or comparison expressions as truth values at this level. */ -#if 0 - case COMPONENT_REF: - /* A one-bit unsigned bit-field is already acceptable. */ - if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) - && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) - return expr; - break; -#endif - - case EQ_EXPR: - /* It is simpler and generates better code to have only TRUTH_*_EXPR - or comparison expressions as truth values at this level. */ - case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case ERROR_MARK: - return expr; - - case INTEGER_CST: - return integer_zerop (expr) ? boolean_false_node : boolean_true_node; - - case REAL_CST: - return real_zerop (expr) ? boolean_false_node : boolean_true_node; - - case ADDR_EXPR: - if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) - return build (COMPOUND_EXPR, boolean_type_node, - TREE_OPERAND (expr, 0), boolean_true_node); - else - return boolean_true_node; - - case NEGATE_EXPR: - case ABS_EXPR: - case FLOAT_EXPR: - case FFS_EXPR: - /* These don't change whether an object is non-zero or zero. */ - return truthvalue_conversion (TREE_OPERAND (expr, 0)); - - case LROTATE_EXPR: - case RROTATE_EXPR: - /* These don't change whether an object is zero or non-zero, but - we can't ignore them if their second arg has side-effects. */ - if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) - return build (COMPOUND_EXPR, boolean_type_node, TREE_OPERAND (expr, 1), - truthvalue_conversion (TREE_OPERAND (expr, 0))); - else - return truthvalue_conversion (TREE_OPERAND (expr, 0)); - - case COND_EXPR: - /* Distribute the conversion into the arms of a COND_EXPR. */ - return fold (build (COND_EXPR, boolean_type_node, TREE_OPERAND (expr, 0), - truthvalue_conversion (TREE_OPERAND (expr, 1)), - truthvalue_conversion (TREE_OPERAND (expr, 2)))); - - case CONVERT_EXPR: - /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, - since that affects how `default_conversion' will behave. */ - if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE - || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) - break; - /* fall through... */ - case NOP_EXPR: - /* If this is widening the argument, we can ignore it. */ - if (TYPE_PRECISION (TREE_TYPE (expr)) - >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) - return truthvalue_conversion (TREE_OPERAND (expr, 0)); - break; - - case BIT_XOR_EXPR: - case MINUS_EXPR: - /* These can be changed into a comparison of the two objects. */ - if (TREE_TYPE (TREE_OPERAND (expr, 0)) - == TREE_TYPE (TREE_OPERAND (expr, 1))) - return build_chill_binary_op (NE_EXPR, TREE_OPERAND (expr, 0), - TREE_OPERAND (expr, 1)); - return build_chill_binary_op (NE_EXPR, TREE_OPERAND (expr, 0), - fold (build1 (NOP_EXPR, - TREE_TYPE (TREE_OPERAND (expr, 0)), - TREE_OPERAND (expr, 1)))); - } - - return build_chill_binary_op (NE_EXPR, expr, boolean_false_node); -} - - -/* - * return a folded tree for the powerset's length in bits. If a - * non-set is passed, we assume it's an array or boolean bytes. - */ -tree -powersetlen (powerset) - tree powerset; -{ - if (powerset == NULL_TREE || TREE_CODE (powerset) == ERROR_MARK) - return error_mark_node; - - return discrete_count (TYPE_DOMAIN (TREE_TYPE (powerset))); -} diff --git a/gcc/ch/gperf b/gcc/ch/gperf deleted file mode 100644 index c6edb6803b0..00000000000 --- a/gcc/ch/gperf +++ /dev/null @@ -1,166 +0,0 @@ -struct resword { - const char *name; - short token; - enum rid rid; - enum toktype { RESERVED, DIRECTIVE, PREDEF } flags; -}; -extern tree ridpointers []; -#ifdef __GNUC__ -__inline -#endif -static unsigned int hash PARAMS ((const char *, unsigned int)); -#ifdef __GNUC__ -__inline -#endif -struct resword *in_word_set PARAMS ((const char *, unsigned int)); -%% -access, ACCESS, NORID, RESERVED -after, AFTER, NORID, RESERVED -all, ALL, NORID, RESERVED -all_static_off, ALL_STATIC_OFF, NORID, DIRECTIVE -all_static_on, ALL_STATIC_ON, NORID, DIRECTIVE -and, AND, NORID, RESERVED -andif, ANDIF, NORID, RESERVED -array, ARRAY, NORID, RESERVED -asm, ASM_KEYWORD, NORID, RESERVED -assert, ASSERT, NORID, RESERVED -at, AT, NORID, RESERVED -based, BASED, NORID, RESERVED -begin, BEGINTOKEN, NORID, RESERVED -bin, BIN, NORID, RESERVED -bit, BOOLS, RID_BOOLS, PREDEF -body, BODY, NORID, RESERVED -bools, BOOLS, RID_BOOLS, RESERVED -buffer, BUFFER, NORID, RESERVED -buffer_code, IGNORED_DIRECTIVE, NORID, DIRECTIVE -by, BY, NORID, RESERVED -call, CALL, NORID, RESERVED -case, CASE, NORID, RESERVED -cause, CAUSE, NORID, RESERVED -ccitt_os, IGNORED_DIRECTIVE, NORID, DIRECTIVE -chars, CHARS, NORID, RESERVED -context, CONTEXT, NORID, RESERVED -continue, CONTINUE, NORID, RESERVED -cycle, CYCLE, NORID, RESERVED -dcl, DCL, NORID, RESERVED -debug_lines, IGNORED_DIRECTIVE, NORID, DIRECTIVE -debug_symbols, IGNORED_DIRECTIVE, NORID, DIRECTIVE -debug_types, IGNORED_DIRECTIVE, NORID, DIRECTIVE -delay, DELAY, NORID, RESERVED -do, DO, NORID, RESERVED -down, DOWN, NORID, RESERVED -dynamic, DYNAMIC, RID_DYNAMIC, RESERVED -else, ELSE, NORID, RESERVED -elsif, ELSIF, NORID, RESERVED -empty_off, EMPTY_OFF, NORID, DIRECTIVE -empty_on, EMPTY_ON, NORID, DIRECTIVE -end, END, NORID, RESERVED -esac, ESAC, NORID, RESERVED -even, IGNORED_DIRECTIVE, NORID, DIRECTIVE -event, EVENT, NORID, RESERVED -event_code, IGNORED_DIRECTIVE, NORID, DIRECTIVE -ever, EVER, NORID, RESERVED -exceptions, EXCEPTIONS, NORID, RESERVED -exit, EXIT, NORID, RESERVED -extra_const_seg, IGNORED_DIRECTIVE, NORID, DIRECTIVE -far, IGNORED_DIRECTIVE, NORID, DIRECTIVE -fi, FI, NORID, RESERVED -for, FOR, NORID, RESERVED -forbid, FORBID, NORID, RESERVED -general, GENERAL, NORID, RESERVED -generate_all_set_names, IGNORED_DIRECTIVE, NORID, DIRECTIVE -generate_set_names, IGNORED_DIRECTIVE, NORID, DIRECTIVE -goto, GOTO, NORID, RESERVED -grant, GRANT, NORID, RESERVED -grant_file_size, IGNORED_DIRECTIVE, NORID, DIRECTIVE -if, IF, NORID, RESERVED -in, IN, RID_IN, RESERVED -init, INIT, NORID, RESERVED -inline, INLINE, RID_INLINE, RESERVED -inout, PARAMATTR, RID_INOUT, RESERVED -large, IGNORED_DIRECTIVE, NORID, DIRECTIVE -list, IGNORED_DIRECTIVE, NORID, DIRECTIVE -loc, LOC, NORID, RESERVED -make_publics_for_discrete_syns, IGNORED_DIRECTIVE, NORID, DIRECTIVE -medium, IGNORED_DIRECTIVE, NORID, DIRECTIVE -mod, MOD, NORID, RESERVED -module, MODULE, NORID, RESERVED -multiple_const_segs, IGNORED_DIRECTIVE, NORID, DIRECTIVE -multiple_data_segs, IGNORED_DIRECTIVE, NORID, DIRECTIVE -newmode, NEWMODE, NORID, RESERVED -nolist, IGNORED_DIRECTIVE, NORID, DIRECTIVE -no_overlap_check, IGNORED_DIRECTIVE, NORID, DIRECTIVE -nonref, NONREF, NORID, RESERVED -nopack, NOPACK, NORID, RESERVED -not, NOT, NORID, RESERVED -od, OD, NORID, RESERVED -of, OF, NORID, RESERVED -on, ON, NORID, RESERVED -only_for_simulation, IGNORED_DIRECTIVE, NORID, DIRECTIVE -only_for_target, IGNORED_DIRECTIVE, NORID, DIRECTIVE -optimize, IGNORED_DIRECTIVE, NORID, DIRECTIVE -optimize_runtime, IGNORED_DIRECTIVE, NORID, DIRECTIVE -optimization_window, IGNORED_DIRECTIVE, NORID, DIRECTIVE -or, OR, NORID, RESERVED -orif, ORIF, NORID, RESERVED -out, PARAMATTR, RID_OUT, RESERVED -pack, PACK, NORID, RESERVED -page, IGNORED_DIRECTIVE, NORID, DIRECTIVE -pos, POS, NORID, RESERVED -powerset, POWERSET, NORID, RESERVED -prefixed, PREFIXED, NORID, RESERVED -print_o_code, IGNORED_DIRECTIVE, NORID, DIRECTIVE -print_symbol_table, IGNORED_DIRECTIVE, NORID, DIRECTIVE -priority, PRIORITY, NORID, RESERVED -proc, PROC, NORID, RESERVED -process, PROCESS, NORID, RESERVED -process_type, PROCESS_TYPE_TOKEN, NORID, DIRECTIVE -range, RANGE, NORID, RESERVED -range_off, RANGE_OFF, NORID, DIRECTIVE -range_on, RANGE_ON, NORID, DIRECTIVE -read, READ, RID_READ, RESERVED -receive, RECEIVE, NORID, RESERVED -recursive, RECURSIVE, NORID, RESERVED -reentrant, IGNORED_DIRECTIVE, NORID, DIRECTIVE -reentrant_all, IGNORED_DIRECTIVE, NORID, DIRECTIVE -ref, REF, NORID, RESERVED -region, REGION, NORID, RESERVED -rem, REM, NORID, RESERVED -remote, REMOTE, NORID, RESERVED -result, RESULT, NORID, RESERVED -return, RETURN, NORID, RESERVED -returns, RETURNS, NORID, RESERVED -row, ROW, NORID, RESERVED -seize, SEIZE, NORID, RESERVED -send, SEND, NORID, RESERVED -send_buffer_default_priority, SEND_BUFFER_DEFAULT_PRIORITY, NORID, DIRECTIVE -send_signal_default_priority, SEND_SIGNAL_DEFAULT_PRIORITY, NORID, DIRECTIVE -set, SET, NORID, RESERVED -short_pred_succ, IGNORED_DIRECTIVE, NORID, DIRECTIVE -signal, SIGNAL, NORID, RESERVED -signal_code, SIGNAL_CODE, NORID, DIRECTIVE -signal_max_length, IGNORED_DIRECTIVE, NORID, DIRECTIVE -simple, SIMPLE, NORID, RESERVED -small, IGNORED_DIRECTIVE, NORID, DIRECTIVE -spec, SPEC, NORID, RESERVED -start, START, NORID, RESERVED -state_routine, IGNORED_DIRECTIVE, NORID, DIRECTIVE -static, STATIC, NORID, RESERVED -step, STEP, NORID, RESERVED -stop, STOP, NORID, RESERVED -struct, STRUCT, NORID, RESERVED -support_causing_address, IGNORED_DIRECTIVE, NORID, DIRECTIVE -syn, SYN, NORID, RESERVED -synmode, SYNMODE, NORID, RESERVED -text, TEXT, NORID, RESERVED -then, THEN, NORID, RESERVED -this, THIS, NORID, RESERVED -timeout, TIMEOUT, NORID, RESERVED -to, TO, NORID, RESERVED -up, UP, NORID, RESERVED -use_seize_file, USE_SEIZE_FILE, NORID, DIRECTIVE -use_seize_file_restricted, USE_SEIZE_FILE_RESTRICTED, NORID, DIRECTIVE -varying, VARYING, NORID, RESERVED -while, WHILE, NORID, RESERVED -with, WITH, NORID, RESERVED -xor, XOR, NORID, RESERVED diff --git a/gcc/ch/grant.c b/gcc/ch/grant.c deleted file mode 100644 index 29e7ddc1bb5..00000000000 --- a/gcc/ch/grant.c +++ /dev/null @@ -1,3061 +0,0 @@ -/* Implement grant-file output & seize-file input for CHILL. - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "lex.h" -#include "flags.h" -#include "actions.h" -#include "input.h" -#include "rtl.h" -#include "tasking.h" -#include "toplev.h" -#include "output.h" - -#define APPEND(X,Y) X = append (X, Y) -#define PREPEND(X,Y) X = prepend (X, Y); -#define FREE(x) strfree (x) -#define ALLOCAMOUNT 10000 -/* may be we can handle this in a more exciting way, - but this also should work for the moment */ -#define MAYBE_NEWLINE(X) \ -do \ -{ \ - if (X->len && X->str[X->len - 1] != '\n') \ - APPEND (X, ";\n"); \ -} while (0) - -extern tree process_type; -extern char *asm_file_name; -extern char *dump_base_name; - -/* forward declarations */ - -/* variable indicates compilation at module level */ -int chill_at_module_level = 0; - - -/* mark that a SPEC MODULE was generated */ -static int spec_module_generated = 0; - -/* define a faster string handling */ -typedef struct -{ - char *str; - int len; - int allocated; -} MYSTRING; - -/* structure used for handling multiple grant files */ -char *grant_file_name; -MYSTRING *gstring = NULL; -MYSTRING *selective_gstring = NULL; - -static MYSTRING *decode_decl PARAMS ((tree)); -static MYSTRING *decode_constant PARAMS ((tree)); -static void grant_one_decl PARAMS ((tree)); -static MYSTRING *get_type PARAMS ((tree)); -static MYSTRING *decode_mode PARAMS ((tree)); -static MYSTRING *decode_prefix_rename PARAMS ((tree)); -static MYSTRING *decode_constant_selective PARAMS ((tree, tree)); -static MYSTRING *decode_mode_selective PARAMS ((tree, tree)); -static MYSTRING *get_type_selective PARAMS ((tree, tree)); -static MYSTRING *decode_decl_selective PARAMS ((tree, tree)); -static MYSTRING *newstring PARAMS ((const char *)); -static void strfree PARAMS ((MYSTRING *)); -static MYSTRING *append PARAMS ((MYSTRING *, const char *)); -static MYSTRING *prepend PARAMS ((MYSTRING *, const char *)); -static void grant_use_seizefile PARAMS ((const char *)); -static MYSTRING *decode_layout PARAMS ((tree)); -static MYSTRING *grant_array_type PARAMS ((tree)); -static MYSTRING *grant_array_type_selective PARAMS ((tree, tree)); -static MYSTRING *get_tag_value PARAMS ((tree)); -static MYSTRING *get_tag_value_selective PARAMS ((tree, tree)); -static MYSTRING *print_enumeral PARAMS ((tree)); -static MYSTRING *print_enumeral_selective PARAMS ((tree, tree)); -static MYSTRING *print_integer_type PARAMS ((tree)); -static tree find_enum_parent PARAMS ((tree, tree)); -static MYSTRING *print_integer_selective PARAMS ((tree, tree)); -static MYSTRING *print_struct PARAMS ((tree)); -static MYSTRING *print_struct_selective PARAMS ((tree, tree)); -static MYSTRING *print_proc_exceptions PARAMS ((tree)); -static MYSTRING *print_proc_tail PARAMS ((tree, tree, int)); -static MYSTRING *print_proc_tail_selective PARAMS ((tree, tree, tree)); -static tree find_in_decls PARAMS ((tree, tree)); -static int in_ridpointers PARAMS ((tree)); -static void grant_seized_identifier PARAMS ((tree)); -static void globalize_decl PARAMS ((tree)); -static void grant_one_decl_selective PARAMS ((tree, tree)); -static int compare_memory_file PARAMS ((const char *, const char *)); -static int search_in_list PARAMS ((tree, tree)); -static int really_grant_this PARAMS ((tree, tree)); - -/* list of the VAR_DECLs of the module initializer entries */ -tree module_init_list = NULL_TREE; - -/* handle different USE_SEIZE_FILE's in case of selective granting */ -typedef struct SEIZEFILELIST -{ - struct SEIZEFILELIST *next; - tree filename; - MYSTRING *seizes; -} seizefile_list; - -static seizefile_list *selective_seizes = 0; - - -static MYSTRING * -newstring (str) - const char *str; -{ - MYSTRING *tmp = (MYSTRING *) xmalloc (sizeof (MYSTRING)); - unsigned len = strlen (str); - - tmp->allocated = len + ALLOCAMOUNT; - tmp->str = xmalloc ((unsigned)tmp->allocated); - strcpy (tmp->str, str); - tmp->len = len; - return (tmp); -} - -static void -strfree (str) - MYSTRING *str; -{ - free (str->str); - free (str); -} - -static MYSTRING * -append (inout, in) - MYSTRING *inout; - const char *in; -{ - int inlen = strlen (in); - int amount = ALLOCAMOUNT; - - if (inlen >= amount) - amount += inlen; - if ((inout->len + inlen) >= inout->allocated) - inout->str = xrealloc (inout->str, inout->allocated += amount); - strcpy (inout->str + inout->len, in); - inout->len += inlen; - return (inout); -} - -static MYSTRING * -prepend (inout, in) - MYSTRING *inout; - const char *in; -{ - MYSTRING *res = inout; - if (strlen (in)) - { - res = newstring (in); - res = APPEND (res, inout->str); - FREE (inout); - } - return res; -} - -static void -grant_use_seizefile (seize_filename) - const char *seize_filename; -{ - APPEND (gstring, "<> USE_SEIZE_FILE \""); - APPEND (gstring, seize_filename); - APPEND (gstring, "\" <>\n"); -} - -static MYSTRING * -decode_layout (layout) - tree layout; -{ - tree temp; - tree stepsize = NULL_TREE; - int was_step = 0; - MYSTRING *result = newstring (""); - MYSTRING *work; - - if (layout == integer_zero_node) /* NOPACK */ - { - APPEND (result, " NOPACK"); - return result; - } - - if (layout == integer_one_node) /* PACK */ - { - APPEND (result, " PACK"); - return result; - } - - APPEND (result, " "); - temp = layout; - if (TREE_PURPOSE (temp) == NULL_TREE) - { - APPEND (result, "STEP("); - was_step = 1; - temp = TREE_VALUE (temp); - stepsize = TREE_VALUE (temp); - } - APPEND (result, "POS("); - - /* Get the starting word */ - temp = TREE_PURPOSE (temp); - work = decode_constant (TREE_PURPOSE (temp)); - APPEND (result, work->str); - FREE (work); - - temp = TREE_VALUE (temp); - if (temp != NULL_TREE) - { - /* Get the starting bit */ - APPEND (result, ", "); - work = decode_constant (TREE_PURPOSE (temp)); - APPEND (result, work->str); - FREE (work); - - temp = TREE_VALUE (temp); - if (temp != NULL_TREE) - { - /* Get the length or the ending bit */ - tree what = TREE_PURPOSE (temp); - if (what == integer_zero_node) /* length */ - { - APPEND (result, ", "); - } - else - { - APPEND (result, ":"); - } - work = decode_constant (TREE_VALUE (temp)); - APPEND (result, work->str); - FREE (work); - } - } - APPEND (result, ")"); - - if (was_step) - { - if (stepsize != NULL_TREE) - { - APPEND (result, ", "); - work = decode_constant (stepsize); - APPEND (result, work->str); - FREE (work); - } - APPEND (result, ")"); - } - - return result; -} - -static MYSTRING * -grant_array_type (type) - tree type; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - tree layout; - int varying = 0; - - if (chill_varying_type_p (type)) - { - varying = 1; - type = CH_VARYING_ARRAY_TYPE (type); - } - if (CH_STRING_TYPE_P (type)) - { - tree fields = TYPE_DOMAIN (type); - tree maxval = TYPE_MAX_VALUE (fields); - - if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE) - APPEND (result, "CHARS ("); - else - APPEND (result, "BOOLS ("); - if (TREE_CODE (maxval) == INTEGER_CST) - { - char wrk[20]; - sprintf (wrk, HOST_WIDE_INT_PRINT_DEC, - TREE_INT_CST_LOW (maxval) + 1); - APPEND (result, wrk); - } - else if (TREE_CODE (maxval) == MINUS_EXPR - && TREE_OPERAND (maxval, 1) == integer_one_node) - { - mode_string = decode_constant (TREE_OPERAND (maxval, 0)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - mode_string = decode_constant (maxval); - APPEND (result, mode_string->str); - FREE (mode_string); - APPEND (result, "+1"); - } - APPEND (result, ")"); - if (varying) - APPEND (result, " VARYING"); - return result; - } - - APPEND (result, "ARRAY ("); - if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE - && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE]) - { - mode_string = decode_constant (TYPE_MIN_VALUE (TYPE_DOMAIN (type))); - APPEND (result, mode_string->str); - FREE (mode_string); - - APPEND (result, ":"); - mode_string = decode_constant (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - mode_string = decode_mode (TYPE_DOMAIN (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - APPEND (result, ") "); - if (varying) - APPEND (result, "VARYING "); - - mode_string = get_type (TREE_TYPE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - - layout = TYPE_ATTRIBUTES (type); - if (layout != NULL_TREE) - { - mode_string = decode_layout (layout); - APPEND (result, mode_string->str); - FREE (mode_string); - } - - return result; -} - -static MYSTRING * -grant_array_type_selective (type, all_decls) - tree type; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - int varying = 0; - - if (chill_varying_type_p (type)) - { - varying = 1; - type = CH_VARYING_ARRAY_TYPE (type); - } - if (CH_STRING_TYPE_P (type)) - { - tree fields = TYPE_DOMAIN (type); - tree maxval = TYPE_MAX_VALUE (fields); - - if (TREE_CODE (maxval) != INTEGER_CST) - { - if (TREE_CODE (maxval) == MINUS_EXPR - && TREE_OPERAND (maxval, 1) == integer_one_node) - { - mode_string = decode_constant_selective (TREE_OPERAND (maxval, 0), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - mode_string = decode_constant_selective (maxval, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - } - return result; - } - - if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE - && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE]) - { - mode_string = decode_constant_selective (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - - mode_string = decode_constant_selective (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - else - { - mode_string = decode_mode_selective (TYPE_DOMAIN (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - - mode_string = get_type_selective (TREE_TYPE (type), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - - return result; -} - -static MYSTRING * -get_tag_value (val) - tree val; -{ - MYSTRING *result; - - if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val)) - { - result = newstring (IDENTIFIER_POINTER (DECL_NAME (val))); - } - else if (TREE_CODE (val) == CONST_DECL) - { - /* it's a synonym -- get the value */ - result = decode_constant (DECL_INITIAL (val)); - } - else - { - result = decode_constant (val); - } - return (result); -} - -static MYSTRING * -get_tag_value_selective (val, all_decls) - tree val; - tree all_decls; -{ - MYSTRING *result; - - if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val)) - result = newstring (""); - else if (TREE_CODE (val) == CONST_DECL) - { - /* it's a synonym -- get the value */ - result = decode_constant_selective (DECL_INITIAL (val), all_decls); - } - else - { - result = decode_constant_selective (val, all_decls); - } - return (result); -} - -static MYSTRING * -print_enumeral (type) - tree type; -{ - MYSTRING *result = newstring (""); - tree fields; - -#if 0 - if (TYPE_LANG_SPECIFIC (type) == NULL) -#endif - { - - APPEND (result, "SET ("); - for (fields = TYPE_VALUES (type); - fields != NULL_TREE; - fields = TREE_CHAIN (fields)) - { - if (TREE_PURPOSE (fields) == NULL_TREE) - APPEND (result, "*"); - else - { - tree decl = TREE_VALUE (fields); - APPEND (result, IDENTIFIER_POINTER (TREE_PURPOSE (fields))); - if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl)) - { - MYSTRING *val_string = decode_constant (DECL_INITIAL (decl)); - APPEND (result, " = "); - APPEND (result, val_string->str); - FREE (val_string); - } - } - if (TREE_CHAIN (fields) != NULL_TREE) - APPEND (result, ",\n "); - } - APPEND (result, ")"); - } - return result; -} - -static MYSTRING * -print_enumeral_selective (type, all_decls) - tree type; - tree all_decls; -{ - MYSTRING *result = newstring (""); - tree fields; - - for (fields = TYPE_VALUES (type); - fields != NULL_TREE; - fields = TREE_CHAIN (fields)) - { - if (TREE_PURPOSE (fields) != NULL_TREE) - { - tree decl = TREE_VALUE (fields); - if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl)) - { - MYSTRING *val_string = decode_constant_selective (DECL_INITIAL (decl), all_decls); - if (val_string->len) - APPEND (result, val_string->str); - FREE (val_string); - } - } - } - return result; -} - -static MYSTRING * -print_integer_type (type) - tree type; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - const char *name_ptr; - tree base_type; - - if (TREE_TYPE (type)) - { - mode_string = decode_mode (TREE_TYPE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - - APPEND (result, "("); - mode_string = decode_constant (TYPE_MIN_VALUE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - - if (TREE_TYPE (type) != ridpointers[(int) RID_BIN]) - { - APPEND (result, ":"); - mode_string = decode_constant (TYPE_MAX_VALUE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - - APPEND (result, ")"); - return result; - } - /* We test TYPE_MAIN_VARIANT because pushdecl often builds - a copy of a built-in type node, which is logically id- - entical but has a different address, and the same - TYPE_MAIN_VARIANT. */ - /* FIXME this should not be needed! */ - - base_type = TREE_TYPE (type) ? TREE_TYPE (type) : type; - - if (TREE_UNSIGNED (base_type)) - { - if (base_type == chill_unsigned_type_node - || TYPE_MAIN_VARIANT(base_type) == - TYPE_MAIN_VARIANT (chill_unsigned_type_node)) - name_ptr = "UINT"; - else if (base_type == long_integer_type_node - || TYPE_MAIN_VARIANT(base_type) == - TYPE_MAIN_VARIANT (long_unsigned_type_node)) - name_ptr = "ULONG"; - else if (type == unsigned_char_type_node - || TYPE_MAIN_VARIANT(base_type) == - TYPE_MAIN_VARIANT (unsigned_char_type_node)) - name_ptr = "UBYTE"; - else if (type == duration_timing_type_node - || TYPE_MAIN_VARIANT (base_type) == - TYPE_MAIN_VARIANT (duration_timing_type_node)) - name_ptr = "DURATION"; - else if (type == abs_timing_type_node - || TYPE_MAIN_VARIANT (base_type) == - TYPE_MAIN_VARIANT (abs_timing_type_node)) - name_ptr = "TIME"; - else - name_ptr = "UINT"; - } - else - { - if (base_type == chill_integer_type_node - || TYPE_MAIN_VARIANT (base_type) == - TYPE_MAIN_VARIANT (chill_integer_type_node)) - name_ptr = "INT"; - else if (base_type == long_integer_type_node - || TYPE_MAIN_VARIANT (base_type) == - TYPE_MAIN_VARIANT (long_integer_type_node)) - name_ptr = "LONG"; - else if (type == signed_char_type_node - || TYPE_MAIN_VARIANT (base_type) == - TYPE_MAIN_VARIANT (signed_char_type_node)) - name_ptr = "BYTE"; - else - name_ptr = "INT"; - } - - APPEND (result, name_ptr); - - /* see if we have a range */ - if (TREE_TYPE (type) != NULL) - { - mode_string = decode_constant (TYPE_MIN_VALUE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - APPEND (result, ":"); - mode_string = decode_constant (TYPE_MAX_VALUE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - - return result; -} - -static tree -find_enum_parent (enumname, all_decls) - tree enumname; - tree all_decls; -{ - tree wrk; - - for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk)) - { - if (TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (wrk) != CONST_DECL && - TREE_CODE (TREE_TYPE (wrk)) == ENUMERAL_TYPE) - { - tree list; - for (list = TYPE_VALUES (TREE_TYPE (wrk)); list != NULL_TREE; list = TREE_CHAIN (list)) - { - if (DECL_NAME (TREE_VALUE (list)) == enumname) - return wrk; - } - } - } - return NULL_TREE; -} - -static MYSTRING * -print_integer_selective (type, all_decls) - tree type; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - - if (TREE_TYPE (type)) - { - mode_string = decode_mode_selective (TREE_TYPE (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - - if (TREE_TYPE (type) == ridpointers[(int)RID_RANGE] && - TREE_CODE (TYPE_MIN_VALUE (type)) == IDENTIFIER_NODE && - TREE_CODE (TYPE_MAX_VALUE (type)) == IDENTIFIER_NODE) - { - /* we have a range of a set. Find parant mode and write it - to SPEC MODULE. This will loose if the parent mode was SEIZED from - another file.*/ - tree minparent = find_enum_parent (TYPE_MIN_VALUE (type), all_decls); - tree maxparent = find_enum_parent (TYPE_MAX_VALUE (type), all_decls); - - if (minparent != NULL_TREE) - { - if (! CH_ALREADY_GRANTED (minparent)) - { - mode_string = decode_decl (minparent); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - CH_ALREADY_GRANTED (minparent) = 1; - } - } - if (minparent != maxparent && maxparent != NULL_TREE) - { - if (!CH_ALREADY_GRANTED (maxparent)) - { - mode_string = decode_decl (maxparent); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - CH_ALREADY_GRANTED (maxparent) = 1; - } - } - } - else - { - mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - - mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - return result; - } - - /* see if we have a range */ - if (TREE_TYPE (type) != NULL) - { - mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - - mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - - return result; -} - -static MYSTRING * -print_struct (type) - tree type; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - tree fields; - - if (chill_varying_type_p (type)) - { - mode_string = grant_array_type (type); - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - fields = TYPE_FIELDS (type); - - APPEND (result, "STRUCT ("); - while (fields != NULL_TREE) - { - if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE) - { - tree variants; - /* Format a tagged variant record type. */ - APPEND (result, " CASE "); - if (TYPE_TAGFIELDS (TREE_TYPE (fields)) != NULL_TREE) - { - tree tag_list = TYPE_TAGFIELDS (TREE_TYPE (fields)); - for (;;) - { - tree tag_name = DECL_NAME (TREE_VALUE (tag_list)); - APPEND (result, IDENTIFIER_POINTER (tag_name)); - tag_list = TREE_CHAIN (tag_list); - if (tag_list == NULL_TREE) - break; - APPEND (result, ", "); - } - } - APPEND (result, " OF\n"); - variants = TYPE_FIELDS (TREE_TYPE (fields)); - - /* Each variant is a FIELD_DECL whose type is an anonymous - struct within the anonymous union. */ - while (variants != NULL_TREE) - { - tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants)); - tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants)); - - while (tag_list != NULL_TREE) - { - tree tag_values = TREE_VALUE (tag_list); - APPEND (result, " ("); - while (tag_values != NULL_TREE) - { - mode_string = get_tag_value (TREE_VALUE (tag_values)); - APPEND (result, mode_string->str); - FREE (mode_string); - if (TREE_CHAIN (tag_values) != NULL_TREE) - { - APPEND (result, ",\n "); - tag_values = TREE_CHAIN (tag_values); - } - else break; - } - APPEND (result, ")"); - tag_list = TREE_CHAIN (tag_list); - if (tag_list) - APPEND (result, ","); - else - break; - } - APPEND (result, " : "); - - while (struct_elts != NULL_TREE) - { - mode_string = decode_decl (struct_elts); - APPEND (result, mode_string->str); - FREE (mode_string); - - if (TREE_CHAIN (struct_elts) != NULL_TREE) - APPEND (result, ",\n "); - struct_elts = TREE_CHAIN (struct_elts); - } - - variants = TREE_CHAIN (variants); - if (variants != NULL_TREE - && TREE_CHAIN (variants) == NULL_TREE - && DECL_NAME (variants) == ELSE_VARIANT_NAME) - { - tree else_elts = TYPE_FIELDS (TREE_TYPE (variants)); - APPEND (result, "\n ELSE "); - while (else_elts != NULL_TREE) - { - mode_string = decode_decl (else_elts); - APPEND (result, mode_string->str); - FREE (mode_string); - if (TREE_CHAIN (else_elts) != NULL_TREE) - APPEND (result, ",\n "); - else_elts = TREE_CHAIN (else_elts); - } - break; - } - if (variants != NULL_TREE) - APPEND (result, ",\n"); - } - - APPEND (result, "\n ESAC"); - } - else - { - mode_string = decode_decl (fields); - APPEND (result, mode_string->str); - FREE (mode_string); - } - - fields = TREE_CHAIN (fields); - if (fields != NULL_TREE) - APPEND (result, ",\n "); - } - APPEND (result, ")"); - } - return result; -} - -static MYSTRING * -print_struct_selective (type, all_decls) - tree type; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - tree fields; - - if (chill_varying_type_p (type)) - { - mode_string = grant_array_type_selective (type, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - fields = TYPE_FIELDS (type); - - while (fields != NULL_TREE) - { - if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE) - { - tree variants; - /* Format a tagged variant record type. */ - - variants = TYPE_FIELDS (TREE_TYPE (fields)); - - /* Each variant is a FIELD_DECL whose type is an anonymous - struct within the anonymous union. */ - while (variants != NULL_TREE) - { - tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants)); - tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants)); - - while (tag_list != NULL_TREE) - { - tree tag_values = TREE_VALUE (tag_list); - while (tag_values != NULL_TREE) - { - mode_string = get_tag_value_selective (TREE_VALUE (tag_values), - all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - if (TREE_CHAIN (tag_values) != NULL_TREE) - tag_values = TREE_CHAIN (tag_values); - else break; - } - tag_list = TREE_CHAIN (tag_list); - if (!tag_list) - break; - } - - while (struct_elts != NULL_TREE) - { - mode_string = decode_decl_selective (struct_elts, all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - - struct_elts = TREE_CHAIN (struct_elts); - } - - variants = TREE_CHAIN (variants); - if (variants != NULL_TREE - && TREE_CHAIN (variants) == NULL_TREE - && DECL_NAME (variants) == ELSE_VARIANT_NAME) - { - tree else_elts = TYPE_FIELDS (TREE_TYPE (variants)); - while (else_elts != NULL_TREE) - { - mode_string = decode_decl_selective (else_elts, all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - else_elts = TREE_CHAIN (else_elts); - } - break; - } - } - } - else - { - mode_string = decode_decl_selective (fields, all_decls); - APPEND (result, mode_string->str); - FREE (mode_string); - } - - fields = TREE_CHAIN (fields); - } - } - return result; -} - -static MYSTRING * -print_proc_exceptions (ex) - tree ex; -{ - MYSTRING *result = newstring (""); - - if (ex != NULL_TREE) - { - APPEND (result, "\n EXCEPTIONS ("); - for ( ; ex != NULL_TREE; ex = TREE_CHAIN (ex)) - { - APPEND (result, IDENTIFIER_POINTER (TREE_VALUE (ex))); - if (TREE_CHAIN (ex) != NULL_TREE) - APPEND (result, ",\n "); - } - APPEND (result, ")"); - } - return result; -} - -static MYSTRING * -print_proc_tail (type, args, print_argnames) - tree type; - tree args; - int print_argnames; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - int count = 0; - int stopat = list_length (args) - 3; - - /* do the argument modes */ - for ( ; args != NULL_TREE; - args = TREE_CHAIN (args), count++) - { - char buf[20]; - tree argmode = TREE_VALUE (args); - tree attribute = TREE_PURPOSE (args); - - if (argmode == void_type_node) - continue; - - /* if we have exceptions don't print last 2 arguments */ - if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat) - break; - - if (count) - APPEND (result, ",\n "); - if (print_argnames) - { - sprintf(buf, "arg%d ", count); - APPEND (result, buf); - } - - if (attribute == ridpointers[(int) RID_LOC]) - argmode = TREE_TYPE (argmode); - mode_string = get_type (argmode); - APPEND (result, mode_string->str); - FREE (mode_string); - - if (attribute != NULL_TREE) - { - sprintf (buf, " %s", IDENTIFIER_POINTER (attribute)); - APPEND (result, buf); - } - } - APPEND (result, ")"); - - /* return type */ - { - tree retn_type = TREE_TYPE (type); - - if (retn_type != NULL_TREE - && TREE_CODE (retn_type) != VOID_TYPE) - { - mode_string = get_type (retn_type); - APPEND (result, "\n RETURNS ("); - APPEND (result, mode_string->str); - FREE (mode_string); - if (TREE_CODE (retn_type) == REFERENCE_TYPE) - APPEND (result, " LOC"); - APPEND (result, ")"); - } - } - - mode_string = print_proc_exceptions (TYPE_RAISES_EXCEPTIONS (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - - return result; -} - -static MYSTRING * -print_proc_tail_selective (type, args, all_decls) - tree type; - tree args; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - int count = 0; - int stopat = list_length (args) - 3; - - /* do the argument modes */ - for ( ; args != NULL_TREE; - args = TREE_CHAIN (args), count++) - { - tree argmode = TREE_VALUE (args); - tree attribute = TREE_PURPOSE (args); - - if (argmode == void_type_node) - continue; - - /* if we have exceptions don't process last 2 arguments */ - if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat) - break; - - if (attribute == ridpointers[(int) RID_LOC]) - argmode = TREE_TYPE (argmode); - mode_string = get_type_selective (argmode, all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - - /* return type */ - { - tree retn_type = TREE_TYPE (type); - - if (retn_type != NULL_TREE - && TREE_CODE (retn_type) != VOID_TYPE) - { - mode_string = get_type_selective (retn_type, all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - } - - return result; -} - -/* output a mode (or type). */ - -static MYSTRING * -decode_mode (type) - tree type; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - - switch ((enum chill_tree_code)TREE_CODE (type)) - { - case TYPE_DECL: - if (DECL_NAME (type)) - { - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (type))); - return result; - } - type = TREE_TYPE (type); - break; - - case IDENTIFIER_NODE: - APPEND (result, IDENTIFIER_POINTER (type)); - return result; - - case LANG_TYPE: - /* LANG_TYPE are only used until satisfy is done, - as place-holders for 'READ T', NEWMODE/SYNMODE modes, - parameterised modes, and old-fashioned CHAR(N). */ - if (TYPE_READONLY (type)) - APPEND (result, "READ "); - - mode_string = get_type (TREE_TYPE (type)); - APPEND (result, mode_string->str); - if (TYPE_DOMAIN (type) != NULL_TREE) - { - /* Parameterized mode, - or old-fashioned CHAR(N) string declaration.. */ - APPEND (result, "("); - mode_string = decode_constant (TYPE_DOMAIN (type)); - APPEND (result, mode_string->str); - APPEND (result, ")"); - } - FREE (mode_string); - break; - - case ARRAY_TYPE: - mode_string = grant_array_type (type); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case BOOLEAN_TYPE: - APPEND (result, "BOOL"); - break; - - case CHAR_TYPE: - APPEND (result, "CHAR"); - break; - - case ENUMERAL_TYPE: - mode_string = print_enumeral (type); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case FUNCTION_TYPE: - { - tree args = TYPE_ARG_TYPES (type); - - APPEND (result, "PROC ("); - - mode_string = print_proc_tail (type, args, 0); - APPEND (result, mode_string->str); - FREE (mode_string); - } - break; - - case INTEGER_TYPE: - mode_string = print_integer_type (type); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case RECORD_TYPE: - if (CH_IS_INSTANCE_MODE (type)) - { - APPEND (result, "INSTANCE"); - return result; - } - else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) - { tree bufsize = max_queue_size (type); - APPEND (result, CH_IS_BUFFER_MODE (type) ? "BUFFER " : "EVENT "); - if (bufsize != NULL_TREE) - { - APPEND (result, "("); - mode_string = decode_constant (bufsize); - APPEND (result, mode_string->str); - APPEND (result, ") "); - FREE (mode_string); - } - if (CH_IS_BUFFER_MODE (type)) - { - mode_string = decode_mode (buffer_element_mode (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - break; - } - else if (CH_IS_ACCESS_MODE (type)) - { - tree indexmode, recordmode, dynamic; - - APPEND (result, "ACCESS"); - recordmode = access_recordmode (type); - indexmode = access_indexmode (type); - dynamic = access_dynamic (type); - - if (indexmode != void_type_node) - { - mode_string = decode_mode (indexmode); - APPEND (result, " ("); - APPEND (result, mode_string->str); - APPEND (result, ")"); - FREE (mode_string); - } - if (recordmode != void_type_node) - { - mode_string = decode_mode (recordmode); - APPEND (result, " "); - APPEND (result, mode_string->str); - FREE (mode_string); - } - if (dynamic != integer_zero_node) - APPEND (result, " DYNAMIC"); - break; - } - else if (CH_IS_TEXT_MODE (type)) - { - tree indexmode, dynamic, length; - - APPEND (result, "TEXT ("); - length = text_length (type); - indexmode = text_indexmode (type); - dynamic = text_dynamic (type); - - mode_string = decode_constant (length); - APPEND (result, mode_string->str); - FREE (mode_string); - APPEND (result, ")"); - if (indexmode != void_type_node) - { - APPEND (result, " "); - mode_string = decode_mode (indexmode); - APPEND (result, mode_string->str); - FREE (mode_string); - } - if (dynamic != integer_zero_node) - APPEND (result, " DYNAMIC"); - return result; - } - mode_string = print_struct (type); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case POINTER_TYPE: - if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE) - APPEND (result, "PTR"); - else - { - if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) - { - mode_string = get_type (TREE_TYPE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - APPEND (result, "REF "); - mode_string = get_type (TREE_TYPE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - } - break; - - case REAL_TYPE: - if (TREE_INT_CST_LOW (TYPE_SIZE (type)) == 32) - APPEND (result, "REAL"); - else - APPEND (result, "LONG_REAL"); - break; - - case SET_TYPE: - if (CH_BOOLS_TYPE_P (type)) - mode_string = grant_array_type (type); - else - { - APPEND (result, "POWERSET "); - mode_string = get_type (TYPE_DOMAIN (type)); - } - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case REFERENCE_TYPE: - mode_string = get_type (TREE_TYPE (type)); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - default: - APPEND (result, "/* ---- not implemented ---- */"); - break; - } - - return (result); -} - -static tree -find_in_decls (id, all_decls) - tree id; - tree all_decls; -{ - tree wrk; - - for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk)) - { - if (DECL_NAME (wrk) == id || DECL_POSTFIX (wrk) == id) - return wrk; - } - return NULL_TREE; -} - -static int -in_ridpointers (id) - tree id; -{ - int i; - for (i = RID_UNUSED; i < RID_MAX; i++) - { - if (id == ridpointers[i]) - return 1; - } - return 0; -} - -static void -grant_seized_identifier (decl) - tree decl; -{ - seizefile_list *wrk = selective_seizes; - MYSTRING *mode_string; - - CH_ALREADY_GRANTED (decl) = 1; - - /* comes from a SPEC MODULE in the module */ - if (DECL_SEIZEFILE (decl) == NULL_TREE) - return; - - /* search file already in process */ - while (wrk != 0) - { - if (wrk->filename == DECL_SEIZEFILE (decl)) - break; - wrk = wrk->next; - } - if (!wrk) - { - wrk = (seizefile_list *)xmalloc (sizeof (seizefile_list)); - wrk->next = selective_seizes; - selective_seizes = wrk; - wrk->filename = DECL_SEIZEFILE (decl); - wrk->seizes = newstring ("<> USE_SEIZE_FILE \""); - APPEND (wrk->seizes, IDENTIFIER_POINTER (DECL_SEIZEFILE (decl))); - APPEND (wrk->seizes, "\" <>\n"); - } - APPEND (wrk->seizes, "SEIZE "); - mode_string = decode_prefix_rename (decl); - APPEND (wrk->seizes, mode_string->str); - FREE (mode_string); - APPEND (wrk->seizes, ";\n"); -} - -static MYSTRING * -decode_mode_selective (type, all_decls) - tree type; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - tree decl; - - switch ((enum chill_tree_code)TREE_CODE (type)) - { - case TYPE_DECL: - /* FIXME: could this ever happen ?? */ - if (DECL_NAME (type)) - { - FREE (result); - result = decode_mode_selective (DECL_NAME (type), all_decls); - return result; - } - break; - - case IDENTIFIER_NODE: - if (in_ridpointers (type)) - /* it's a predefined, we must not search the whole list */ - return result; - - decl = find_in_decls (type, all_decls); - if (decl != NULL_TREE) - { - if (CH_ALREADY_GRANTED (decl)) - /* already processed */ - return result; - - if (TREE_CODE (decl) == ALIAS_DECL && DECL_POSTFIX (decl) != NULL_TREE) - { - /* If CH_DECL_GRANTED, decl was granted into this scope, and - so wasn't in the source code. */ - if (!CH_DECL_GRANTED (decl)) - { - grant_seized_identifier (decl); - } - } - else - { - result = decode_decl (decl); - mode_string = decode_decl_selective (decl, all_decls); - if (mode_string->len) - { - PREPEND (result, mode_string->str); - } - FREE (mode_string); - } - } - return result; - - case LANG_TYPE: - mode_string = get_type_selective (TREE_TYPE (type), all_decls); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case ARRAY_TYPE: - mode_string = grant_array_type_selective (type, all_decls); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case BOOLEAN_TYPE: - return result; - break; - - case CHAR_TYPE: - return result; - break; - - case ENUMERAL_TYPE: - mode_string = print_enumeral_selective (type, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case FUNCTION_TYPE: - { - tree args = TYPE_ARG_TYPES (type); - - mode_string = print_proc_tail_selective (type, args, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - break; - - case INTEGER_TYPE: - mode_string = print_integer_selective (type, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case RECORD_TYPE: - if (CH_IS_INSTANCE_MODE (type)) - { - return result; - } - else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) - { - tree bufsize = max_queue_size (type); - if (bufsize != NULL_TREE) - { - mode_string = decode_constant_selective (bufsize, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - if (CH_IS_BUFFER_MODE (type)) - { - mode_string = decode_mode_selective (buffer_element_mode (type), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - break; - } - else if (CH_IS_ACCESS_MODE (type)) - { - tree indexmode = access_indexmode (type); - tree recordmode = access_recordmode (type); - - if (indexmode != void_type_node) - { - mode_string = decode_mode_selective (indexmode, all_decls); - if (mode_string->len) - { - if (result->len && result->str[result->len - 1] != '\n') - APPEND (result, ";\n"); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - if (recordmode != void_type_node) - { - mode_string = decode_mode_selective (recordmode, all_decls); - if (mode_string->len) - { - if (result->len && result->str[result->len - 1] != '\n') - APPEND (result, ";\n"); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - break; - } - else if (CH_IS_TEXT_MODE (type)) - { - tree indexmode = text_indexmode (type); - tree length = text_length (type); - - mode_string = decode_constant_selective (length, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - if (indexmode != void_type_node) - { - mode_string = decode_mode_selective (indexmode, all_decls); - if (mode_string->len) - { - if (result->len && result->str[result->len - 1] != '\n') - APPEND (result, ";\n"); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - break; - } - mode_string = print_struct_selective (type, all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - break; - - case POINTER_TYPE: - if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE) - break; - else - { - if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) - { - mode_string = get_type_selective (TREE_TYPE (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - else - { - mode_string = get_type_selective (TREE_TYPE (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - } - break; - - case REAL_TYPE: - return result; - break; - - case SET_TYPE: - if (CH_BOOLS_TYPE_P (type)) - mode_string = grant_array_type_selective (type, all_decls); - else - mode_string = get_type_selective (TYPE_DOMAIN (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case REFERENCE_TYPE: - mode_string = get_type_selective (TREE_TYPE (type), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - default: - APPEND (result, "/* ---- not implemented ---- */"); - break; - } - - return (result); -} - -static MYSTRING * -get_type (type) - tree type; -{ - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return newstring (""); - - return (decode_mode (type)); -} - -static MYSTRING * -get_type_selective (type, all_decls) - tree type; - tree all_decls; -{ - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return newstring (""); - - return (decode_mode_selective (type, all_decls)); -} - -#if 0 -static int -is_forbidden (str, forbid) - tree str; - tree forbid; -{ - if (forbid == NULL_TREE) - return (0); - - if (TREE_CODE (forbid) == INTEGER_CST) - return (1); - - while (forbid != NULL_TREE) - { - if (TREE_VALUE (forbid) == str) - return (1); - forbid = TREE_CHAIN (forbid); - } - /* nothing found */ - return (0); -} -#endif - -static MYSTRING * -decode_constant (init) - tree init; -{ - MYSTRING *result = newstring (""); - MYSTRING *tmp_string; - tree type = TREE_TYPE (init); - tree val = init; - const char *op; - char wrk[256]; - MYSTRING *mode_string; - - switch ((enum chill_tree_code)TREE_CODE (val)) - { - case CALL_EXPR: - tmp_string = decode_constant (TREE_OPERAND (val, 0)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - val = TREE_OPERAND (val, 1); /* argument list */ - if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST) - { - APPEND (result, " "); - tmp_string = decode_constant (val); - APPEND (result, tmp_string->str); - FREE (tmp_string); - } - else - { - APPEND (result, " ("); - if (val != NULL_TREE) - { - for (;;) - { - tmp_string = decode_constant (TREE_VALUE (val)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - val = TREE_CHAIN (val); - if (val == NULL_TREE) - break; - APPEND (result, ", "); - } - } - APPEND (result, ")"); - } - return result; - - case NOP_EXPR: - /* Generate an "expression conversion" expression (a cast). */ - tmp_string = decode_mode (type); - - APPEND (result, tmp_string->str); - FREE (tmp_string); - APPEND (result, "("); - val = TREE_OPERAND (val, 0); - type = TREE_TYPE (val); - - /* If the coercee is a tuple, make sure it is prefixed by its mode. */ - if (TREE_CODE (val) == CONSTRUCTOR - && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type)) - { - tmp_string = decode_mode (type); - APPEND (result, tmp_string->str); - FREE (tmp_string); - APPEND (result, " "); - } - - tmp_string = decode_constant (val); - APPEND (result, tmp_string->str); - FREE (tmp_string); - APPEND (result, ")"); - return result; - - case IDENTIFIER_NODE: - APPEND (result, IDENTIFIER_POINTER (val)); - return result; - - case PAREN_EXPR: - APPEND (result, "("); - tmp_string = decode_constant (TREE_OPERAND (val, 0)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - APPEND (result, ")"); - return result; - - case UNDEFINED_EXPR: - APPEND (result, "*"); - return result; - - case PLUS_EXPR: op = "+"; goto binary; - case MINUS_EXPR: op = "-"; goto binary; - case MULT_EXPR: op = "*"; goto binary; - case TRUNC_DIV_EXPR: op = "/"; goto binary; - case FLOOR_MOD_EXPR: op = " MOD "; goto binary; - case TRUNC_MOD_EXPR: op = " REM "; goto binary; - case CONCAT_EXPR: op = "//"; goto binary; - case BIT_IOR_EXPR: op = " OR "; goto binary; - case BIT_XOR_EXPR: op = " XOR "; goto binary; - case TRUTH_ORIF_EXPR: op = " ORIF "; goto binary; - case BIT_AND_EXPR: op = " AND "; goto binary; - case TRUTH_ANDIF_EXPR: op = " ANDIF "; goto binary; - case GT_EXPR: op = ">"; goto binary; - case GE_EXPR: op = ">="; goto binary; - case SET_IN_EXPR: op = " IN "; goto binary; - case LT_EXPR: op = "<"; goto binary; - case LE_EXPR: op = "<="; goto binary; - case EQ_EXPR: op = "="; goto binary; - case NE_EXPR: op = "/="; goto binary; - case RANGE_EXPR: - if (TREE_OPERAND (val, 0) == NULL_TREE) - { - APPEND (result, TREE_OPERAND (val, 1) == NULL_TREE ? "*" : "ELSE"); - return result; - } - op = ":"; goto binary; - binary: - tmp_string = decode_constant (TREE_OPERAND (val, 0)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - APPEND (result, op); - tmp_string = decode_constant (TREE_OPERAND (val, 1)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case REPLICATE_EXPR: - APPEND (result, "("); - tmp_string = decode_constant (TREE_OPERAND (val, 0)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - APPEND (result, ")"); - tmp_string = decode_constant (TREE_OPERAND (val, 1)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case NEGATE_EXPR: op = "-"; goto unary; - case BIT_NOT_EXPR: op = " NOT "; goto unary; - case ADDR_EXPR: op = "->"; goto unary; - unary: - APPEND (result, op); - tmp_string = decode_constant (TREE_OPERAND (val, 0)); - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case INTEGER_CST: - APPEND (result, display_int_cst (val)); - return result; - - case REAL_CST: -#ifndef REAL_IS_NOT_DOUBLE - sprintf (wrk, "%.20g", TREE_REAL_CST (val)); -#else - REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk); -#endif - APPEND (result, wrk); - return result; - - case STRING_CST: - { - const char *ptr = TREE_STRING_POINTER (val); - int i = TREE_STRING_LENGTH (val); - APPEND (result, "\""); - while (--i >= 0) - { - char buf[10]; - unsigned char c = *ptr++; - if (c == '^') - APPEND (result, "^^"); - else if (c == '"') - APPEND (result, "\"\""); - else if (c == '\n') - APPEND (result, "^J"); - else if (c < ' ' || c > '~') - { - sprintf (buf, "^(%u)", c); - APPEND (result, buf); - } - else - { - buf[0] = c; - buf[1] = 0; - APPEND (result, buf); - } - } - APPEND (result, "\""); - return result; - } - - case CONSTRUCTOR: - val = TREE_OPERAND (val, 1); - if (type != NULL && TREE_CODE (type) == SET_TYPE - && CH_BOOLS_TYPE_P (type)) - { - /* It's a bitstring. */ - tree domain = TYPE_DOMAIN (type); - tree domain_max = TYPE_MAX_VALUE (domain); - char *buf; - register char *ptr; - int len; - if (TREE_CODE (domain_max) != INTEGER_CST - || (val && TREE_CODE (val) != TREE_LIST)) - goto fail; - - len = TREE_INT_CST_LOW (domain_max) + 1; - if (TREE_CODE (init) != CONSTRUCTOR) - goto fail; - buf = (char *) alloca (len + 10); - ptr = buf; - *ptr++ = ' '; - *ptr++ = 'B'; - *ptr++ = '\''; - if (get_set_constructor_bits (init, ptr, len)) - goto fail; - for (; --len >= 0; ptr++) - *ptr += '0'; - *ptr++ = '\''; - *ptr = '\0'; - APPEND (result, buf); - return result; - } - else - { /* It's some kind of tuple */ - if (type != NULL_TREE) - { - mode_string = get_type (type); - APPEND (result, mode_string->str); - FREE (mode_string); - APPEND (result, " "); - } - if (val == NULL_TREE - || TREE_CODE (val) == ERROR_MARK) - APPEND (result, "[ ]"); - else if (TREE_CODE (val) != TREE_LIST) - goto fail; - else - { - APPEND (result, "["); - for ( ; ; ) - { - tree lo_val = TREE_PURPOSE (val); - tree hi_val = TREE_VALUE (val); - MYSTRING *val_string; - if (TUPLE_NAMED_FIELD (val)) - APPEND(result, "."); - if (lo_val != NULL_TREE) - { - val_string = decode_constant (lo_val); - APPEND (result, val_string->str); - FREE (val_string); - APPEND (result, ":"); - } - val_string = decode_constant (hi_val); - APPEND (result, val_string->str); - FREE (val_string); - val = TREE_CHAIN (val); - if (val == NULL_TREE) - break; - APPEND (result, ", "); - } - APPEND (result, "]"); - } - } - return result; - case COMPONENT_REF: - { - tree op1; - - mode_string = decode_constant (TREE_OPERAND (init, 0)); - APPEND (result, mode_string->str); - FREE (mode_string); - op1 = TREE_OPERAND (init, 1); - if (TREE_CODE (op1) != IDENTIFIER_NODE) - { - error ("decode_constant: invalid component_ref"); - break; - } - APPEND (result, "."); - APPEND (result, IDENTIFIER_POINTER (op1)); - return result; - } - fail: - error ("decode_constant: mode and value mismatch"); - break; - default: - error ("decode_constant: cannot decode this mode"); - break; - } - return result; -} - -static MYSTRING * -decode_constant_selective (init, all_decls) - tree init; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *tmp_string; - tree type = TREE_TYPE (init); - tree val = init; - MYSTRING *mode_string; - - switch ((enum chill_tree_code)TREE_CODE (val)) - { - case CALL_EXPR: - tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - val = TREE_OPERAND (val, 1); /* argument list */ - if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST) - { - tmp_string = decode_constant_selective (val, all_decls); - if (tmp_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, tmp_string->str); - } - FREE (tmp_string); - } - else - { - if (val != NULL_TREE) - { - for (;;) - { - tmp_string = decode_constant_selective (TREE_VALUE (val), all_decls); - if (tmp_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, tmp_string->str); - } - FREE (tmp_string); - val = TREE_CHAIN (val); - if (val == NULL_TREE) - break; - } - } - } - return result; - - case NOP_EXPR: - /* Generate an "expression conversion" expression (a cast). */ - tmp_string = decode_mode_selective (type, all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - val = TREE_OPERAND (val, 0); - type = TREE_TYPE (val); - - /* If the coercee is a tuple, make sure it is prefixed by its mode. */ - if (TREE_CODE (val) == CONSTRUCTOR - && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type)) - { - tmp_string = decode_mode_selective (type, all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - } - - tmp_string = decode_constant_selective (val, all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case IDENTIFIER_NODE: - tmp_string = decode_mode_selective (val, all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case PAREN_EXPR: - tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case UNDEFINED_EXPR: - return result; - - case PLUS_EXPR: - case MINUS_EXPR: - case MULT_EXPR: - case TRUNC_DIV_EXPR: - case FLOOR_MOD_EXPR: - case TRUNC_MOD_EXPR: - case CONCAT_EXPR: - case BIT_IOR_EXPR: - case BIT_XOR_EXPR: - case TRUTH_ORIF_EXPR: - case BIT_AND_EXPR: - case TRUTH_ANDIF_EXPR: - case GT_EXPR: - case GE_EXPR: - case SET_IN_EXPR: - case LT_EXPR: - case LE_EXPR: - case EQ_EXPR: - case NE_EXPR: - goto binary; - case RANGE_EXPR: - if (TREE_OPERAND (val, 0) == NULL_TREE) - return result; - - binary: - tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls); - if (tmp_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, tmp_string->str); - } - FREE (tmp_string); - return result; - - case REPLICATE_EXPR: - tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls); - if (tmp_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, tmp_string->str); - } - FREE (tmp_string); - return result; - - case NEGATE_EXPR: - case BIT_NOT_EXPR: - case ADDR_EXPR: - tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls); - if (tmp_string->len) - APPEND (result, tmp_string->str); - FREE (tmp_string); - return result; - - case INTEGER_CST: - return result; - - case REAL_CST: - return result; - - case STRING_CST: - return result; - - case CONSTRUCTOR: - val = TREE_OPERAND (val, 1); - if (type != NULL && TREE_CODE (type) == SET_TYPE - && CH_BOOLS_TYPE_P (type)) - /* It's a bitstring. */ - return result; - else - { /* It's some kind of tuple */ - if (type != NULL_TREE) - { - mode_string = get_type_selective (type, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - if (val == NULL_TREE - || TREE_CODE (val) == ERROR_MARK) - return result; - else if (TREE_CODE (val) != TREE_LIST) - goto fail; - else - { - for ( ; ; ) - { - tree lo_val = TREE_PURPOSE (val); - tree hi_val = TREE_VALUE (val); - MYSTRING *val_string; - if (lo_val != NULL_TREE) - { - val_string = decode_constant_selective (lo_val, all_decls); - if (val_string->len) - APPEND (result, val_string->str); - FREE (val_string); - } - val_string = decode_constant_selective (hi_val, all_decls); - if (val_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, val_string->str); - } - FREE (val_string); - val = TREE_CHAIN (val); - if (val == NULL_TREE) - break; - } - } - } - return result; - case COMPONENT_REF: - { - mode_string = decode_constant_selective (TREE_OPERAND (init, 0), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - return result; - } - fail: - error ("decode_constant_selective: mode and value mismatch"); - break; - default: - error ("decode_constant_selective: cannot decode this mode"); - break; - } - return result; -} - -/* Assuming DECL is an ALIAS_DECL, return its prefix rename clause. */ - -static MYSTRING * -decode_prefix_rename (decl) - tree decl; -{ - MYSTRING *result = newstring (""); - if (DECL_OLD_PREFIX (decl) || DECL_NEW_PREFIX (decl)) - { - APPEND (result, "("); - if (DECL_OLD_PREFIX (decl)) - APPEND (result, IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl))); - APPEND (result, "->"); - if (DECL_NEW_PREFIX (decl)) - APPEND (result, IDENTIFIER_POINTER (DECL_NEW_PREFIX (decl))); - APPEND (result, ")!"); - } - if (DECL_POSTFIX_ALL (decl)) - APPEND (result, "ALL"); - else - APPEND (result, IDENTIFIER_POINTER (DECL_POSTFIX (decl))); - return result; -} - -static MYSTRING * -decode_decl (decl) - tree decl; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - tree type; - - switch ((enum chill_tree_code)TREE_CODE (decl)) - { - case VAR_DECL: - case BASED_DECL: - APPEND (result, "DCL "); - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl))); - APPEND (result, " "); - mode_string = get_type (TREE_TYPE (decl)); - APPEND (result, mode_string->str); - FREE (mode_string); - if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL) - { - APPEND (result, " BASED ("); - APPEND (result, IDENTIFIER_POINTER (DECL_ABSTRACT_ORIGIN (decl))); - APPEND (result, ")"); - } - break; - - case TYPE_DECL: - if (CH_DECL_SIGNAL (decl)) - { - /* this is really a signal */ - tree fields = TYPE_FIELDS (TREE_TYPE (decl)); - tree signame = DECL_NAME (decl); - tree sigdest; - - APPEND (result, "SIGNAL "); - APPEND (result, IDENTIFIER_POINTER (signame)); - if (IDENTIFIER_SIGNAL_DATA (signame)) - { - APPEND (result, " = ("); - for ( ; fields != NULL_TREE; - fields = TREE_CHAIN (fields)) - { - MYSTRING *mode_string; - - mode_string = get_type (TREE_TYPE (fields)); - APPEND (result, mode_string->str); - FREE (mode_string); - if (TREE_CHAIN (fields) != NULL_TREE) - APPEND (result, ", "); - } - APPEND (result, ")"); - } - sigdest = IDENTIFIER_SIGNAL_DEST (signame); - if (sigdest != NULL_TREE) - { - APPEND (result, " TO "); - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (sigdest))); - } - } - else - { - /* avoid defining a mode as itself */ - if (CH_NOVELTY (TREE_TYPE (decl)) == decl) - APPEND (result, "NEWMODE "); - else - APPEND (result, "SYNMODE "); - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl))); - APPEND (result, " = "); - mode_string = decode_mode (TREE_TYPE (decl)); - APPEND (result, mode_string->str); - FREE (mode_string); - } - break; - - case FUNCTION_DECL: - { - tree args; - - type = TREE_TYPE (decl); - args = TYPE_ARG_TYPES (type); - - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl))); - - if (CH_DECL_PROCESS (decl)) - APPEND (result, ": PROCESS ("); - else - APPEND (result, ": PROC ("); - - args = TYPE_ARG_TYPES (type); - - mode_string = print_proc_tail (type, args, 1); - APPEND (result, mode_string->str); - FREE (mode_string); - - /* generality */ - if (CH_DECL_GENERAL (decl)) - APPEND (result, " GENERAL"); - if (CH_DECL_SIMPLE (decl)) - APPEND (result, " SIMPLE"); - if (DECL_INLINE (decl)) - APPEND (result, " INLINE"); - if (CH_DECL_RECURSIVE (decl)) - APPEND (result, " RECURSIVE"); - APPEND (result, " END"); - } - break; - - case FIELD_DECL: - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl))); - APPEND (result, " "); - mode_string = get_type (TREE_TYPE (decl)); - APPEND (result, mode_string->str); - FREE (mode_string); - if (DECL_INITIAL (decl) != NULL_TREE) - { - mode_string = decode_layout (DECL_INITIAL (decl)); - APPEND (result, mode_string->str); - FREE (mode_string); - } -#if 0 - if (is_forbidden (DECL_NAME (decl), forbid)) - APPEND (result, " FORBID"); -#endif - break; - - case CONST_DECL: - if (DECL_INITIAL (decl) == NULL_TREE - || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK) - break; - APPEND (result, "SYN "); - APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl))); - APPEND (result, " "); - mode_string = get_type (TREE_TYPE (decl)); - APPEND (result, mode_string->str); - FREE (mode_string); - APPEND (result, " = "); - mode_string = decode_constant (DECL_INITIAL (decl)); - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case ALIAS_DECL: - /* If CH_DECL_GRANTED, decl was granted into this scope, and - so wasn't in the source code. */ - if (!CH_DECL_GRANTED (decl)) - { - static int restricted = 0; - - if (DECL_SEIZEFILE (decl) != use_seizefile_name - && DECL_SEIZEFILE (decl)) - { - use_seizefile_name = DECL_SEIZEFILE (decl); - restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name); - if (! restricted) - grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name)); - mark_use_seizefile_written (use_seizefile_name); - } - if (! restricted) - { - APPEND (result, "SEIZE "); - mode_string = decode_prefix_rename (decl); - APPEND (result, mode_string->str); - FREE (mode_string); - } - } - break; - - default: - APPEND (result, "----- not implemented ------"); - break; - } - return (result); -} - -static MYSTRING * -decode_decl_selective (decl, all_decls) - tree decl; - tree all_decls; -{ - MYSTRING *result = newstring (""); - MYSTRING *mode_string; - tree type; - - if (CH_ALREADY_GRANTED (decl)) - /* do nothing */ - return result; - - CH_ALREADY_GRANTED (decl) = 1; - - switch ((int)TREE_CODE (decl)) - { - case VAR_DECL: - case BASED_DECL: - mode_string = get_type_selective (TREE_TYPE (decl), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL) - { - mode_string = decode_mode_selective (DECL_ABSTRACT_ORIGIN (decl), all_decls); - if (mode_string->len) - PREPEND (result, mode_string->str); - FREE (mode_string); - } - break; - - case TYPE_DECL: - if (CH_DECL_SIGNAL (decl)) - { - /* this is really a signal */ - tree fields = TYPE_FIELDS (TREE_TYPE (decl)); - tree signame = DECL_NAME (decl); - tree sigdest; - - if (IDENTIFIER_SIGNAL_DATA (signame)) - { - for ( ; fields != NULL_TREE; - fields = TREE_CHAIN (fields)) - { - MYSTRING *mode_string; - - mode_string = get_type_selective (TREE_TYPE (fields), - all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - } - sigdest = IDENTIFIER_SIGNAL_DEST (signame); - if (sigdest != NULL_TREE) - { - mode_string = decode_mode_selective (DECL_NAME (sigdest), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - } - } - else - { - /* avoid defining a mode as itself */ - mode_string = decode_mode_selective (TREE_TYPE (decl), all_decls); - APPEND (result, mode_string->str); - FREE (mode_string); - } - break; - - case FUNCTION_DECL: - { - tree args; - - type = TREE_TYPE (decl); - args = TYPE_ARG_TYPES (type); - - args = TYPE_ARG_TYPES (type); - - mode_string = print_proc_tail_selective (type, args, all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - } - break; - - case FIELD_DECL: - mode_string = get_type_selective (TREE_TYPE (decl), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - break; - - case CONST_DECL: - if (DECL_INITIAL (decl) == NULL_TREE - || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK) - break; - mode_string = get_type_selective (TREE_TYPE (decl), all_decls); - if (mode_string->len) - APPEND (result, mode_string->str); - FREE (mode_string); - mode_string = decode_constant_selective (DECL_INITIAL (decl), all_decls); - if (mode_string->len) - { - MAYBE_NEWLINE (result); - APPEND (result, mode_string->str); - } - FREE (mode_string); - break; - - } - MAYBE_NEWLINE (result); - return (result); -} - -static void -globalize_decl (decl) - tree decl; -{ - if (!TREE_PUBLIC (decl) && DECL_NAME (decl) && - (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)) - { - const char *name = XSTR (XEXP (DECL_RTL (decl), 0), 0); - - if (!first_global_object_name) - first_global_object_name = name + (name[0] == '*'); - ASM_GLOBALIZE_LABEL (asm_out_file, name); - } -} - - -static void -grant_one_decl (decl) - tree decl; -{ - MYSTRING *result; - - if (DECL_SOURCE_LINE (decl) == 0) - return; - result = decode_decl (decl); - if (result->len) - { - APPEND (result, ";\n"); - APPEND (gstring, result->str); - } - FREE (result); -} - -static void -grant_one_decl_selective (decl, all_decls) - tree decl; - tree all_decls; -{ - MYSTRING *result; - MYSTRING *fixups; - - tree d = DECL_ABSTRACT_ORIGIN (decl); - - if (CH_ALREADY_GRANTED (d)) - /* already done */ - return; - - result = decode_decl (d); - if (!result->len) - { - /* nothing to do */ - FREE (result); - return; - } - - APPEND (result, ";\n"); - - /* now process all undefined items in the decl */ - fixups = decode_decl_selective (d, all_decls); - if (fixups->len) - { - PREPEND (result, fixups->str); - } - FREE (fixups); - - /* we have finished a decl */ - APPEND (selective_gstring, result->str); - FREE (result); -} - -static int -compare_memory_file (fname, buf) - const char *fname; - const char *buf; -{ - FILE *fb; - int c; - - /* check if we have something to write */ - if (!buf || !strlen (buf)) - return (0); - - if ((fb = fopen (fname, "r")) == NULL) - return (1); - - while ((c = getc (fb)) != EOF) - { - if (c != *buf++) - { - fclose (fb); - return (1); - } - } - fclose (fb); - return (*buf ? 1 : 0); -} - -void -write_grant_file () -{ - FILE *fb; - - /* We only write out the grant file if it has changed, - to avoid changing its time-stamp and triggering an - unnecessary 'make' action. Return if no change. */ - if (gstring == NULL || !spec_module_generated || - !compare_memory_file (grant_file_name, gstring->str)) - return; - - fb = fopen (grant_file_name, "w"); - if (fb == NULL) - fatal_io_error ("can't open %s", grant_file_name); - - /* write file. Due to problems with record sizes on VAX/VMS - write string to '\n' */ -#ifdef VMS - /* do it this way for VMS, cause of problems with - record sizes */ - p = gstring->str; - while (*p) - { - p1 = strchr (p, '\n'); - c = *++p1; - *p1 = '\0'; - fprintf (fb, "%s", p); - *p1 = c; - p = p1; - } -#else - /* faster way to write */ - if (write (fileno (fb), gstring->str, gstring->len) < 0) - { - int save_errno = errno; - - unlink (grant_file_name); - errno = save_errno; - fatal_io_error ("can't write to %s", grant_file_name); - } -#endif - fclose (fb); -} - - -/* handle grant statement */ - -void -set_default_grant_file () -{ - char *p, *tmp; - const char *fname; - - if (dump_base_name) - fname = dump_base_name; /* Probably invoked via gcc */ - else - { /* Probably invoked directly (not via gcc) */ - fname = asm_file_name; - if (!fname) - fname = main_input_filename ? main_input_filename : input_filename; - if (!fname) - return; - } - - p = strrchr (fname, '.'); - if (!p) - { - tmp = (char *) alloca (strlen (fname) + 10); - strcpy (tmp, fname); - } - else - { - int i = p - fname; - - tmp = (char *) alloca (i + 10); - strncpy (tmp, fname, i); - tmp[i] = '\0'; - } - strcat (tmp, ".grt"); - default_grant_file = build_string (strlen (tmp), tmp); - - grant_file_name = TREE_STRING_POINTER (default_grant_file); - - if (gstring == NULL) - gstring = newstring (""); - if (selective_gstring == NULL) - selective_gstring = newstring (""); -} - -/* Make DECL visible under the name NAME in the (fake) outermost scope. */ - -void -push_granted (name, decl) - tree name ATTRIBUTE_UNUSED, decl ATTRIBUTE_UNUSED; -{ -#if 0 - IDENTIFIER_GRANTED_VALUE (name) = decl; - granted_decls = tree_cons (name, decl, granted_decls); -#endif -} - -void -chill_grant (old_prefix, new_prefix, postfix, forbid) - tree old_prefix; - tree new_prefix; - tree postfix; - tree forbid; -{ - if (pass == 1) - { -#if 0 - tree old_name = old_prefix == NULL_TREE ? postfix - : get_identifier3 (IDENTIFIER_POINTER (old_prefix), - "!", IDENTIFIER_POINTER (postfix)); - tree new_name = new_prefix == NULL_TREE ? postfix - : get_identifier3 (IDENTIFIER_POINTER (new_prefix), - "!", IDENTIFIER_POINTER (postfix)); -#endif - tree alias = build_alias_decl (old_prefix, new_prefix, postfix); - CH_DECL_GRANTED (alias) = 1; - DECL_SEIZEFILE (alias) = current_seizefile_name; - TREE_CHAIN (alias) = current_module->granted_decls; - current_module->granted_decls = alias; - - if (forbid) - warning ("FORBID is not yet implemented"); /* FIXME */ - } -} - -/* flag GRANT ALL only once. Avoids search in case of GRANT ALL. */ -static int grant_all_seen = 0; - -/* check if a decl is in the list of granted decls. */ -static int -search_in_list (name, granted_decls) - tree name; - tree granted_decls; -{ - tree vars; - - for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars)) - if (DECL_SOURCE_LINE (vars)) - { - if (DECL_POSTFIX_ALL (vars)) - { - grant_all_seen = 1; - return 1; - } - else if (name == DECL_NAME (vars)) - return 1; - } - /* not found */ - return 0; -} - -static int -really_grant_this (decl, granted_decls) - tree decl; - tree granted_decls; -{ - /* we never grant labels at module level */ - if ((enum chill_tree_code)TREE_CODE (decl) == LABEL_DECL) - return 0; - - if (grant_all_seen) - return 1; - - switch ((enum chill_tree_code)TREE_CODE (decl)) - { - case VAR_DECL: - case BASED_DECL: - case FUNCTION_DECL: - return search_in_list (DECL_NAME (decl), granted_decls); - case ALIAS_DECL: - case CONST_DECL: - return 1; - case TYPE_DECL: - if (CH_DECL_SIGNAL (decl)) - return search_in_list (DECL_NAME (decl), granted_decls); - else - return 1; - default: - break; - } - - /* this nerver should happen */ - error_with_decl (decl, "function \"really_grant_this\" called for `%s'."); - return 1; -} - -/* Write a SPEC MODULE using the declarations in the list DECLS. */ -static int header_written = 0; -#define HEADER_TEMPLATE "--\n-- WARNING: this file was generated by\n\ --- GNUCHILL version %s\n-- based on gcc version %s\n--\n" - -void -write_spec_module (decls, granted_decls) - tree decls; - tree granted_decls; -{ - tree vars; - char *hdr; - - if (granted_decls == NULL_TREE) - return; - - use_seizefile_name = NULL_TREE; - - if (!header_written) - { - hdr = (char*) alloca (strlen (gnuchill_version) - + strlen (version_string) - + sizeof (HEADER_TEMPLATE) /* includes \0 */); - sprintf (hdr, HEADER_TEMPLATE, gnuchill_version, version_string); - APPEND (gstring, hdr); - header_written = 1; - } - APPEND (gstring, IDENTIFIER_POINTER (current_module->name)); - APPEND (gstring, ": SPEC MODULE\n"); - - /* first of all we look for GRANT ALL specified */ - search_in_list (NULL_TREE, granted_decls); - - if (grant_all_seen != 0) - { - /* write all identifiers to grant file */ - for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars)) - { - if (DECL_SOURCE_LINE (vars)) - { - if (DECL_NAME (vars)) - { - if ((TREE_CODE (vars) != CONST_DECL || !CH_DECL_ENUM (vars)) && - really_grant_this (vars, granted_decls)) - grant_one_decl (vars); - } - else if (DECL_POSTFIX_ALL (vars)) - { - static int restricted = 0; - - if (DECL_SEIZEFILE (vars) != use_seizefile_name - && DECL_SEIZEFILE (vars)) - { - use_seizefile_name = DECL_SEIZEFILE (vars); - restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name); - if (! restricted) - grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name)); - mark_use_seizefile_written (use_seizefile_name); - } - if (! restricted) - { - APPEND (gstring, "SEIZE ALL;\n"); - } - } - } - } - } - else - { - seizefile_list *wrk, *x; - - /* do a selective write to the grantfile. This will reduce the - size of a grantfile and speed up compilation of - modules depending on this grant file */ - - if (selective_gstring == 0) - selective_gstring = newstring (""); - - /* first of all process all SEIZE ALL's */ - for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars)) - { - if (DECL_SOURCE_LINE (vars) - && DECL_POSTFIX_ALL (vars)) - grant_seized_identifier (vars); - } - - /* now walk through granted decls */ - granted_decls = nreverse (granted_decls); - for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars)) - { - grant_one_decl_selective (vars, decls); - } - granted_decls = nreverse (granted_decls); - - /* append all SEIZES */ - wrk = selective_seizes; - while (wrk != 0) - { - x = wrk->next; - APPEND (gstring, wrk->seizes->str); - FREE (wrk->seizes); - free (wrk); - wrk = x; - } - selective_seizes = 0; - - /* append generated string to grant file */ - APPEND (gstring, selective_gstring->str); - FREE (selective_gstring); - selective_gstring = NULL; - } - - for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars)) - if (DECL_SOURCE_LINE (vars)) - { - MYSTRING *mode_string = decode_prefix_rename (vars); - APPEND (gstring, "GRANT "); - APPEND (gstring, mode_string->str); - FREE (mode_string); - APPEND (gstring, ";\n"); - } - - APPEND (gstring, "END;\n"); - spec_module_generated = 1; - - /* initialize this for next spec module */ - grant_all_seen = 0; -} - -/* - * after the dark comes, after all of the modules are at rest, - * we tuck the compilation unit to bed... A story in pass 1 - * and a hug-and-a-kiss goodnight in pass 2. - */ -void -chill_finish_compile () -{ - tree global_list; - tree chill_init_function; - - tasking_setup (); - build_enum_tables (); - - /* We only need an initializer function for the source file if - a) there's module-level code to be called, or - b) tasking-related stuff to be initialized. */ - if (module_init_list != NULL_TREE || tasking_list != NULL_TREE) - { - extern tree initializer_type; - static tree chill_init_name; - - /* declare the global initializer list */ - global_list = do_decl (get_identifier ("_ch_init_list"), - build_chill_pointer_type (initializer_type), 1, 0, - NULL_TREE, 1); - - /* Now, we're building the function which is the *real* - constructor - if there's any module-level code in this - source file, the compiler puts the file's initializer entry - onto the global initializer list, so each module's body code - will eventually get called, after all of the processes have - been started up. */ - - /* This is better done in pass 2 (when first_global_object_name - may have been set), but that is too late. - Perhaps rewrite this so nothing is done in pass 1. */ - if (pass == 1) - { - /* If we don't do this spoof, we get the name of the first - tasking_code variable, and not the file name. */ - char *q; - const char *tmp = first_global_object_name; - first_global_object_name = NULL; - chill_init_name = get_file_function_name ('I'); - first_global_object_name = tmp; - - /* strip off the file's extension, if any. */ - q = strrchr (IDENTIFIER_POINTER (chill_init_name), '.'); - if (q) - *q = '\0'; - } - - start_chill_function (chill_init_name, void_type_node, NULL_TREE, - NULL_TREE, NULL_TREE); - TREE_PUBLIC (current_function_decl) = 1; - chill_init_function = current_function_decl; - - /* For each module that we've compiled, that had module-level - code to be called, add its entry to the global initializer - list. */ - - if (pass == 2) - { - tree module_init; - - for (module_init = module_init_list; - module_init != NULL_TREE; - module_init = TREE_CHAIN (module_init)) - { - tree init_entry = TREE_VALUE (module_init); - - /* assign module_entry.next := _ch_init_list; */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (init_entry, - get_identifier ("__INIT_NEXT")), - global_list)); - - /* assign _ch_init_list := &module_entry; */ - expand_expr_stmt ( - build_chill_modify_expr (global_list, - build1 (ADDR_EXPR, ptr_type_node, init_entry))); - } - } - - tasking_registry (); - - make_decl_rtl (current_function_decl, NULL, 1); - - finish_chill_function (); - - if (pass == 2) - { - assemble_constructor (IDENTIFIER_POINTER (chill_init_name)); - globalize_decl (chill_init_function); - } - - /* ready now to link decls onto this list in pass 2. */ - module_init_list = NULL_TREE; - tasking_list = NULL_TREE; - } -} - - diff --git a/gcc/ch/hash.h b/gcc/ch/hash.h deleted file mode 100644 index 4d7c02ab7b0..00000000000 --- a/gcc/ch/hash.h +++ /dev/null @@ -1,1370 +0,0 @@ -/* C code produced by gperf version 2.7.1 (19981006 egcs) */ -/* Command-line: gperf -L C -F , 0, 0, 0 -D -E -S1 -p -j1 -i 1 -g -o -t -k* gperf.tmp */ -struct resword { - const char *name; - short token; - enum rid rid; - enum toktype { RESERVED, DIRECTIVE, PREDEF } flags; -}; -extern tree ridpointers []; -#ifdef __GNUC__ -__inline -#endif -static unsigned int hash PARAMS ((const char *, unsigned int)); -#ifdef __GNUC__ -__inline -#endif -struct resword *in_word_set PARAMS ((const char *, unsigned int)); -/* maximum key range = 2815, duplicates = 6 */ - -#ifdef __GNUC__ -__inline -#endif -static unsigned int -hash (str, len) - register const char *str; - register unsigned int len; -{ - static unsigned short asso_values[] = - { - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 4, 61, 80, 12, 350, - 91, 39, 3, 2, 2822, 4, 129, 155, 64, 46, - 65, 2822, 96, 13, 1, 135, 7, 2, 8, 124, - 7, 2822, 2822, 2822, 2822, 1, 2822, 94, 40, 127, - 21, 1, 81, 1, 1, 7, 2822, 3, 23, 74, - 255, 203, 70, 2822, 218, 1, 88, 124, 1, 6, - 10, 56, 40, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, 2822, - 2822, 2822, 2822, 2822, 2822, 2822 - }; - register int hval = len; - - switch (hval) - { - default: - case 30: - hval += asso_values[(unsigned char)str[29]]; - case 29: - hval += asso_values[(unsigned char)str[28]]; - case 28: - hval += asso_values[(unsigned char)str[27]]; - case 27: - hval += asso_values[(unsigned char)str[26]]; - case 26: - hval += asso_values[(unsigned char)str[25]]; - case 25: - hval += asso_values[(unsigned char)str[24]]; - case 24: - hval += asso_values[(unsigned char)str[23]]; - case 23: - hval += asso_values[(unsigned char)str[22]]; - case 22: - hval += asso_values[(unsigned char)str[21]]; - case 21: - hval += asso_values[(unsigned char)str[20]]; - case 20: - hval += asso_values[(unsigned char)str[19]]; - case 19: - hval += asso_values[(unsigned char)str[18]]; - case 18: - hval += asso_values[(unsigned char)str[17]]; - case 17: - hval += asso_values[(unsigned char)str[16]]; - case 16: - hval += asso_values[(unsigned char)str[15]]; - case 15: - hval += asso_values[(unsigned char)str[14]]; - case 14: - hval += asso_values[(unsigned char)str[13]]; - case 13: - hval += asso_values[(unsigned char)str[12]]; - case 12: - hval += asso_values[(unsigned char)str[11]]; - case 11: - hval += asso_values[(unsigned char)str[10]]; - case 10: - hval += asso_values[(unsigned char)str[9]]; - case 9: - hval += asso_values[(unsigned char)str[8]]; - case 8: - hval += asso_values[(unsigned char)str[7]]; - case 7: - hval += asso_values[(unsigned char)str[6]]; - case 6: - hval += asso_values[(unsigned char)str[5]]; - case 5: - hval += asso_values[(unsigned char)str[4]]; - case 4: - hval += asso_values[(unsigned char)str[3]]; - case 3: - hval += asso_values[(unsigned char)str[2]]; - case 2: - hval += asso_values[(unsigned char)str[1]]; - case 1: - hval += asso_values[(unsigned char)str[0]]; - break; - } - return hval; -} - -#ifdef __GNUC__ -__inline -#endif -struct resword * -in_word_set (str, len) - register const char *str; - register unsigned int len; -{ - enum - { - TOTAL_KEYWORDS = 300, - MIN_WORD_LENGTH = 2, - MAX_WORD_LENGTH = 30, - MIN_HASH_VALUE = 7, - MAX_HASH_VALUE = 2821 - }; - - static struct resword wordlist[] = - { - {"AT", AT, NORID, RESERVED}, - {"WITH", WITH, NORID, RESERVED}, - {"THIS", THIS, NORID, RESERVED}, - {"else", ELSE, NORID, RESERVED}, - {"while", WHILE, NORID, RESERVED}, - {"TO", TO, NORID, RESERVED}, - {"seize", SEIZE, NORID, RESERVED}, - {"DO", DO, NORID, RESERVED}, - {"OD", OD, NORID, RESERVED}, - {"BIT", BOOLS, RID_BOOLS, PREDEF}, - {"IN", IN, RID_IN, RESERVED}, - {"INIT", INIT, NORID, RESERVED}, - {"AND", AND, NORID, RESERVED}, - {"fi", FI, NORID, RESERVED}, - {"if", IF, NORID, RESERVED}, - {"set", SET, NORID, RESERVED}, - {"FI", FI, NORID, RESERVED}, - {"IF", IF, NORID, RESERVED}, - {"by", BY, NORID, RESERVED}, - {"this", THIS, NORID, RESERVED}, - {"with", WITH, NORID, RESERVED}, - {"STATIC", STATIC, NORID, RESERVED}, - {"exit", EXIT, NORID, RESERVED}, - {"ON", ON, NORID, RESERVED}, - {"NOT", NOT, NORID, RESERVED}, - {"elsif", ELSIF, NORID, RESERVED}, - {"START", START, NORID, RESERVED}, - {"list", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"POS", POS, NORID, RESERVED}, - {"DOWN", DOWN, NORID, RESERVED}, - {"STOP", STOP, NORID, RESERVED}, - {"BIN", BIN, NORID, RESERVED}, - {"GOTO", GOTO, NORID, RESERVED}, - {"bit", BOOLS, RID_BOOLS, PREDEF}, - {"OF", OF, NORID, RESERVED}, - {"all", ALL, NORID, RESERVED}, - {"OR", OR, NORID, RESERVED}, - {"ROW", ROW, NORID, RESERVED}, - {"LIST", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"XOR", XOR, NORID, RESERVED}, - {"PACK", PACK, NORID, RESERVED}, - {"based", BASED, NORID, RESERVED}, - {"step", STEP, NORID, RESERVED}, - {"page", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"asm", ASM_KEYWORD, NORID, RESERVED}, - {"dcl", DCL, NORID, RESERVED}, - {"ASM", ASM_KEYWORD, NORID, RESERVED}, - {"ANDIF", ANDIF, NORID, RESERVED}, - {"simple", SIMPLE, NORID, RESERVED}, - {"at", AT, NORID, RESERVED}, - {"OUT", PARAMATTR, RID_OUT, RESERVED}, - {"BY", BY, NORID, RESERVED}, - {"text", TEXT, NORID, RESERVED}, - {"FAR", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"up", UP, NORID, RESERVED}, - {"delay", DELAY, NORID, RESERVED}, - {"CHARS", CHARS, NORID, RESERVED}, - {"UP", UP, NORID, RESERVED}, - {"spec", SPEC, NORID, RESERVED}, - {"SYN", SYN, NORID, RESERVED}, - {"GRANT", GRANT, NORID, RESERVED}, - {"MOD", MOD, NORID, RESERVED}, - {"small", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"DCL", DCL, NORID, RESERVED}, - {"ever", EVER, NORID, RESERVED}, - {"do", DO, NORID, RESERVED}, - {"od", OD, NORID, RESERVED}, - {"case", CASE, NORID, RESERVED}, - {"esac", ESAC, NORID, RESERVED}, - {"CCITT_OS", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"FOR", FOR, NORID, RESERVED}, - {"ORIF", ORIF, NORID, RESERVED}, - {"BODY", BODY, NORID, RESERVED}, - {"INOUT", PARAMATTR, RID_INOUT, RESERVED}, - {"SIGNAL", SIGNAL, NORID, RESERVED}, - {"LOC", LOC, NORID, RESERVED}, - {"NOLIST", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"even", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"in", IN, RID_IN, RESERVED}, - {"ALL", ALL, NORID, RESERVED}, - {"NOPACK", NOPACK, NORID, RESERVED}, - {"call", CALL, NORID, RESERVED}, - {"pos", POS, NORID, RESERVED}, - {"end", END, NORID, RESERVED}, - {"send", SEND, NORID, RESERVED}, - {"of", OF, NORID, RESERVED}, - {"PROC", PROC, NORID, RESERVED}, - {"to", TO, NORID, RESERVED}, - {"rem", REM, NORID, RESERVED}, - {"pack", PACK, NORID, RESERVED}, - {"BOOLS", BOOLS, RID_BOOLS, RESERVED}, - {"mod", MOD, NORID, RESERVED}, - {"ref", REF, NORID, RESERVED}, - {"use_seize_file", USE_SEIZE_FILE, NORID, DIRECTIVE}, - {"bin", BIN, NORID, RESERVED}, - {"medium", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"begin", BEGINTOKEN, NORID, RESERVED}, - {"FORBID", FORBID, NORID, RESERVED}, - {"syn", SYN, NORID, RESERVED}, - {"body", BODY, NORID, RESERVED}, - {"ARRAY", ARRAY, NORID, RESERVED}, - {"STRUCT", STRUCT, NORID, RESERVED}, - {"read", READ, RID_READ, RESERVED}, - {"cycle", CYCLE, NORID, RESERVED}, - {"large", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"VARYING", VARYING, NORID, RESERVED}, - {"CALL", CALL, NORID, RESERVED}, - {"then", THEN, NORID, RESERVED}, - {"event", EVENT, NORID, RESERVED}, - {"cause", CAUSE, NORID, RESERVED}, - {"loc", LOC, NORID, RESERVED}, - {"access", ACCESS, NORID, RESERVED}, - {"init", INIT, NORID, RESERVED}, - {"receive", RECEIVE, NORID, RESERVED}, - {"TEXT", TEXT, NORID, RESERVED}, - {"EXIT", EXIT, NORID, RESERVED}, - {"stop", STOP, NORID, RESERVED}, - {"SET", SET, NORID, RESERVED}, - {"and", AND, NORID, RESERVED}, - {"signal", SIGNAL, NORID, RESERVED}, - {"far", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"assert", ASSERT, NORID, RESERVED}, - {"static", STATIC, NORID, RESERVED}, - {"debug_types", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"prefixed", PREFIXED, NORID, RESERVED}, - {"out", PARAMATTR, RID_OUT, RESERVED}, - {"THEN", THEN, NORID, RESERVED}, - {"or", OR, NORID, RESERVED}, - {"END", END, NORID, RESERVED}, - {"row", ROW, NORID, RESERVED}, - {"STEP", STEP, NORID, RESERVED}, - {"xor", XOR, NORID, RESERVED}, - {"SMALL", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"PRIORITY", PRIORITY, NORID, RESERVED}, - {"SEND", SEND, NORID, RESERVED}, - {"BASED", BASED, NORID, RESERVED}, - {"chars", CHARS, NORID, RESERVED}, - {"DYNAMIC", DYNAMIC, RID_DYNAMIC, RESERVED}, - {"CASE", CASE, NORID, RESERVED}, - {"ESAC", ESAC, NORID, RESERVED}, - {"module", MODULE, NORID, RESERVED}, - {"on", ON, NORID, RESERVED}, - {"result", RESULT, NORID, RESERVED}, - {"PAGE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"andif", ANDIF, NORID, RESERVED}, - {"READ", READ, RID_READ, RESERVED}, - {"bools", BOOLS, RID_BOOLS, RESERVED}, - {"ASSERT", ASSERT, NORID, RESERVED}, - {"debug_lines", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"after", AFTER, NORID, RESERVED}, - {"ALL_STATIC_ON", ALL_STATIC_ON, NORID, DIRECTIVE}, - {"down", DOWN, NORID, RESERVED}, - {"WHILE", WHILE, NORID, RESERVED}, - {"start", START, NORID, RESERVED}, - {"optimize", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"goto", GOTO, NORID, RESERVED}, - {"for", FOR, NORID, RESERVED}, - {"SPEC", SPEC, NORID, RESERVED}, - {"orif", ORIF, NORID, RESERVED}, - {"BEGIN", BEGINTOKEN, NORID, RESERVED}, - {"REF", REF, NORID, RESERVED}, - {"OPTIMIZATION_WINDOW", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"ACCESS", ACCESS, NORID, RESERVED}, - {"AFTER", AFTER, NORID, RESERVED}, - {"not", NOT, NORID, RESERVED}, - {"buffer", BUFFER, NORID, RESERVED}, - {"inline", INLINE, RID_INLINE, RESERVED}, - {"CONTEXT", CONTEXT, NORID, RESERVED}, - {"RANGE", RANGE, NORID, RESERVED}, - {"newmode", NEWMODE, NORID, RESERVED}, - {"range", RANGE, NORID, RESERVED}, - {"forbid", FORBID, NORID, RESERVED}, - {"nolist", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"CAUSE", CAUSE, NORID, RESERVED}, - {"ELSIF", ELSIF, NORID, RESERVED}, - {"remote", REMOTE, NORID, RESERVED}, - {"timeout", TIMEOUT, NORID, RESERVED}, - {"powerset", POWERSET, NORID, RESERVED}, - {"debug_symbols", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"general", GENERAL, NORID, RESERVED}, - {"REGION", REGION, NORID, RESERVED}, - {"REM", REM, NORID, RESERVED}, - {"ALL_STATIC_OFF", ALL_STATIC_OFF, NORID, DIRECTIVE}, - {"INLINE", INLINE, RID_INLINE, RESERVED}, - {"synmode", SYNMODE, NORID, RESERVED}, - {"proc", PROC, NORID, RESERVED}, - {"LARGE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"DELAY", DELAY, NORID, RESERVED}, - {"process", PROCESS, NORID, RESERVED}, - {"OPTIMIZE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"varying", VARYING, NORID, RESERVED}, - {"dynamic", DYNAMIC, RID_DYNAMIC, RESERVED}, - {"ccitt_os", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"struct", STRUCT, NORID, RESERVED}, - {"grant", GRANT, NORID, RESERVED}, - {"empty_off", EMPTY_OFF, NORID, DIRECTIVE}, - {"PROCESS", PROCESS, NORID, RESERVED}, - {"RANGE_ON", RANGE_ON, NORID, DIRECTIVE}, - {"inout", PARAMATTR, RID_INOUT, RESERVED}, - {"array", ARRAY, NORID, RESERVED}, - {"region", REGION, NORID, RESERVED}, - {"TIMEOUT", TIMEOUT, NORID, RESERVED}, - {"recursive", RECURSIVE, NORID, RESERVED}, - {"event_code", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"NONREF", NONREF, NORID, RESERVED}, - {"SIMPLE", SIMPLE, NORID, RESERVED}, - {"SEIZE", SEIZE, NORID, RESERVED}, - {"RESULT", RESULT, NORID, RESERVED}, - {"multiple_data_segs", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"signal_code", SIGNAL_CODE, NORID, DIRECTIVE}, - {"RETURN", RETURN, NORID, RESERVED}, - {"CONTINUE", CONTINUE, NORID, RESERVED}, - {"SIGNAL_CODE", SIGNAL_CODE, NORID, DIRECTIVE}, - {"empty_on", EMPTY_ON, NORID, DIRECTIVE}, - {"nopack", NOPACK, NORID, RESERVED}, - {"RETURNS", RETURNS, NORID, RESERVED}, - {"CYCLE", CYCLE, NORID, RESERVED}, - {"SYNMODE", SYNMODE, NORID, RESERVED}, - {"exceptions", EXCEPTIONS, NORID, RESERVED}, - {"EVEN", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"PRINT_O_CODE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"EVENT", EVENT, NORID, RESERVED}, - {"context", CONTEXT, NORID, RESERVED}, - {"RANGE_OFF", RANGE_OFF, NORID, DIRECTIVE}, - {"EVER", EVER, NORID, RESERVED}, - {"EMPTY_ON", EMPTY_ON, NORID, DIRECTIVE}, - {"MEDIUM", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"BUFFER", BUFFER, NORID, RESERVED}, - {"MODULE", MODULE, NORID, RESERVED}, - {"grant_file_size", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"ELSE", ELSE, NORID, RESERVED}, - {"process_type", PROCESS_TYPE_TOKEN, NORID, DIRECTIVE}, - {"priority", PRIORITY, NORID, RESERVED}, - {"buffer_code", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"return", RETURN, NORID, RESERVED}, - {"returns", RETURNS, NORID, RESERVED}, - {"all_static_off", ALL_STATIC_OFF, NORID, DIRECTIVE}, - {"POWERSET", POWERSET, NORID, RESERVED}, - {"EMPTY_OFF", EMPTY_OFF, NORID, DIRECTIVE}, - {"range_off", RANGE_OFF, NORID, DIRECTIVE}, - {"signal_max_length", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"PREFIXED", PREFIXED, NORID, RESERVED}, - {"NEWMODE", NEWMODE, NORID, RESERVED}, - {"EXCEPTIONS", EXCEPTIONS, NORID, RESERVED}, - {"REMOTE", REMOTE, NORID, RESERVED}, - {"SHORT_PRED_SUCC", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"all_static_on", ALL_STATIC_ON, NORID, DIRECTIVE}, - {"nonref", NONREF, NORID, RESERVED}, - {"SIGNAL_MAX_LENGTH", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"REENTRANT", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"range_on", RANGE_ON, NORID, DIRECTIVE}, - {"GENERAL", GENERAL, NORID, RESERVED}, - {"continue", CONTINUE, NORID, RESERVED}, - {"STATE_ROUTINE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"EXTRA_CONST_SEG", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"use_seize_file_restricted", USE_SEIZE_FILE_RESTRICTED, NORID, DIRECTIVE}, - {"ONLY_FOR_TARGET", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"extra_const_seg", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"multiple_const_segs", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"RECURSIVE", RECURSIVE, NORID, RESERVED}, - {"DEBUG_SYMBOLS", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"DEBUG_TYPES", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"GRANT_FILE_SIZE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"DEBUG_LINES", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"ONLY_FOR_SIMULATION", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"state_routine", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"generate_set_names", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"print_o_code", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"PROCESS_TYPE", PROCESS_TYPE_TOKEN, NORID, DIRECTIVE}, - {"short_pred_succ", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"reentrant", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"RECEIVE", RECEIVE, NORID, RESERVED}, - {"EVENT_CODE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"optimize_runtime", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"SUPPORT_CAUSING_ADDRESS", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"print_symbol_table", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"REENTRANT_ALL", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"PRINT_SYMBOL_TABLE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"BUFFER_CODE", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"generate_all_set_names", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"NO_OVERLAP_CHECK", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"no_overlap_check", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"reentrant_all", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"MULTIPLE_DATA_SEGS", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"OPTIMIZE_RUNTIME", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"only_for_target", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"MULTIPLE_CONST_SEGS", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"optimization_window", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"support_causing_address", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"USE_SEIZE_FILE", USE_SEIZE_FILE, NORID, DIRECTIVE}, - {"SEND_SIGNAL_DEFAULT_PRIORITY", SEND_SIGNAL_DEFAULT_PRIORITY, NORID, DIRECTIVE}, - {"make_publics_for_discrete_syns", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"only_for_simulation", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"send_signal_default_priority", SEND_SIGNAL_DEFAULT_PRIORITY, NORID, DIRECTIVE}, - {"send_buffer_default_priority", SEND_BUFFER_DEFAULT_PRIORITY, NORID, DIRECTIVE}, - {"GENERATE_SET_NAMES", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"MAKE_PUBLICS_FOR_DISCRETE_SYNS", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"SEND_BUFFER_DEFAULT_PRIORITY", SEND_BUFFER_DEFAULT_PRIORITY, NORID, DIRECTIVE}, - {"GENERATE_ALL_SET_NAMES", IGNORED_DIRECTIVE, NORID, DIRECTIVE}, - {"USE_SEIZE_FILE_RESTRICTED", USE_SEIZE_FILE_RESTRICTED, NORID, DIRECTIVE} - }; - - if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH) - { - register int key = hash (str, len); - - if (key <= MAX_HASH_VALUE && key >= MIN_HASH_VALUE) - { - register struct resword *wordptr; - register struct resword *wordendptr; - register struct resword *resword; - - switch (key - 7) - { - case 0: - resword = &wordlist[0]; - goto compare; - case 5: - resword = &wordlist[1]; - goto compare; - case 16: - resword = &wordlist[2]; - goto compare; - case 23: - resword = &wordlist[3]; - goto compare; - case 36: - resword = &wordlist[4]; - goto compare; - case 42: - resword = &wordlist[5]; - goto compare; - case 48: - resword = &wordlist[6]; - goto compare; - case 53: - wordptr = &wordlist[7]; - wordendptr = wordptr + 2; - goto multicompare; - case 60: - resword = &wordlist[9]; - goto compare; - case 61: - resword = &wordlist[10]; - goto compare; - case 66: - resword = &wordlist[11]; - goto compare; - case 76: - resword = &wordlist[12]; - goto compare; - case 83: - wordptr = &wordlist[13]; - wordendptr = wordptr + 2; - goto multicompare; - case 86: - resword = &wordlist[15]; - goto compare; - case 88: - wordptr = &wordlist[16]; - wordendptr = wordptr + 2; - goto multicompare; - case 91: - resword = &wordlist[18]; - goto compare; - case 94: - resword = &wordlist[19]; - goto compare; - case 99: - resword = &wordlist[20]; - goto compare; - case 100: - resword = &wordlist[21]; - goto compare; - case 103: - resword = &wordlist[22]; - goto compare; - case 105: - resword = &wordlist[23]; - goto compare; - case 107: - resword = &wordlist[24]; - goto compare; - case 111: - resword = &wordlist[25]; - goto compare; - case 113: - resword = &wordlist[26]; - goto compare; - case 116: - resword = &wordlist[27]; - goto compare; - case 120: - resword = &wordlist[28]; - goto compare; - case 121: - resword = &wordlist[29]; - goto compare; - case 122: - resword = &wordlist[30]; - goto compare; - case 123: - resword = &wordlist[31]; - goto compare; - case 129: - resword = &wordlist[32]; - goto compare; - case 131: - resword = &wordlist[33]; - goto compare; - case 132: - resword = &wordlist[34]; - goto compare; - case 136: - resword = &wordlist[35]; - goto compare; - case 137: - resword = &wordlist[36]; - goto compare; - case 140: - resword = &wordlist[37]; - goto compare; - case 142: - resword = &wordlist[38]; - goto compare; - case 146: - resword = &wordlist[39]; - goto compare; - case 150: - resword = &wordlist[40]; - goto compare; - case 155: - resword = &wordlist[41]; - goto compare; - case 157: - resword = &wordlist[42]; - goto compare; - case 163: - resword = &wordlist[43]; - goto compare; - case 165: - resword = &wordlist[44]; - goto compare; - case 167: - resword = &wordlist[45]; - goto compare; - case 168: - resword = &wordlist[46]; - goto compare; - case 171: - resword = &wordlist[47]; - goto compare; - case 175: - resword = &wordlist[48]; - goto compare; - case 177: - resword = &wordlist[49]; - goto compare; - case 178: - resword = &wordlist[50]; - goto compare; - case 180: - resword = &wordlist[51]; - goto compare; - case 184: - resword = &wordlist[52]; - goto compare; - case 187: - resword = &wordlist[53]; - goto compare; - case 189: - resword = &wordlist[54]; - goto compare; - case 193: - resword = &wordlist[55]; - goto compare; - case 194: - resword = &wordlist[56]; - goto compare; - case 195: - resword = &wordlist[57]; - goto compare; - case 196: - resword = &wordlist[58]; - goto compare; - case 197: - resword = &wordlist[59]; - goto compare; - case 202: - resword = &wordlist[60]; - goto compare; - case 209: - resword = &wordlist[61]; - goto compare; - case 213: - resword = &wordlist[62]; - goto compare; - case 217: - resword = &wordlist[63]; - goto compare; - case 218: - resword = &wordlist[64]; - goto compare; - case 219: - wordptr = &wordlist[65]; - wordendptr = wordptr + 2; - goto multicompare; - case 220: - wordptr = &wordlist[67]; - wordendptr = wordptr + 2; - goto multicompare; - case 225: - resword = &wordlist[69]; - goto compare; - case 229: - resword = &wordlist[70]; - goto compare; - case 232: - resword = &wordlist[71]; - goto compare; - case 240: - resword = &wordlist[72]; - goto compare; - case 246: - resword = &wordlist[73]; - goto compare; - case 250: - resword = &wordlist[74]; - goto compare; - case 251: - resword = &wordlist[75]; - goto compare; - case 254: - resword = &wordlist[76]; - goto compare; - case 255: - resword = &wordlist[77]; - goto compare; - case 257: - resword = &wordlist[78]; - goto compare; - case 258: - resword = &wordlist[79]; - goto compare; - case 262: - resword = &wordlist[80]; - goto compare; - case 264: - resword = &wordlist[81]; - goto compare; - case 270: - resword = &wordlist[82]; - goto compare; - case 273: - resword = &wordlist[83]; - goto compare; - case 275: - resword = &wordlist[84]; - goto compare; - case 279: - resword = &wordlist[85]; - goto compare; - case 284: - resword = &wordlist[86]; - goto compare; - case 286: - resword = &wordlist[87]; - goto compare; - case 289: - resword = &wordlist[88]; - goto compare; - case 291: - resword = &wordlist[89]; - goto compare; - case 293: - resword = &wordlist[90]; - goto compare; - case 294: - resword = &wordlist[91]; - goto compare; - case 296: - resword = &wordlist[92]; - goto compare; - case 297: - resword = &wordlist[93]; - goto compare; - case 298: - resword = &wordlist[94]; - goto compare; - case 300: - resword = &wordlist[95]; - goto compare; - case 302: - resword = &wordlist[96]; - goto compare; - case 307: - resword = &wordlist[97]; - goto compare; - case 308: - resword = &wordlist[98]; - goto compare; - case 317: - resword = &wordlist[99]; - goto compare; - case 322: - resword = &wordlist[100]; - goto compare; - case 325: - resword = &wordlist[101]; - goto compare; - case 331: - resword = &wordlist[102]; - goto compare; - case 332: - resword = &wordlist[103]; - goto compare; - case 335: - resword = &wordlist[104]; - goto compare; - case 336: - resword = &wordlist[105]; - goto compare; - case 339: - resword = &wordlist[106]; - goto compare; - case 342: - resword = &wordlist[107]; - goto compare; - case 344: - resword = &wordlist[108]; - goto compare; - case 345: - resword = &wordlist[109]; - goto compare; - case 349: - resword = &wordlist[110]; - goto compare; - case 350: - resword = &wordlist[111]; - goto compare; - case 354: - resword = &wordlist[112]; - goto compare; - case 356: - resword = &wordlist[113]; - goto compare; - case 357: - resword = &wordlist[114]; - goto compare; - case 358: - resword = &wordlist[115]; - goto compare; - case 359: - resword = &wordlist[116]; - goto compare; - case 360: - resword = &wordlist[117]; - goto compare; - case 366: - resword = &wordlist[118]; - goto compare; - case 380: - resword = &wordlist[119]; - goto compare; - case 389: - resword = &wordlist[120]; - goto compare; - case 402: - resword = &wordlist[121]; - goto compare; - case 404: - resword = &wordlist[122]; - goto compare; - case 408: - resword = &wordlist[123]; - goto compare; - case 410: - resword = &wordlist[124]; - goto compare; - case 411: - resword = &wordlist[125]; - goto compare; - case 415: - resword = &wordlist[126]; - goto compare; - case 416: - resword = &wordlist[127]; - goto compare; - case 422: - resword = &wordlist[128]; - goto compare; - case 423: - resword = &wordlist[129]; - goto compare; - case 426: - resword = &wordlist[130]; - goto compare; - case 427: - resword = &wordlist[131]; - goto compare; - case 428: - resword = &wordlist[132]; - goto compare; - case 433: - resword = &wordlist[133]; - goto compare; - case 436: - resword = &wordlist[134]; - goto compare; - case 438: - resword = &wordlist[135]; - goto compare; - case 439: - resword = &wordlist[136]; - goto compare; - case 441: - resword = &wordlist[137]; - goto compare; - case 444: - wordptr = &wordlist[138]; - wordendptr = wordptr + 2; - goto multicompare; - case 445: - resword = &wordlist[140]; - goto compare; - case 453: - resword = &wordlist[141]; - goto compare; - case 454: - resword = &wordlist[142]; - goto compare; - case 455: - resword = &wordlist[143]; - goto compare; - case 456: - resword = &wordlist[144]; - goto compare; - case 459: - resword = &wordlist[145]; - goto compare; - case 468: - resword = &wordlist[146]; - goto compare; - case 476: - resword = &wordlist[147]; - goto compare; - case 479: - resword = &wordlist[148]; - goto compare; - case 480: - resword = &wordlist[149]; - goto compare; - case 481: - resword = &wordlist[150]; - goto compare; - case 482: - resword = &wordlist[151]; - goto compare; - case 484: - resword = &wordlist[152]; - goto compare; - case 487: - resword = &wordlist[153]; - goto compare; - case 491: - resword = &wordlist[154]; - goto compare; - case 492: - resword = &wordlist[155]; - goto compare; - case 498: - resword = &wordlist[156]; - goto compare; - case 505: - resword = &wordlist[157]; - goto compare; - case 506: - resword = &wordlist[158]; - goto compare; - case 514: - resword = &wordlist[159]; - goto compare; - case 533: - resword = &wordlist[160]; - goto compare; - case 536: - resword = &wordlist[161]; - goto compare; - case 539: - resword = &wordlist[162]; - goto compare; - case 540: - resword = &wordlist[163]; - goto compare; - case 542: - resword = &wordlist[164]; - goto compare; - case 544: - resword = &wordlist[165]; - goto compare; - case 547: - resword = &wordlist[166]; - goto compare; - case 550: - resword = &wordlist[167]; - goto compare; - case 551: - resword = &wordlist[168]; - goto compare; - case 561: - resword = &wordlist[169]; - goto compare; - case 567: - resword = &wordlist[170]; - goto compare; - case 569: - resword = &wordlist[171]; - goto compare; - case 576: - resword = &wordlist[172]; - goto compare; - case 580: - resword = &wordlist[173]; - goto compare; - case 583: - resword = &wordlist[174]; - goto compare; - case 584: - resword = &wordlist[175]; - goto compare; - case 585: - resword = &wordlist[176]; - goto compare; - case 589: - resword = &wordlist[177]; - goto compare; - case 592: - resword = &wordlist[178]; - goto compare; - case 593: - resword = &wordlist[179]; - goto compare; - case 596: - resword = &wordlist[180]; - goto compare; - case 597: - resword = &wordlist[181]; - goto compare; - case 600: - resword = &wordlist[182]; - goto compare; - case 610: - resword = &wordlist[183]; - goto compare; - case 611: - resword = &wordlist[184]; - goto compare; - case 615: - resword = &wordlist[185]; - goto compare; - case 616: - resword = &wordlist[186]; - goto compare; - case 617: - resword = &wordlist[187]; - goto compare; - case 621: - resword = &wordlist[188]; - goto compare; - case 629: - resword = &wordlist[189]; - goto compare; - case 632: - resword = &wordlist[190]; - goto compare; - case 634: - resword = &wordlist[191]; - goto compare; - case 643: - resword = &wordlist[192]; - goto compare; - case 645: - resword = &wordlist[193]; - goto compare; - case 654: - resword = &wordlist[194]; - goto compare; - case 657: - resword = &wordlist[195]; - goto compare; - case 663: - resword = &wordlist[196]; - goto compare; - case 665: - resword = &wordlist[197]; - goto compare; - case 675: - resword = &wordlist[198]; - goto compare; - case 678: - resword = &wordlist[199]; - goto compare; - case 684: - resword = &wordlist[200]; - goto compare; - case 690: - resword = &wordlist[201]; - goto compare; - case 700: - resword = &wordlist[202]; - goto compare; - case 702: - resword = &wordlist[203]; - goto compare; - case 710: - resword = &wordlist[204]; - goto compare; - case 713: - resword = &wordlist[205]; - goto compare; - case 720: - resword = &wordlist[206]; - goto compare; - case 723: - resword = &wordlist[207]; - goto compare; - case 724: - resword = &wordlist[208]; - goto compare; - case 738: - resword = &wordlist[209]; - goto compare; - case 741: - resword = &wordlist[210]; - goto compare; - case 743: - resword = &wordlist[211]; - goto compare; - case 744: - resword = &wordlist[212]; - goto compare; - case 749: - resword = &wordlist[213]; - goto compare; - case 751: - resword = &wordlist[214]; - goto compare; - case 755: - resword = &wordlist[215]; - goto compare; - case 761: - resword = &wordlist[216]; - goto compare; - case 764: - resword = &wordlist[217]; - goto compare; - case 766: - resword = &wordlist[218]; - goto compare; - case 768: - resword = &wordlist[219]; - goto compare; - case 769: - resword = &wordlist[220]; - goto compare; - case 770: - resword = &wordlist[221]; - goto compare; - case 772: - resword = &wordlist[222]; - goto compare; - case 784: - resword = &wordlist[223]; - goto compare; - case 800: - resword = &wordlist[224]; - goto compare; - case 807: - resword = &wordlist[225]; - goto compare; - case 808: - resword = &wordlist[226]; - goto compare; - case 823: - resword = &wordlist[227]; - goto compare; - case 826: - resword = &wordlist[228]; - goto compare; - case 827: - resword = &wordlist[229]; - goto compare; - case 839: - resword = &wordlist[230]; - goto compare; - case 842: - resword = &wordlist[231]; - goto compare; - case 868: - resword = &wordlist[232]; - goto compare; - case 902: - resword = &wordlist[233]; - goto compare; - case 903: - resword = &wordlist[234]; - goto compare; - case 905: - resword = &wordlist[235]; - goto compare; - case 919: - resword = &wordlist[236]; - goto compare; - case 924: - resword = &wordlist[237]; - goto compare; - case 926: - resword = &wordlist[238]; - goto compare; - case 937: - resword = &wordlist[239]; - goto compare; - case 940: - resword = &wordlist[240]; - goto compare; - case 975: - resword = &wordlist[241]; - goto compare; - case 979: - resword = &wordlist[242]; - goto compare; - case 982: - resword = &wordlist[243]; - goto compare; - case 997: - resword = &wordlist[244]; - goto compare; - case 1000: - resword = &wordlist[245]; - goto compare; - case 1011: - resword = &wordlist[246]; - goto compare; - case 1012: - resword = &wordlist[247]; - goto compare; - case 1016: - resword = &wordlist[248]; - goto compare; - case 1028: - resword = &wordlist[249]; - goto compare; - case 1029: - resword = &wordlist[250]; - goto compare; - case 1032: - resword = &wordlist[251]; - goto compare; - case 1061: - resword = &wordlist[252]; - goto compare; - case 1070: - resword = &wordlist[253]; - goto compare; - case 1075: - resword = &wordlist[254]; - goto compare; - case 1079: - resword = &wordlist[255]; - goto compare; - case 1097: - resword = &wordlist[256]; - goto compare; - case 1098: - resword = &wordlist[257]; - goto compare; - case 1102: - resword = &wordlist[258]; - goto compare; - case 1131: - resword = &wordlist[259]; - goto compare; - case 1145: - resword = &wordlist[260]; - goto compare; - case 1155: - resword = &wordlist[261]; - goto compare; - case 1158: - resword = &wordlist[262]; - goto compare; - case 1160: - resword = &wordlist[263]; - goto compare; - case 1161: - resword = &wordlist[264]; - goto compare; - case 1175: - resword = &wordlist[265]; - goto compare; - case 1187: - resword = &wordlist[266]; - goto compare; - case 1200: - resword = &wordlist[267]; - goto compare; - case 1209: - resword = &wordlist[268]; - goto compare; - case 1210: - resword = &wordlist[269]; - goto compare; - case 1220: - resword = &wordlist[270]; - goto compare; - case 1235: - resword = &wordlist[271]; - goto compare; - case 1264: - resword = &wordlist[272]; - goto compare; - case 1267: - resword = &wordlist[273]; - goto compare; - case 1276: - resword = &wordlist[274]; - goto compare; - case 1294: - resword = &wordlist[275]; - goto compare; - case 1295: - resword = &wordlist[276]; - goto compare; - case 1314: - resword = &wordlist[277]; - goto compare; - case 1317: - resword = &wordlist[278]; - goto compare; - case 1332: - resword = &wordlist[279]; - goto compare; - case 1335: - resword = &wordlist[280]; - goto compare; - case 1338: - resword = &wordlist[281]; - goto compare; - case 1365: - resword = &wordlist[282]; - goto compare; - case 1415: - resword = &wordlist[283]; - goto compare; - case 1441: - resword = &wordlist[284]; - goto compare; - case 1539: - resword = &wordlist[285]; - goto compare; - case 1599: - resword = &wordlist[286]; - goto compare; - case 1647: - resword = &wordlist[287]; - goto compare; - case 1758: - resword = &wordlist[288]; - goto compare; - case 1801: - resword = &wordlist[289]; - goto compare; - case 1868: - resword = &wordlist[290]; - goto compare; - case 1870: - resword = &wordlist[291]; - goto compare; - case 1929: - resword = &wordlist[292]; - goto compare; - case 1982: - resword = &wordlist[293]; - goto compare; - case 2146: - resword = &wordlist[294]; - goto compare; - case 2217: - resword = &wordlist[295]; - goto compare; - case 2376: - resword = &wordlist[296]; - goto compare; - case 2441: - resword = &wordlist[297]; - goto compare; - case 2484: - resword = &wordlist[298]; - goto compare; - case 2814: - resword = &wordlist[299]; - goto compare; - } - return 0; - multicompare: - while (wordptr < wordendptr) - { - register const char *s = wordptr->name; - - if (*str == *s && !strcmp (str + 1, s + 1)) - return wordptr; - wordptr++; - } - return 0; - compare: - { - register const char *s = resword->name; - - if (*str == *s && !strcmp (str + 1, s + 1)) - return resword; - } - } - } - return 0; -} diff --git a/gcc/ch/inout.c b/gcc/ch/inout.c deleted file mode 100644 index c4593471eaf..00000000000 --- a/gcc/ch/inout.c +++ /dev/null @@ -1,4691 +0,0 @@ -/* Implement I/O-related actions for CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - Free Software Foundation, Inc. - - This file is part of GNU CC. - - GNU CC is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. - - GNU CC is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with GNU CC; see the file COPYING. If not, write to - the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "rtl.h" -#include "lex.h" -#include "flags.h" -#include "input.h" -#include "assert.h" -#include "toplev.h" - -/* set non-zero if input text is forced to lowercase */ -extern int ignore_case; - -/* set non-zero if special words are to be entered in uppercase */ -extern int special_UC; - -static int intsize_of_charsexpr PARAMS ((tree)); -static tree add_enum_to_list PARAMS ((tree, tree)); -static void build_chill_io_list_type PARAMS ((void)); -static void build_io_types PARAMS ((void)); -static void declare_predefined_file PARAMS ((const char *, const char *)); -static tree build_access_part PARAMS ((void)); -static tree textlocation_mode PARAMS ((tree)); -static int check_assoc PARAMS ((tree, int, const char *)); -static tree assoc_call PARAMS ((tree, tree, const char *)); -static int check_transfer PARAMS ((tree, int, const char *)); -static int connect_process_optionals PARAMS ((tree, tree *, tree *, tree)); -static tree connect_text PARAMS ((tree, tree, tree, tree)); -static tree connect_access PARAMS ((tree, tree, tree, tree)); -static int check_access PARAMS ((tree, int, const char *)); -static int check_text PARAMS ((tree, int, const char *)); -static tree get_final_type_and_range PARAMS ((tree, tree *, tree *)); -static void process_io_list PARAMS ((tree, tree *, tree *, rtx *, - int, int)); -static void check_format_string PARAMS ((tree, tree, int)); -static int get_max_size PARAMS ((tree)); - -/* association mode */ -tree association_type_node; -/* initialzier for association mode */ -tree association_init_value; - -/* NOTE: should be same as in runtime/chillrt0.c */ -#define STDIO_TEXT_LENGTH 1024 -/* mode of stdout, stdin, stderr*/ -static tree stdio_type_node; - -/* usage- and where modes */ -tree usage_type_node; -tree where_type_node; - -/* we have to distinguish between io-list-type for WRITETEXT - and for READTEXT. WRITETEXT does not process ranges and - READTEXT must get pointers to the variables. - */ -/* variable to hold the type of the io_list */ -static tree chill_io_list_type = NULL_TREE; - -/* the type for the enum tables */ -static tree enum_table_type = NULL_TREE; - -/* structure to save enums for later use in compilation */ -typedef struct save_enum_names -{ - struct save_enum_names *forward; - tree name; - tree decl; -} SAVE_ENUM_NAMES; - -static SAVE_ENUM_NAMES *used_enum_names = (SAVE_ENUM_NAMES *)0; - -typedef struct save_enum_values -{ - long val; - struct save_enum_names *name; -} SAVE_ENUM_VALUES; - -typedef struct save_enums -{ - struct save_enums *forward; - tree context; - tree type; - tree ptrdecl; - long num_vals; - struct save_enum_values *vals; -} SAVE_ENUMS; - -static SAVE_ENUMS *used_enums = (SAVE_ENUMS *)0; - - -/* Function collects all enums are necessary to collect, makes a copy of - the value and returns a VAR_DECL external to current function describing - the pointer to a name table, which will be generated at the end of - compilation - */ - -static tree add_enum_to_list (type, context) - tree type; - tree context; -{ - tree tmp; - SAVE_ENUMS *wrk = used_enums; - SAVE_ENUM_VALUES *vals; - SAVE_ENUM_NAMES *names; - - while (wrk != (SAVE_ENUMS *)0) - { - /* search for this enum already in use */ - if (wrk->context == context && wrk->type == type) - { - /* yes, found. look if the ptrdecl is valid in this scope */ - tree var = DECL_NAME (wrk->ptrdecl); - tree decl = lookup_name (var); - - if (decl == NULL_TREE) - { - /* no, not valid in this context, declare it */ - decl = decl_temp1 (var, build_pointer_type (TREE_TYPE (enum_table_type)), - 0, NULL_TREE, 1, 0); - } - return decl; - } - - /* next one */ - wrk = wrk->forward; - } - - /* not yet found -- generate an entry */ - wrk = (SAVE_ENUMS *)xmalloc (sizeof (SAVE_ENUMS)); - wrk->forward = used_enums; - used_enums = wrk; - - /* generate the pointer decl */ - wrk->ptrdecl = get_unique_identifier ("ENUMTABPTR"); - wrk->ptrdecl = decl_temp1 (wrk->ptrdecl, build_pointer_type (TREE_TYPE (enum_table_type)), - 0, NULL_TREE, 1, 0); - - /* save information for later use */ - wrk->context = context; - wrk->type = type; - - /* insert the names and values */ - tmp = TYPE_FIELDS (type); - wrk->num_vals = list_length (tmp); - vals = (SAVE_ENUM_VALUES *)xmalloc (sizeof (SAVE_ENUM_VALUES) * wrk->num_vals); - wrk->vals = vals; - - while (tmp != NULL_TREE) - { - /* search if name is already in use */ - names = used_enum_names; - while (names != (SAVE_ENUM_NAMES *)0) - { - if (names->name == TREE_PURPOSE (tmp)) - break; - names = names->forward; - } - if (names == (SAVE_ENUM_NAMES *)0) - { - /* we have to insert one */ - names = (SAVE_ENUM_NAMES *)xmalloc (sizeof (SAVE_ENUM_NAMES)); - names->forward = used_enum_names; - used_enum_names = names; - names->decl = NULL_TREE; - names->name = TREE_PURPOSE (tmp); - } - vals->name = names; - vals->val = TREE_INT_CST_LOW (TREE_VALUE (tmp)); - - /* next entry in enum */ - vals++; - tmp = TREE_CHAIN (tmp); - } - - /* return the generated decl */ - return wrk->ptrdecl; -} - - -static void -build_chill_io_list_type () -{ - tree list = NULL_TREE; - tree result, enum1, listbase; - tree io_descriptor; - tree decl1, decl2; - tree forcharstring, forset_W, forset_R, forboolrange; - - tree forintrange, intunion, forsetrange, forcharrange; - tree long_type, ulong_type, union_type; - - long_type = long_integer_type_node; - ulong_type = long_unsigned_type_node; - - if (chill_io_list_type != NULL_TREE) - /* already done */ - return; - - /* first build the enum for the desriptor */ - enum1 = start_enum (NULL_TREE); - result = build_enumerator (get_identifier ("__IO_UNUSED"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_ByteVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_UByteVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_IntVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_UIntVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_LongVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_ULongVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_ByteLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_UByteLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_IntLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_UIntLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_LongLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_ULongLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_IntRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_LongRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_BoolVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_BoolLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_SetVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_SetLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_SetRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_CharVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_CharLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_CharRangeLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_CharStrLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_BitStrLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_RealVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_RealLoc"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_LongRealVal"), - NULL_TREE); - list = chainon (result, list); - - result = build_enumerator (get_identifier ("__IO_LongRealLoc"), - NULL_TREE); - list = chainon (result, list); -#if 0 - result = build_enumerator (get_identifier ("_IO_Pointer"), - NULL_TREE); - list = chainon (result, list); -#endif - - result = finish_enum (enum1, list); - pushdecl (io_descriptor = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_enum"), - result)); - /* prevent seizing/granting of the decl */ - DECL_SOURCE_LINE (io_descriptor) = 0; - satisfy_decl (io_descriptor, 0); - - /* build type for enum_tables */ - decl1 = build_decl (FIELD_DECL, get_identifier ("value"), - long_type); - DECL_INITIAL (decl1) = NULL_TREE; - decl2 = build_decl (FIELD_DECL, get_identifier ("name"), - build_pointer_type (char_type_node)); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - result = build_chill_struct_type (decl1); - pushdecl (enum_table_type = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_enum_table_type"), - result)); - DECL_SOURCE_LINE (enum_table_type) = 0; - satisfy_decl (enum_table_type, 0); - - /* build type for writing a set mode */ - decl1 = build_decl (FIELD_DECL, get_identifier ("value"), - long_type); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), - build_pointer_type (TREE_TYPE (enum_table_type))); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forset_W = build_decl (TYPE_DECL, - get_identifier ("__tmp_WIO_set"), - result)); - DECL_SOURCE_LINE (forset_W) = 0; - satisfy_decl (forset_W, 0); - - /* build type for charrange */ - decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), - build_pointer_type (char_type_node)); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), - long_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), - long_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forcharrange = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_charrange"), - result)); - DECL_SOURCE_LINE (forcharrange) = 0; - satisfy_decl (forcharrange, 0); - - /* type for integer range */ - decl1 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("_slong"), - long_type)); - listbase = decl1; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("_ulong"), - ulong_type)); - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE); - TREE_CHAIN (decl1) = NULL_TREE; - result = build_chill_struct_type (decl1); - pushdecl (intunion = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_long"), - result)); - DECL_SOURCE_LINE (intunion) = 0; - satisfy_decl (intunion, 0); - - decl1 = build_decl (FIELD_DECL, - get_identifier ("ptr"), - ptr_type_node); - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("lower"), - TREE_TYPE (intunion)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("upper"), - TREE_TYPE (intunion)); - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forintrange = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_intrange"), - result)); - DECL_SOURCE_LINE (forintrange) = 0; - satisfy_decl (forintrange, 0); - - /* build structure for bool range */ - decl1 = build_decl (FIELD_DECL, - get_identifier ("ptr"), - ptr_type_node); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("lower"), - ulong_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("upper"), - ulong_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forboolrange = build_decl (TYPE_DECL, - get_identifier ("__tmp_RIO_boolrange"), - result)); - DECL_SOURCE_LINE (forboolrange) = 0; - satisfy_decl (forboolrange, 0); - - /* build type for reading a set */ - decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), - ptr_type_node); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("length"), - long_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), - build_pointer_type (TREE_TYPE (enum_table_type))); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forset_R = build_decl (TYPE_DECL, - get_identifier ("__tmp_RIO_set"), - result)); - DECL_SOURCE_LINE (forset_R) = 0; - satisfy_decl (forset_R, 0); - - /* build type for setrange */ - decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), - ptr_type_node); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("length"), - long_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), - build_pointer_type (TREE_TYPE (enum_table_type))); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), - long_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), - long_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forsetrange = build_decl (TYPE_DECL, - get_identifier ("__tmp_RIO_setrange"), - result)); - DECL_SOURCE_LINE (forsetrange) = 0; - satisfy_decl (forsetrange, 0); - - /* build structure for character string */ - decl1 = build_decl (FIELD_DECL, - get_identifier ("string"), - build_pointer_type (char_type_node)); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("string_length"), - ulong_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (forcharstring = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_forcharstring"), result)); - DECL_SOURCE_LINE (forcharstring) = 0; - satisfy_decl (forcharstring, 0); - - /* build the union */ - decl1 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valbyte"), - signed_char_type_node)); - listbase = decl1; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valubyte"), - unsigned_char_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valint"), - chill_integer_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valuint"), - chill_unsigned_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__vallong"), - long_type)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valulong"), - ulong_type)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locint"), - ptr_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locintrange"), - TREE_TYPE (forintrange))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valbool"), - boolean_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locbool"), - build_pointer_type (boolean_type_node))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locboolrange"), - TREE_TYPE (forboolrange))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valset"), - TREE_TYPE (forset_W))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locset"), - TREE_TYPE (forset_R))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locsetrange"), - TREE_TYPE (forsetrange))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valchar"), - char_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locchar"), - build_pointer_type (char_type_node))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__loccharrange"), - TREE_TYPE (forcharrange))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__loccharstring"), - TREE_TYPE (forcharstring))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__valreal"), - float_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__locreal"), - build_pointer_type (float_type_node))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__vallongreal"), - double_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__loclongreal"), - build_pointer_type (double_type_node))); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - -#if 0 - decl2 = build_tree_list (NULL_TREE, - build_decl (FIELD_DECL, - get_identifier ("__forpointer"), - ptr_type_node)); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; -#endif - - TREE_CHAIN (decl2) = NULL_TREE; - - decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE); - TREE_CHAIN (decl1) = NULL_TREE; - result = build_chill_struct_type (decl1); - pushdecl (union_type = build_decl (TYPE_DECL, - get_identifier ("__tmp_WIO_union"), - result)); - DECL_SOURCE_LINE (union_type) = 0; - satisfy_decl (union_type, 0); - - /* now build the final structure */ - decl1 = build_decl (FIELD_DECL, get_identifier ("__t"), - TREE_TYPE (union_type)); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"), - long_type); - - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (chill_io_list_type = build_decl (TYPE_DECL, - get_identifier ("__tmp_IO_list"), - result)); - DECL_SOURCE_LINE (chill_io_list_type) = 0; - satisfy_decl (chill_io_list_type, 0); -} - -/* build the ASSOCIATION, ACCESS and TEXT mode types */ -static void -build_io_types () -{ - tree listbase, decl1, decl2, result, association; - tree acc, txt, tloc; - tree enum1, tmp; - - /* the association mode */ - listbase = build_decl (FIELD_DECL, - get_identifier ("flags"), - long_unsigned_type_node); - DECL_INITIAL (listbase) = NULL_TREE; - decl1 = listbase; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("pathname"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("access"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("handle"), - integer_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("bufptr"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("syserrno"), - long_integer_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("usage"), - char_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("ctl_pre"), - char_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("ctl_post"), - char_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (association = build_decl (TYPE_DECL, - ridpointers[(int)RID_ASSOCIATION], - result)); - DECL_SOURCE_LINE (association) = 0; - satisfy_decl (association, 0); - association_type_node = TREE_TYPE (association); - TYPE_NAME (association_type_node) = association; - CH_NOVELTY (association_type_node) = association; - CH_TYPE_NONVALUE_P(association_type_node) = 1; - CH_TYPE_NONVALUE_P(association) = 1; - - /* initialiser for association type */ - tmp = convert (char_type_node, integer_zero_node); - association_init_value = - build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, integer_zero_node, /* flags */ - tree_cons (NULL_TREE, null_pointer_node, /* pathname */ - tree_cons (NULL_TREE, null_pointer_node, /* access */ - tree_cons (NULL_TREE, integer_minus_one_node, /* handle */ - tree_cons (NULL_TREE, null_pointer_node, /* bufptr */ - tree_cons (NULL_TREE, integer_zero_node, /* syserrno */ - tree_cons (NULL_TREE, tmp, /* usage */ - tree_cons (NULL_TREE, tmp, /* ctl_pre */ - tree_cons (NULL_TREE, tmp, /* ctl_post */ - NULL_TREE)))))))))); - - /* the type for stdin, stdout, stderr */ - /* text part */ - decl1 = build_decl (FIELD_DECL, - get_identifier ("flags"), - long_unsigned_type_node); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("text_record"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("access_sub"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("actual_index"), - long_unsigned_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - txt = build_chill_struct_type (listbase); - - /* access part */ - decl1 = build_decl (FIELD_DECL, - get_identifier ("flags"), - long_unsigned_type_node); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("reclength"), - long_unsigned_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("lowindex"), - long_integer_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("highindex"), - long_integer_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl2 = decl1; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("association"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("base"), - long_unsigned_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("storelocptr"), - ptr_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, - get_identifier ("rectype"), - long_integer_type_node); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - acc = build_chill_struct_type (listbase); - - /* the location */ - tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0)); - tloc = build_varying_struct (tmp); - - /* now the final mode */ - decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt); - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), - void_type_node); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"), - integer_type_node); - DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0); - TREE_CHAIN (decl1) = decl2; - decl1 = decl2; - - decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"), - integer_type_node); - DECL_INITIAL (decl2) = integer_zero_node; - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - - result = build_chill_struct_type (listbase); - pushdecl (tmp = build_decl (TYPE_DECL, - get_identifier ("__stdio_text"), - result)); - DECL_SOURCE_LINE (tmp) = 0; - satisfy_decl (tmp, 0); - stdio_type_node = TREE_TYPE (tmp); - CH_IS_TEXT_MODE (stdio_type_node) = 1; - - /* predefined usage mode */ - enum1 = start_enum (NULL_TREE); - listbase = NULL_TREE; - result = build_enumerator ( - get_identifier ((ignore_case || ! special_UC) ? "readonly" : "READONLY"), - NULL_TREE); - listbase = chainon (result, listbase); - result = build_enumerator ( - get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"), - NULL_TREE); - listbase = chainon (result, listbase); - result = build_enumerator ( - get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"), - NULL_TREE); - listbase = chainon (result, listbase); - result = finish_enum (enum1, listbase); - pushdecl (tmp = build_decl (TYPE_DECL, - get_identifier ((ignore_case || ! special_UC) ? "usage" : "USAGE"), - result)); - DECL_SOURCE_LINE (tmp) = 0; - satisfy_decl (tmp, 0); - usage_type_node = TREE_TYPE (tmp); - TYPE_NAME (usage_type_node) = tmp; - CH_NOVELTY (usage_type_node) = tmp; - - /* predefined where mode */ - enum1 = start_enum (NULL_TREE); - listbase = NULL_TREE; - result = build_enumerator ( - get_identifier ((ignore_case || ! special_UC) ? "first" : "FIRST"), - NULL_TREE); - listbase = chainon (result, listbase); - result = build_enumerator ( - get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"), - NULL_TREE); - listbase = chainon (result, listbase); - result = build_enumerator ( - get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"), - NULL_TREE); - listbase = chainon (result, listbase); - result = finish_enum (enum1, listbase); - pushdecl (tmp = build_decl (TYPE_DECL, - get_identifier ((ignore_case || ! special_UC) ? "where" : "WHERE"), - result)); - DECL_SOURCE_LINE (tmp) = 0; - satisfy_decl (tmp, 0); - where_type_node = TREE_TYPE (tmp); - TYPE_NAME (where_type_node) = tmp; - CH_NOVELTY (where_type_node) = tmp; -} - -static void -declare_predefined_file (name, assembler_name) - const char *name; - const char *assembler_name; -{ - tree decl = build_lang_decl (VAR_DECL, get_identifier (name), - stdio_type_node); - DECL_ASSEMBLER_NAME (decl) = get_identifier(assembler_name); - TREE_STATIC (decl) = 1; - TREE_PUBLIC (decl) = 1; - DECL_EXTERNAL (decl) = 1; - DECL_IN_SYSTEM_HEADER (decl) = 1; - make_decl_rtl (decl, 0, 1); - pushdecl (decl); -} - - -/* initialisation of all IO/related functions, types, etc. */ -void -inout_init () -{ - /* We temporarily reset the maximum_field_alignment to zero so the - compiler's init data structures can be compatible with the - run-time system, even when we're compiling with -fpack. */ - unsigned int save_maximum_field_alignment = maximum_field_alignment; - - extern tree chill_predefined_function_type; - tree endlink = void_list_node; - tree bool_ftype_ptr_ptr_int; - tree ptr_ftype_ptr_ptr_int; - tree luns_ftype_ptr_ptr_int; - tree int_ftype_ptr_ptr_int; - tree ptr_ftype_ptr_ptr_int_ptr_int_ptr_int; - tree void_ftype_ptr_ptr_int_ptr_int_ptr_int; - tree void_ftype_ptr_ptr_int; - tree void_ftype_ptr_ptr_int_int_int_long_ptr_int; - tree ptr_ftype_ptr_int_ptr_ptr_int; - tree void_ftype_ptr_int_ptr_luns_ptr_int; - tree void_ftype_ptr_ptr_ptr_int; - tree void_ftype_ptr_int_ptr_int; - tree void_ftype_ptr_int_ptr_int_ptr_int_ptr_int; - - maximum_field_alignment = 0; - - builtin_function ((ignore_case || ! special_UC) ? "associate" : "ASSOCIATE", - chill_predefined_function_type, - BUILT_IN_ASSOCIATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT", - chill_predefined_function_type, - BUILT_IN_CONNECT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE", - chill_predefined_function_type, - BUILT_IN_CREATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE", - chill_predefined_function_type, - BUILT_IN_CH_DELETE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT", - chill_predefined_function_type, - BUILT_IN_DISCONNECT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE", - chill_predefined_function_type, - BUILT_IN_DISSOCIATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN", - chill_predefined_function_type, - BUILT_IN_EOLN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING", - chill_predefined_function_type, - BUILT_IN_EXISTING, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION", - chill_predefined_function_type, - BUILT_IN_GETASSOCIATION, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS", - chill_predefined_function_type, - BUILT_IN_GETTEXTACCESS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX", - chill_predefined_function_type, - BUILT_IN_GETTEXTINDEX, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD", - chill_predefined_function_type, - BUILT_IN_GETTEXTRECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE", - chill_predefined_function_type, - BUILT_IN_GETUSAGE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE", - chill_predefined_function_type, - BUILT_IN_INDEXABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED", - chill_predefined_function_type, - BUILT_IN_ISASSOCIATED, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY", - chill_predefined_function_type, - BUILT_IN_MODIFY, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE", - chill_predefined_function_type, - BUILT_IN_OUTOFFILE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE", - chill_predefined_function_type, - BUILT_IN_READABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD", - chill_predefined_function_type, - BUILT_IN_READRECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT", - chill_predefined_function_type, - BUILT_IN_READTEXT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE", - chill_predefined_function_type, - BUILT_IN_SEQUENCIBLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS", - chill_predefined_function_type, - BUILT_IN_SETTEXTACCESS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX", - chill_predefined_function_type, - BUILT_IN_SETTEXTINDEX, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD", - chill_predefined_function_type, - BUILT_IN_SETTEXTRECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE", - chill_predefined_function_type, - BUILT_IN_VARIABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE", - chill_predefined_function_type, - BUILT_IN_WRITEABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD", - chill_predefined_function_type, - BUILT_IN_WRITERECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT", - chill_predefined_function_type, - BUILT_IN_WRITETEXT, BUILT_IN_NORMAL, NULL_PTR); - - /* build function prototypes */ - bool_ftype_ptr_ptr_int = - build_function_type (boolean_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - ptr_ftype_ptr_ptr_int_ptr_int_ptr_int = - build_function_type (ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))))); - void_ftype_ptr_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - void_ftype_ptr_ptr_int_ptr_int_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))))); - void_ftype_ptr_ptr_int_int_int_long_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, long_integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))))); - ptr_ftype_ptr_ptr_int = - build_function_type (ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - int_ftype_ptr_ptr_int = - build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - ptr_ftype_ptr_int_ptr_ptr_int = - build_function_type (ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))); - void_ftype_ptr_int_ptr_luns_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, long_unsigned_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))); - luns_ftype_ptr_ptr_int = - build_function_type (long_unsigned_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - void_ftype_ptr_ptr_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - void_ftype_ptr_int_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - void_ftype_ptr_int_ptr_int_ptr_int_ptr_int = - build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))))); - - builtin_function ("__associate", ptr_ftype_ptr_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__create", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__delete", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__disconnect", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__dissociate", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__eoln", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__existing", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__getusage", int_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__indexable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__isassociated", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__outoffile", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__sequencible", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__variable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writeable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - - /* declare ASSOCIATION, ACCESS, and TEXT modes */ - build_io_types (); - - /* declare the predefined text locations */ - declare_predefined_file ((ignore_case || ! special_UC) ? "stdin" : "STDIN", - "chill_stdin"); - declare_predefined_file ((ignore_case || ! special_UC) ? "stdout" : "STDOUT", - "chill_stdout"); - declare_predefined_file ((ignore_case || ! special_UC) ? "stderr" : "STDERR", - "chill_stderr"); - - /* last, but not least, build the chill IO-list type */ - build_chill_io_list_type (); - - maximum_field_alignment = save_maximum_field_alignment; -} - -/* function returns the recordmode of an ACCESS */ -tree -access_recordmode (access) - tree access; -{ - tree field; - - if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_ACCESS_MODE (access)) - return NULL_TREE; - - field = TYPE_FIELDS (access); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == TYPE_DECL && - DECL_NAME (field) == get_identifier ("__recordmode")) - return TREE_TYPE (field); - } - return void_type_node; -} - -/* function invalidates the recordmode of an ACCESS */ -void -invalidate_access_recordmode (access) - tree access; -{ - tree field; - - if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) - return; - if (! CH_IS_ACCESS_MODE (access)) - return; - - field = TYPE_FIELDS (access); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == TYPE_DECL && - DECL_NAME (field) == get_identifier ("__recordmode")) - { - TREE_TYPE (field) = error_mark_node; - return; - } - } -} - -/* function returns the index mode of an ACCESS if there is one, - otherwise NULL_TREE */ -tree -access_indexmode (access) - tree access; -{ - tree field; - - if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_ACCESS_MODE (access)) - return NULL_TREE; - - field = TYPE_FIELDS (access); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == TYPE_DECL && - DECL_NAME (field) == get_identifier ("__indexmode")) - return TREE_TYPE (field); - } - return void_type_node; -} - -/* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */ -tree -access_dynamic (access) - tree access; -{ - tree field; - - if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_ACCESS_MODE (access)) - return NULL_TREE; - - field = TYPE_FIELDS (access); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == CONST_DECL) - return DECL_INITIAL (field); - } - return integer_zero_node; -} - -#if 0 - returns a structure like - STRUCT (data STRUCT (flags ULONG, - reclength ULONG, - lowindex LONG, - highindex LONG, - association PTR, - base ULONG, - store_loc PTR, - rectype LONG), - this is followed by a - TYPE_DECL __recordmode recordmode ? recordmode : void_type_node - TYPE_DECL __indexmode indexmode ? indexmode : void_type_node - CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node -#endif - -static tree -build_access_part () -{ - tree listbase, decl; - - listbase = build_decl (FIELD_DECL, get_identifier ("flags"), - long_unsigned_type_node); - decl = build_decl (FIELD_DECL, get_identifier ("reclength"), - long_unsigned_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("lowindex"), - long_unsigned_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("highindex"), - long_integer_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("association"), - ptr_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("base"), - long_unsigned_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"), - ptr_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("rectype"), - long_integer_type_node); - listbase = chainon (listbase, decl); - return build_chill_struct_type (listbase); -} - -tree -build_access_mode (indexmode, recordmode, dynamic) - tree indexmode; - tree recordmode; - int dynamic; -{ - tree type, listbase, decl, datamode; - - if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK) - return error_mark_node; - if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK) - return error_mark_node; - - datamode = build_access_part (); - - type = make_node (RECORD_TYPE); - listbase = build_decl (FIELD_DECL, get_identifier ("data"), - datamode); - TYPE_FIELDS (type) = listbase; - decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"), - recordmode == NULL_TREE ? void_type_node : recordmode); - chainon (listbase, decl); - decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), - indexmode == NULL_TREE ? void_type_node : indexmode); - chainon (listbase, decl); - decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), - integer_type_node); - DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node; - chainon (listbase, decl); - CH_IS_ACCESS_MODE (type) = 1; - CH_TYPE_NONVALUE_P (type) = 1; - return type; -} - -#if 0 - returns a structure like: - STRUCT (txt STRUCT (flags ULONG, - text_record PTR, - access_sub PTR, - actual_index LONG), - acc STRUCT (flags ULONG, - reclength ULONG, - lowindex LONG, - highindex LONG, - association PTR, - base ULONG, - store_loc PTR, - rectype LONG), - tloc CHARS(textlength) VARYING; - ) - followed by - TYPE_DECL __indexmode indexmode ? indexmode : void_type_node - CONST_DECL __text_length - CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node -#endif -tree -build_text_mode (textlength, indexmode, dynamic) - tree textlength; - tree indexmode; - int dynamic; -{ - tree txt, acc, listbase, decl, type, tltype; - tree savedlength = textlength; - - if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK) - return error_mark_node; - if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK) - return error_mark_node; - - /* build the structure */ - listbase = build_decl (FIELD_DECL, get_identifier ("flags"), - long_unsigned_type_node); - decl = build_decl (FIELD_DECL, get_identifier ("text_record"), - ptr_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("access_sub"), - ptr_type_node); - listbase = chainon (listbase, decl); - decl = build_decl (FIELD_DECL, get_identifier ("actual_index"), - long_integer_type_node); - listbase = chainon (listbase, decl); - txt = build_chill_struct_type (listbase); - - acc = build_access_part (); - - type = make_node (RECORD_TYPE); - listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt); - TYPE_FIELDS (type) = listbase; - decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc); - chainon (listbase, decl); - /* the text location */ - tltype = build_string_type (char_type_node, textlength); - tltype = build_varying_struct (tltype); - decl = build_decl (FIELD_DECL, get_identifier ("tloc"), - tltype); - chainon (listbase, decl); - /* the index mode */ - decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), - indexmode == NULL_TREE ? void_type_node : indexmode); - chainon (listbase, decl); - /* save dynamic */ - decl = build_decl (CONST_DECL, get_identifier ("__textlength"), - integer_type_node); - if (TREE_CODE (textlength) == COMPONENT_REF) - /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build - another one */ - savedlength = build_component_ref (TREE_OPERAND (textlength, 0), - TREE_OPERAND (textlength, 1)); - DECL_INITIAL (decl) = savedlength; - chainon (listbase, decl); - /* save dynamic */ - decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), - integer_type_node); - DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node; - chainon (listbase, decl); - CH_IS_TEXT_MODE (type) = 1; - CH_TYPE_NONVALUE_P (type) = 1; - return type; -} - -tree -check_text_length (length) - tree length; -{ - if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK) - return length; - if (TREE_TYPE (length) == NULL_TREE - || !CH_SIMILAR (TREE_TYPE (length), integer_type_node)) - { - error ("non-integral text length"); - return integer_one_node; - } - if (TREE_CODE (length) != INTEGER_CST) - { - error ("non-constant text length"); - return integer_one_node; - } - if (compare_int_csts (LE_EXPR, length, integer_zero_node)) - { - error ("text length must be greater then 0"); - return integer_one_node; - } - return length; -} - -tree -text_indexmode (text) - tree text; -{ - tree field; - - if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_TEXT_MODE (text)) - return NULL_TREE; - - field = TYPE_FIELDS (text); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == TYPE_DECL) - return TREE_TYPE (field); - } - return void_type_node; -} - -tree -text_dynamic (text) - tree text; -{ - tree field; - - if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_TEXT_MODE (text)) - return NULL_TREE; - - field = TYPE_FIELDS (text); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == CONST_DECL && - DECL_NAME (field) == get_identifier ("__dynamic")) - return DECL_INITIAL (field); - } - return integer_zero_node; -} - -tree -text_length (text) - tree text; -{ - tree field; - - if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_TEXT_MODE (text)) - return NULL_TREE; - - field = TYPE_FIELDS (text); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == CONST_DECL && - DECL_NAME (field) == get_identifier ("__textlength")) - return DECL_INITIAL (field); - } - return integer_zero_node; -} - -static tree -textlocation_mode (text) - tree text; -{ - tree field; - - if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) - return NULL_TREE; - if (! CH_IS_TEXT_MODE (text)) - return NULL_TREE; - - field = TYPE_FIELDS (text); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == FIELD_DECL && - DECL_NAME (field) == get_identifier ("tloc")) - return TREE_TYPE (field); - } - return NULL_TREE; -} - -static int -check_assoc (assoc, argnum, errmsg) - tree assoc; - int argnum; - const char *errmsg; -{ - if (assoc == NULL_TREE || TREE_CODE (assoc) == ERROR_MARK) - return 0; - - if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc))) - { - error ("argument %d of %s must be of mode ASSOCIATION", argnum, errmsg); - return 0; - } - if (! CH_LOCATION_P (assoc)) - { - error ("argument %d of %s must be a location", argnum, errmsg); - return 0; - } - return 1; -} - -tree -build_chill_associate (assoc, fname, attr) - tree assoc; - tree fname; - tree attr; -{ - tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE, - arg5 = NULL_TREE, arg6, arg7; - int had_errors = 0; - tree result; - - /* make some checks */ - if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK) - return error_mark_node; - - /* check the association */ - if (! check_assoc (assoc, 1, "ASSOCIATION")) - had_errors = 1; - else - /* build a pointer to the association */ - arg1 = force_addr_of (assoc); - - /* check the filename, must be a string */ - if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) || - (flag_old_strings && TREE_CODE (fname) == INTEGER_CST && - TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE)) - { - if (int_size_in_bytes (TREE_TYPE (fname)) == 0) - { - error ("argument 2 of ASSOCIATE must not be an empty string"); - had_errors = 1; - } - else - { - arg2 = force_addr_of (fname); - arg3 = size_in_bytes (TREE_TYPE (fname)); - } - } - else if (chill_varying_string_type_p (TREE_TYPE (fname))) - { - arg2 = force_addr_of (build_component_ref (fname, var_data_id)); - arg3 = build_component_ref (fname, var_length_id); - } - else - { - error ("argument 2 to ASSOCIATE must be a string"); - had_errors = 1; - } - - /* check attr argument, must be a string too */ - if (attr == NULL_TREE) - { - arg4 = null_pointer_node; - arg5 = integer_zero_node; - } - else - { - attr = TREE_VALUE (attr); - if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK) - had_errors = 1; - else - { - if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) || - (flag_old_strings && TREE_CODE (attr) == INTEGER_CST && - TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE)) - { - if (int_size_in_bytes (TREE_TYPE (attr)) == 0) - { - arg4 = null_pointer_node; - arg5 = integer_zero_node; - } - else - { - arg4 = force_addr_of (attr); - arg5 = size_in_bytes (TREE_TYPE (attr)); - } - } - else if (chill_varying_string_type_p (TREE_TYPE (attr))) - { - arg4 = force_addr_of (build_component_ref (attr, var_data_id)); - arg5 = build_component_ref (attr, var_length_id); - } - else - { - error ("argument 3 to ASSOCIATE must be a string"); - had_errors = 1; - } - } - } - - if (had_errors) - return error_mark_node; - - /* other arguments */ - arg6 = force_addr_of (get_chill_filename ()); - arg7 = get_chill_linenumber (); - - result = build_chill_function_call ( - lookup_name (get_identifier ("__associate")), - tree_cons (NULL_TREE, arg1, - tree_cons (NULL_TREE, arg2, - tree_cons (NULL_TREE, arg3, - tree_cons (NULL_TREE, arg4, - tree_cons (NULL_TREE, arg5, - tree_cons (NULL_TREE, arg6, - tree_cons (NULL_TREE, arg7, NULL_TREE)))))))); - - TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc)); - return result; -} - -static tree -assoc_call (assoc, func, name) - tree assoc; - tree func; - const char *name; -{ - tree arg1, arg2, arg3; - tree result; - - if (! check_assoc (assoc, 1, name)) - return error_mark_node; - - arg1 = force_addr_of (assoc); - arg2 = force_addr_of (get_chill_filename ()); - arg3 = get_chill_linenumber (); - - result = build_chill_function_call (func, - tree_cons (NULL_TREE, arg1, - tree_cons (NULL_TREE, arg2, - tree_cons (NULL_TREE, arg3, NULL_TREE)))); - return result; -} - -tree -build_chill_isassociated (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__isassociated")), - "ISASSOCIATED"); - return result; -} - -tree -build_chill_existing (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__existing")), - "EXISTING"); - return result; -} - -tree -build_chill_readable (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__readable")), - "READABLE"); - return result; -} - -tree -build_chill_writeable (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__writeable")), - "WRITEABLE"); - return result; -} - -tree -build_chill_sequencible (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__sequencible")), - "SEQUENCIBLE"); - return result; -} - -tree -build_chill_variable (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__variable")), - "VARIABLE"); - return result; -} - -tree -build_chill_indexable (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__indexable")), - "INDEXABLE"); - return result; -} - -tree -build_chill_dissociate (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__dissociate")), - "DISSOCIATE"); - return result; -} - -tree -build_chill_create (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__create")), - "CREATE"); - return result; -} - -tree -build_chill_delete (assoc) - tree assoc; -{ - tree result = assoc_call (assoc, - lookup_name (get_identifier ("__delete")), - "DELETE"); - return result; -} - -tree -build_chill_modify (assoc, list) - tree assoc; - tree list; -{ - tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE, - arg5 = NULL_TREE, arg6, arg7; - int had_errors = 0, numargs; - tree fname = NULL_TREE, attr = NULL_TREE; - tree result; - - /* check the association */ - if (! check_assoc (assoc, 1, "MODIFY")) - had_errors = 1; - else - arg1 = force_addr_of (assoc); - - /* look how much arguments we have got */ - numargs = list_length (list); - switch (numargs) - { - case 0: - break; - case 1: - fname = TREE_VALUE (list); - break; - case 2: - fname = TREE_VALUE (list); - attr = TREE_VALUE (TREE_CHAIN (list)); - break; - default: - error ("Too many arguments in call to MODIFY"); - had_errors = 1; - break; - } - - if (fname != NULL_TREE && fname != null_pointer_node) - { - if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) || - (flag_old_strings && TREE_CODE (fname) == INTEGER_CST && - TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE)) - { - if (int_size_in_bytes (TREE_TYPE (fname)) == 0) - { - error ("argument 2 of MODIFY must not be an empty string"); - had_errors = 1; - } - else - { - arg2 = force_addr_of (fname); - arg3 = size_in_bytes (TREE_TYPE (fname)); - } - } - else if (chill_varying_string_type_p (TREE_TYPE (fname))) - { - arg2 = force_addr_of (build_component_ref (fname, var_data_id)); - arg3 = build_component_ref (fname, var_length_id); - } - else - { - error ("argument 2 to MODIFY must be a string"); - had_errors = 1; - } - } - else - { - arg2 = null_pointer_node; - arg3 = integer_zero_node; - } - - if (attr != NULL_TREE && attr != null_pointer_node) - { - if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) || - (flag_old_strings && TREE_CODE (attr) == INTEGER_CST && - TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE)) - { - if (int_size_in_bytes (TREE_TYPE (attr)) == 0) - { - arg4 = null_pointer_node; - arg5 = integer_zero_node; - } - else - { - arg4 = force_addr_of (attr); - arg5 = size_in_bytes (TREE_TYPE (attr)); - } - } - else if (chill_varying_string_type_p (TREE_TYPE (attr))) - { - arg4 = force_addr_of (build_component_ref (attr, var_data_id)); - arg5 = build_component_ref (attr, var_length_id); - } - else - { - error ("argument 3 to MODIFY must be a string"); - had_errors = 1; - } - } - else - { - arg4 = null_pointer_node; - arg5 = integer_zero_node; - } - - if (had_errors) - return error_mark_node; - - /* other arguments */ - arg6 = force_addr_of (get_chill_filename ()); - arg7 = get_chill_linenumber (); - - result = build_chill_function_call ( - lookup_name (get_identifier ("__modify")), - tree_cons (NULL_TREE, arg1, - tree_cons (NULL_TREE, arg2, - tree_cons (NULL_TREE, arg3, - tree_cons (NULL_TREE, arg4, - tree_cons (NULL_TREE, arg5, - tree_cons (NULL_TREE, arg6, - tree_cons (NULL_TREE, arg7, NULL_TREE)))))))); - - return result; -} - -static int -check_transfer (transfer, argnum, errmsg) - tree transfer; - int argnum; - const char *errmsg; -{ - int result = 0; - - if (transfer == NULL_TREE || TREE_CODE (transfer) == ERROR_MARK) - return 0; - - if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer))) - result = 1; - else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer))) - result = 2; - else - { - error ("argument %d of %s must be an ACCESS or TEXT mode", argnum, errmsg); - return 0; - } - if (! CH_LOCATION_P (transfer)) - { - error ("argument %d of %s must be a location", argnum, errmsg); - return 0; - } - return result; -} - -/* define bits in an access/text flag word. - NOTE: this must be consistent with runtime/iomodes.h */ -#define IO_TEXTLOCATION 0x80000000 -#define IO_INDEXED 0x00000001 -#define IO_TEXTIO 0x00000002 -#define IO_OUTOFFILE 0x00010000 - -/* generated initialisation code for ACCESS and TEXT. - functions gets called from do_decl. */ -void init_access_location (decl, type) - tree decl; - tree type; -{ - tree recordmode = access_recordmode (type); - tree indexmode = access_indexmode (type); - int flags_init = 0; - tree data = build_component_ref (decl, get_identifier ("data")); - tree lowindex = integer_zero_node; - tree highindex = integer_zero_node; - tree rectype, reclen; - - /* flag word */ - if (indexmode != NULL_TREE && indexmode != void_type_node) - { - flags_init |= IO_INDEXED; - lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode)); - highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode)); - } - - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("flags")), - build_int_2 (flags_init, 0))); - - /* record length */ - if (recordmode == NULL_TREE || recordmode == void_type_node) - { - reclen = integer_zero_node; - rectype = integer_zero_node; - } - else if (chill_varying_string_type_p (recordmode)) - { - tree fields = TYPE_FIELDS (recordmode); - tree len1, len2; - - /* don't count any padding bytes at end of varying */ - len1 = size_in_bytes (TREE_TYPE (fields)); - fields = TREE_CHAIN (fields); - len2 = size_in_bytes (TREE_TYPE (fields)); - reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2)); - rectype = build_int_2 (2, 0); - } - else - { - reclen = size_in_bytes (recordmode); - rectype = integer_one_node; - } - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("reclength")), reclen)); - - /* record type */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("rectype")), rectype)); - - /* the index */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("lowindex")), lowindex)); - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("highindex")), highindex)); - - /* association */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_chill_component_ref (data, get_identifier ("association")), - null_pointer_node)); - - /* storelocptr */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node)); -} - -void init_text_location (decl, type) - tree decl; - tree type; -{ - tree indexmode = text_indexmode (type); - unsigned long accessflags = 0; - unsigned long textflags = IO_TEXTLOCATION; - tree lowindex = integer_zero_node; - tree highindex = integer_zero_node; - tree data, tloc, tlocfields, len1, len2, reclen; - - if (indexmode != NULL_TREE && indexmode != void_type_node) - { - accessflags |= IO_INDEXED; - lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode)); - highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode)); - } - - tloc = build_component_ref (decl, get_identifier ("tloc")); - /* fill access part of text location */ - data = build_component_ref (decl, get_identifier ("acc")); - /* flag word */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("flags")), - build_int_2 (accessflags, 0))); - - /* record length, don't count any padding bytes at end of varying */ - tlocfields = TYPE_FIELDS (TREE_TYPE (tloc)); - len1 = size_in_bytes (TREE_TYPE (tlocfields)); - tlocfields = TREE_CHAIN (tlocfields); - len2 = size_in_bytes (TREE_TYPE (tlocfields)); - reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2)); - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("reclength")), - reclen)); - - /* the index */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("lowindex")), lowindex)); - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("highindex")), highindex)); - - /* association */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_chill_component_ref (data, get_identifier ("association")), - null_pointer_node)); - - /* storelocptr */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("storelocptr")), - null_pointer_node)); - - /* record type */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("rectype")), - build_int_2 (2, 0))); /* VaryingChars */ - - /* fill text part */ - data = build_component_ref (decl, get_identifier ("txt")); - /* flag word */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("flags")), - build_int_2 (textflags, 0))); - - /* pointer to text record */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("text_record")), - force_addr_of (tloc))); - - /* pointer to the access */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("access_sub")), - force_addr_of (build_component_ref (decl, get_identifier ("acc"))))); - - /* actual length */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (data, get_identifier ("actual_index")), - integer_zero_node)); - - /* length of text record */ - expand_expr_stmt ( - build_chill_modify_expr ( - build_component_ref (tloc, get_identifier (VAR_LENGTH)), - integer_zero_node)); -} - -static int -connect_process_optionals (optionals, whereptr, indexptr, indexmode) - tree optionals; - tree *whereptr; - tree *indexptr; - tree indexmode; -{ - tree where = NULL_TREE, theindex = NULL_TREE; - int had_errors = 0; - - if (optionals != NULL_TREE) - { - /* get the where expression */ - where = TREE_VALUE (optionals); - if (where == NULL_TREE || TREE_CODE (where) == ERROR_MARK) - had_errors = 1; - else - { - if (! CH_IS_WHERE_MODE (TREE_TYPE (where))) - { - error ("argument 4 of CONNECT must be of mode WHERE"); - had_errors = 1; - } - where = convert (integer_type_node, where); - } - optionals = TREE_CHAIN (optionals); - } - if (optionals != NULL_TREE) - { - theindex = TREE_VALUE (optionals); - if (theindex == NULL_TREE || TREE_CODE (theindex) == ERROR_MARK) - had_errors = 1; - else - { - if (indexmode == void_type_node) - { - error ("index expression for ACCESS without index"); - had_errors = 1; - } - else if (! CH_COMPATIBLE (theindex, indexmode)) - { - error ("incompatible index mode"); - had_errors = 1; - } - } - } - if (had_errors) - return 0; - - *whereptr = where; - *indexptr = theindex; - return 1; -} - -static tree -connect_text (assoc, text, usage, optionals) - tree assoc; - tree text; - tree usage; - tree optionals; -{ - tree where = NULL_TREE, theindex = NULL_TREE; - tree indexmode = text_indexmode (TREE_TYPE (text)); - tree result, what_where, have_index, what_index; - - /* process optionals */ - if (!connect_process_optionals (optionals, &where, &theindex, indexmode)) - return error_mark_node; - - what_where = where == NULL_TREE ? integer_zero_node : where; - have_index = theindex == NULL_TREE ? integer_zero_node - : integer_one_node; - what_index = theindex == NULL_TREE ? integer_zero_node - : convert (integer_type_node, theindex); - result = build_chill_function_call ( - lookup_name (get_identifier ("__connect")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (assoc), - tree_cons (NULL_TREE, convert (integer_type_node, usage), - tree_cons (NULL_TREE, what_where, - tree_cons (NULL_TREE, have_index, - tree_cons (NULL_TREE, what_index, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), - NULL_TREE))))))))); - return result; -} - -static tree -connect_access (assoc, transfer, usage, optionals) - tree assoc; - tree transfer; - tree usage; - tree optionals; -{ - tree where = NULL_TREE, theindex = NULL_TREE; - tree indexmode = access_indexmode (TREE_TYPE (transfer)); - tree result, what_where, have_index, what_index; - - /* process the optionals */ - if (! connect_process_optionals (optionals, &where, &theindex, indexmode)) - return error_mark_node; - - /* now the call */ - what_where = where == NULL_TREE ? integer_zero_node : where; - have_index = theindex == NULL_TREE ? integer_zero_node : integer_one_node; - what_index = theindex == NULL_TREE ? integer_zero_node : convert (integer_type_node, theindex); - result = build_chill_function_call ( - lookup_name (get_identifier ("__connect")), - tree_cons (NULL_TREE, force_addr_of (transfer), - tree_cons (NULL_TREE, force_addr_of (assoc), - tree_cons (NULL_TREE, convert (integer_type_node, usage), - tree_cons (NULL_TREE, what_where, - tree_cons (NULL_TREE, have_index, - tree_cons (NULL_TREE, what_index, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), - NULL_TREE))))))))); - return result; -} - -tree -build_chill_connect (transfer, assoc, usage, optionals) - tree transfer; - tree assoc; - tree usage; - tree optionals; -{ - int had_errors = 0; - int what = 0; - tree result = error_mark_node; - - if (! check_assoc (assoc, 2, "CONNECT")) - had_errors = 1; - - /* check usage */ - if (usage == NULL_TREE || TREE_CODE (usage) == ERROR_MARK) - return error_mark_node; - - if (! CH_IS_USAGE_MODE (TREE_TYPE (usage))) - { - error ("argument 3 to CONNECT must be of mode USAGE"); - had_errors = 1; - } - if (had_errors) - return error_mark_node; - - /* look what we have got */ - what = check_transfer (transfer, 1, "CONNECT"); - switch (what) - { - case 1: - /* we have an ACCESS */ - result = connect_access (assoc, transfer, usage, optionals); - break; - case 2: - /* we have a TEXT */ - result = connect_text (assoc, transfer, usage, optionals); - break; - default: - result = error_mark_node; - } - return result; -} - -static int -check_access (access, argnum, errmsg) - tree access; - int argnum; - const char *errmsg; -{ - if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) - return 1; - - if (! CH_IS_ACCESS_MODE (TREE_TYPE (access))) - { - error ("argument %d of %s must be of mode ACCESS", argnum, errmsg); - return 0; - } - if (! CH_LOCATION_P (access)) - { - error ("argument %d of %s must be a location", argnum, errmsg); - return 0; - } - return 1; -} - -tree -build_chill_readrecord (access, optionals) - tree access; - tree optionals; -{ - int len; - tree recordmode, indexmode, dynamic, result; - tree index = NULL_TREE, location = NULL_TREE; - - if (! check_access (access, 1, "READRECORD")) - return error_mark_node; - - recordmode = access_recordmode (TREE_TYPE (access)); - indexmode = access_indexmode (TREE_TYPE (access)); - dynamic = access_dynamic (TREE_TYPE (access)); - - /* process the optionals */ - len = list_length (optionals); - if (indexmode != void_type_node) - { - /* we must have an index */ - if (!len) - { - error ("Too few arguments in call to `readrecord'"); - return error_mark_node; - } - index = TREE_VALUE (optionals); - if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK) - return error_mark_node; - optionals = TREE_CHAIN (optionals); - if (! CH_COMPATIBLE (index, indexmode)) - { - error ("incompatible index mode"); - return error_mark_node; - } - } - - /* check the record mode, if one */ - if (optionals != NULL_TREE) - { - location = TREE_VALUE (optionals); - if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK) - return error_mark_node; - if (recordmode != void_type_node && - ! CH_COMPATIBLE (location, recordmode)) - { - - error ("incompatible record mode"); - return error_mark_node; - } - if (TYPE_READONLY_PROPERTY (TREE_TYPE (location))) - { - error ("store location must not be READonly"); - return error_mark_node; - } - location = force_addr_of (location); - } - else - location = null_pointer_node; - - index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index); - result = build_chill_function_call ( - lookup_name (get_identifier ("__readrecord")), - tree_cons (NULL_TREE, force_addr_of (access), - tree_cons (NULL_TREE, index, - tree_cons (NULL_TREE, location, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))))); - - TREE_TYPE (result) = build_chill_pointer_type (recordmode); - return result; -} - -tree -build_chill_writerecord (access, optionals) - tree access; - tree optionals; -{ - int had_errors = 0, len; - tree recordmode, indexmode, dynamic; - tree index = NULL_TREE, location = NULL_TREE; - tree result; - - if (! check_access (access, 1, "WRITERECORD")) - return error_mark_node; - - recordmode = access_recordmode (TREE_TYPE (access)); - indexmode = access_indexmode (TREE_TYPE (access)); - dynamic = access_dynamic (TREE_TYPE (access)); - - /* process the optionals */ - len = list_length (optionals); - if (indexmode != void_type_node && len != 2) - { - error ("Too few arguments in call to `writerecord'"); - return error_mark_node; - } - if (indexmode != void_type_node) - { - index = TREE_VALUE (optionals); - if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK) - return error_mark_node; - location = TREE_VALUE (TREE_CHAIN (optionals)); - if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK) - return error_mark_node; - } - else - location = TREE_VALUE (optionals); - - /* check the index */ - if (indexmode != void_type_node) - { - if (! CH_COMPATIBLE (index, indexmode)) - { - error ("incompatible index mode"); - had_errors = 1; - } - } - /* check the record mode */ - if (recordmode == void_type_node) - { - error ("transfer to ACCESS without record mode"); - had_errors = 1; - } - else if (! CH_COMPATIBLE (location, recordmode)) - { - error ("incompatible record mode"); - had_errors = 1; - } - if (had_errors) - return error_mark_node; - - index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index); - - result = build_chill_function_call ( - lookup_name (get_identifier ("__writerecord")), - tree_cons (NULL_TREE, force_addr_of (access), - tree_cons (NULL_TREE, index, - tree_cons (NULL_TREE, force_addr_of (location), - tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (location)), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))))); - return result; -} - -tree -build_chill_disconnect (transfer) - tree transfer; -{ - tree result; - - if (! check_transfer (transfer, 1, "DISCONNECT")) - return error_mark_node; - result = build_chill_function_call ( - lookup_name (get_identifier ("__disconnect")), - tree_cons (NULL_TREE, force_addr_of (transfer), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - return result; -} - -tree -build_chill_getassociation (transfer) - tree transfer; -{ - tree result; - - if (! check_transfer (transfer, 1, "GETASSOCIATION")) - return error_mark_node; - - result = build_chill_function_call ( - lookup_name (get_identifier ("__getassociation")), - tree_cons (NULL_TREE, force_addr_of (transfer), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - TREE_TYPE (result) = build_chill_pointer_type (association_type_node); - return result; -} - -tree -build_chill_getusage (transfer) - tree transfer; -{ - tree result; - - if (! check_transfer (transfer, 1, "GETUSAGE")) - return error_mark_node; - - result = build_chill_function_call ( - lookup_name (get_identifier ("__getusage")), - tree_cons (NULL_TREE, force_addr_of (transfer), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - TREE_TYPE (result) = usage_type_node; - return result; -} - -tree -build_chill_outoffile (transfer) - tree transfer; -{ - tree result; - - if (! check_transfer (transfer, 1, "OUTOFFILE")) - return error_mark_node; - - result = build_chill_function_call ( - lookup_name (get_identifier ("__outoffile")), - tree_cons (NULL_TREE, force_addr_of (transfer), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - return result; -} - -static int -check_text (text, argnum, errmsg) - tree text; - int argnum; - const char *errmsg; -{ - if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) - return 0; - if (! CH_IS_TEXT_MODE (TREE_TYPE (text))) - { - error ("argument %d of %s must be of mode TEXT", argnum, errmsg); - return 0; - } - if (! CH_LOCATION_P (text)) - { - error ("argument %d of %s must be a location", argnum, errmsg); - return 0; - } - return 1; -} - -tree -build_chill_eoln (text) - tree text; -{ - tree result; - - if (! check_text (text, 1, "EOLN")) - return error_mark_node; - - result = build_chill_function_call ( - lookup_name (get_identifier ("__eoln")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - return result; -} - -tree -build_chill_gettextindex (text) - tree text; -{ - tree result; - - if (! check_text (text, 1, "GETTEXTINDEX")) - return error_mark_node; - - result = build_chill_function_call ( - lookup_name (get_identifier ("__gettextindex")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - return result; -} - -tree -build_chill_gettextrecord (text) - tree text; -{ - tree textmode, result; - - if (! check_text (text, 1, "GETTEXTRECORD")) - return error_mark_node; - - textmode = textlocation_mode (TREE_TYPE (text)); - if (textmode == NULL_TREE) - { - error ("TEXT doesn't have a location"); /* FIXME */ - return error_mark_node; - } - result = build_chill_function_call ( - lookup_name (get_identifier ("__gettextrecord")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - TREE_TYPE (result) = build_chill_pointer_type (textmode); - CH_DERIVED_FLAG (result) = 1; - return result; -} - -tree -build_chill_gettextaccess (text) - tree text; -{ - tree access, refaccess, acc, decl, listbase; - tree tlocmode, indexmode, dynamic; - tree result; - unsigned int save_maximum_field_alignment = maximum_field_alignment; - - if (! check_text (text, 1, "GETTEXTACCESS")) - return error_mark_node; - - tlocmode = textlocation_mode (TREE_TYPE (text)); - indexmode = text_indexmode (TREE_TYPE (text)); - dynamic = text_dynamic (TREE_TYPE (text)); - - /* we have to build a type for the access */ - acc = build_access_part (); - access = make_node (RECORD_TYPE); - listbase = build_decl (FIELD_DECL, get_identifier ("data"), acc); - TYPE_FIELDS (access) = listbase; - decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"), - tlocmode); - chainon (listbase, decl); - decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), - indexmode); - chainon (listbase, decl); - decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), - integer_type_node); - DECL_INITIAL (decl) = dynamic; - chainon (listbase, decl); - maximum_field_alignment = 0; - layout_chill_struct_type (access); - maximum_field_alignment = save_maximum_field_alignment; - CH_IS_ACCESS_MODE (access) = 1; - CH_TYPE_NONVALUE_P (access) = 1; - - refaccess = build_chill_pointer_type (access); - - result = build_chill_function_call ( - lookup_name (get_identifier ("__gettextaccess")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - TREE_TYPE (result) = refaccess; - CH_DERIVED_FLAG (result) = 1; - return result; -} - -tree -build_chill_settextindex (text, expr) - tree text; - tree expr; -{ - tree result; - - if (! check_text (text, 1, "SETTEXTINDEX")) - return error_mark_node; - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - result = build_chill_function_call ( - lookup_name (get_identifier ("__settextindex")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, expr, - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))); - return result; -} - -tree -build_chill_settextaccess (text, access) - tree text; - tree access; -{ - tree result; - tree textindexmode, accessindexmode; - tree textrecordmode, accessrecordmode; - - if (! check_text (text, 1, "SETTEXTACCESS")) - return error_mark_node; - if (! check_access (access, 2, "SETTEXTACCESS")) - return error_mark_node; - - textindexmode = text_indexmode (TREE_TYPE (text)); - accessindexmode = access_indexmode (TREE_TYPE (access)); - if (textindexmode != accessindexmode) - { - if (! chill_read_compatible (textindexmode, accessindexmode)) - { - error ("incompatible index mode for SETETEXTACCESS"); - return error_mark_node; - } - } - textrecordmode = textlocation_mode (TREE_TYPE (text)); - accessrecordmode = access_recordmode (TREE_TYPE (access)); - if (textrecordmode != accessrecordmode) - { - if (! chill_read_compatible (textrecordmode, accessrecordmode)) - { - error ("incompatible record mode for SETTEXTACCESS"); - return error_mark_node; - } - } - result = build_chill_function_call ( - lookup_name (get_identifier ("__settextaccess")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (access), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))); - return result; -} - -tree -build_chill_settextrecord (text, charloc) - tree text; - tree charloc; -{ - tree result; - int had_errors = 0; - tree tlocmode; - - if (! check_text (text, 1, "SETTEXTRECORD")) - return error_mark_node; - if (charloc == NULL_TREE || TREE_CODE (charloc) == ERROR_MARK) - return error_mark_node; - - /* check the location */ - if (! CH_LOCATION_P (charloc)) - { - error ("parameter 2 must be a location"); - return error_mark_node; - } - tlocmode = textlocation_mode (TREE_TYPE (text)); - if (! chill_varying_string_type_p (TREE_TYPE (charloc))) - had_errors = 1; - else if (int_size_in_bytes (tlocmode) != int_size_in_bytes (TREE_TYPE (charloc))) - had_errors = 1; - if (had_errors) - { - error ("incompatible modes in parameter 2"); - return error_mark_node; - } - result = build_chill_function_call ( - lookup_name (get_identifier ("__settextrecord")), - tree_cons (NULL_TREE, force_addr_of (text), - tree_cons (NULL_TREE, force_addr_of (charloc), - tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))); - return result; -} - -/* process iolist for READ- and WRITETEXT */ - -/* function walks through types as long as they are ranges, - returns the type and min- and max-value form starting type. - */ - -static tree -get_final_type_and_range (item, low, high) - tree item; - tree *low; - tree *high; -{ - tree wrk = item; - - *low = TYPE_MIN_VALUE (wrk); - *high = TYPE_MAX_VALUE (wrk); - while (TREE_CODE (wrk) == INTEGER_TYPE && - TREE_TYPE (wrk) != NULL_TREE && - TREE_CODE (TREE_TYPE (wrk)) == INTEGER_TYPE && - TREE_TYPE (TREE_TYPE (wrk)) != NULL_TREE) - wrk = TREE_TYPE (wrk); - - return (TREE_TYPE (wrk)); -} - -static void -process_io_list (exprlist, iolist_addr, iolist_length, iolist_rtx, do_read, - argoffset) - tree exprlist; - tree *iolist_addr; - tree *iolist_length; - rtx *iolist_rtx; - int do_read; - int argoffset; -{ - tree idxlist; - int idxcnt; - int iolen; - tree iolisttype, iolist; - - if (exprlist == NULL_TREE) - return; - - iolen = list_length (exprlist); - - /* build indexlist for the io list */ - idxlist = build_tree_list (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_one_node, - build_int_2 (iolen, 0))); - - /* build the io-list type */ - iolisttype = build_chill_array_type (TREE_TYPE (chill_io_list_type), - idxlist, 0, NULL_TREE); - - /* declare the iolist */ - iolist = build_decl (VAR_DECL, get_unique_identifier (do_read ? "RDTEXT" : "WRTEXT"), - iolisttype); - - /* we want to get a variable which gets marked unused after - the function call, This is a little bit tricky cause the - address of this variable will be taken and therefor the variable - gets moved out one level. However, we REALLY don't need this - variable again. Solution: push 2 levels and do pop and free - twice at the end. */ - push_temp_slots (); - push_temp_slots (); - *iolist_rtx = assign_temp (TREE_TYPE (iolist), 0, 1, 0); - DECL_RTL (iolist) = *iolist_rtx; - - /* process the exprlist */ - idxcnt = 1; - while (exprlist != NULL_TREE) - { - tree item = TREE_VALUE (exprlist); - tree idx = build_int_2 (idxcnt++, 0); - const char *fieldname = 0; - const char *enumname = 0; - tree array_ref = build_chill_array_ref_1 (iolist, idx); - tree item_type; - tree range_low = NULL_TREE, range_high = NULL_TREE; - int have_range = 0; - tree item_addr = null_pointer_node; - int referable = 0; - int readonly = 0; - - /* next value in exprlist */ - exprlist = TREE_CHAIN (exprlist); - if (item == NULL_TREE || TREE_CODE (item) == ERROR_MARK) - continue; - - item_type = TREE_TYPE (item); - if (item_type == NULL_TREE) - { - if (TREE_CODE (item) == COND_EXPR || TREE_CODE (item) == CASE_EXPR) - error ("conditional expression not allowed in this context"); - else - error ("untyped expression as argument %d", idxcnt + 1 + argoffset); - continue; - } - else if (TREE_CODE (item_type) == ERROR_MARK) - continue; - - if (TREE_CODE (item_type) == REFERENCE_TYPE) - { - item_type = TREE_TYPE (item_type); - item = convert (item_type, item); - } - - /* check for a range */ - if (TREE_CODE (item_type) == INTEGER_TYPE && - TREE_TYPE (item_type) != NULL_TREE) - { - /* we have a range. NOTE, however, on writetext we don't process ranges */ - item_type = get_final_type_and_range (item_type, - &range_low, &range_high); - have_range = 1; - } - - readonly = TYPE_READONLY_PROPERTY (item_type); - referable = CH_REFERABLE (item); - if (referable) - item_addr = force_addr_of (item); - /* if we are in read and have readonly we can't do this */ - if (readonly && do_read) - { - item_addr = null_pointer_node; - referable = 0; - } - - /* process different types */ - if (TREE_CODE (item_type) == INTEGER_TYPE) - { - int type_size = TREE_INT_CST_LOW (TYPE_SIZE (item_type)); - tree to_assign = NULL_TREE; - - if (do_read && referable) - { - /* process an integer in case of READTEXT and expression is - referable and not READONLY */ - to_assign = item_addr; - if (have_range) - { - /* do it for a range */ - tree t, __forxx, __ptr, __low, __high; - tree what_upper, what_lower; - - /* determine the name in the union of lower and upper */ - if (TREE_UNSIGNED (item_type)) - fieldname = "_ulong"; - else - fieldname = "_slong"; - - switch (type_size) - { - case 8: - if (TREE_UNSIGNED (item_type)) - enumname = "__IO_UByteRangeLoc"; - else - enumname = "__IO_ByteRangeLoc"; - break; - case 16: - if (TREE_UNSIGNED (item_type)) - enumname = "__IO_UIntRangeLoc"; - else - enumname = "__IO_IntRangeLoc"; - break; - case 32: - if (TREE_UNSIGNED (item_type)) - enumname = "__IO_ULongRangeLoc"; - else - enumname = "__IO_LongRangeLoc"; - break; - default: - error ("Cannot process %d bits integer for READTEXT argument %d.", - type_size, idxcnt + 1 + argoffset); - continue; - } - - /* set up access to structure */ - t = build_component_ref (array_ref, - get_identifier ("__t")); - __forxx = build_component_ref (t, get_identifier ("__locintrange")); - __ptr = build_component_ref (__forxx, get_identifier ("ptr")); - __low = build_component_ref (__forxx, get_identifier ("lower")); - what_lower = build_component_ref (__low, get_identifier (fieldname)); - __high = build_component_ref (__forxx, get_identifier ("upper")); - what_upper = build_component_ref (__high, get_identifier (fieldname)); - - /* do the assignments */ - expand_assignment (__ptr, item_addr, 0, 0); - expand_assignment (what_lower, range_low, 0, 0); - expand_assignment (what_upper, range_high, 0, 0); - fieldname = 0; - } - else - { - /* no range */ - fieldname = "__locint"; - switch (type_size) - { - case 8: - if (TREE_UNSIGNED (item_type)) - enumname = "__IO_UByteLoc"; - else - enumname = "__IO_ByteLoc"; - break; - case 16: - if (TREE_UNSIGNED (item_type)) - enumname = "__IO_UIntLoc"; - else - enumname = "__IO_IntLoc"; - break; - case 32: - if (TREE_UNSIGNED (item_type)) - enumname = "__IO_ULongLoc"; - else - enumname = "__IO_LongLoc"; - break; - default: - error ("Cannot process %d bits integer for READTEXT argument %d.", - type_size, idxcnt + 1 + argoffset); - continue; - } - } - } - else - { - /* process an integer in case of WRITETEXT */ - to_assign = item; - switch (type_size) - { - case 8: - if (TREE_UNSIGNED (item_type)) - { - enumname = "__IO_UByteVal"; - fieldname = "__valubyte"; - } - else - { - enumname = "__IO_ByteVal"; - fieldname = "__valbyte"; - } - break; - case 16: - if (TREE_UNSIGNED (item_type)) - { - enumname = "__IO_UIntVal"; - fieldname = "__valuint"; - } - else - { - enumname = "__IO_IntVal"; - fieldname = "__valint"; - } - break; - case 32: - try_long: - if (TREE_UNSIGNED (item_type)) - { - enumname = "__IO_ULongVal"; - fieldname = "__valulong"; - } - else - { - enumname = "__IO_LongVal"; - fieldname = "__vallong"; - } - break; - case 64: - /* convert it back to {unsigned}long. */ - if (TREE_UNSIGNED (item_type)) - item_type = long_unsigned_type_node; - else - item_type = long_integer_type_node; - item = convert (item_type, item); - goto try_long; - default: - /* This kludge is because the lexer gives literals - the type long_long_{integer,unsigned}_type_node. */ - if (TREE_CODE (item) == INTEGER_CST) - { - if (int_fits_type_p (item, long_integer_type_node)) - { - item_type = long_integer_type_node; - item = convert (item_type, item); - goto try_long; - } - if (int_fits_type_p (item, long_unsigned_type_node)) - { - item_type = long_unsigned_type_node; - item = convert (item_type, item); - goto try_long; - } - } - error ("Cannot process %d bits integer WRITETEXT argument %d.", - type_size, idxcnt + 1 + argoffset); - continue; - } - } - if (fieldname) - { - tree t, __forxx; - - t = build_component_ref (array_ref, - get_identifier ("__t")); - __forxx = build_component_ref (t, get_identifier (fieldname)); - expand_assignment (__forxx, to_assign, 0, 0); - } - } - else if (TREE_CODE (item_type) == CHAR_TYPE) - { - tree to_assign = NULL_TREE; - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read) - { - if (! referable) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - if (have_range) - { - tree t, forxx, ptr, lower, upper; - - t = build_component_ref (array_ref, get_identifier ("__t")); - forxx = build_component_ref (t, get_identifier ("__loccharrange")); - ptr = build_component_ref (forxx, get_identifier ("ptr")); - lower = build_component_ref (forxx, get_identifier ("lower")); - upper = build_component_ref (forxx, get_identifier ("upper")); - expand_assignment (ptr, item_addr, 0, 0); - expand_assignment (lower, range_low, 0, 0); - expand_assignment (upper, range_high, 0, 0); - - fieldname = 0; - enumname = "__IO_CharRangeLoc"; - } - else - { - to_assign = item_addr; - fieldname = "__locchar"; - enumname = "__IO_CharLoc"; - } - } - else - { - to_assign = item; - enumname = "__IO_CharVal"; - fieldname = "__valchar"; - } - - if (fieldname) - { - tree t, forxx; - - t = build_component_ref (array_ref, get_identifier ("__t")); - forxx = build_component_ref (t, get_identifier (fieldname)); - expand_assignment (forxx, to_assign, 0, 0); - } - } - else if (TREE_CODE (item_type) == BOOLEAN_TYPE) - { - tree to_assign = NULL_TREE; - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read) - { - if (! referable) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - if (have_range) - { - tree t, forxx, ptr, lower, upper; - - t = build_component_ref (array_ref, get_identifier ("__t")); - forxx = build_component_ref (t, get_identifier ("__locboolrange")); - ptr = build_component_ref (forxx, get_identifier ("ptr")); - lower = build_component_ref (forxx, get_identifier ("lower")); - upper = build_component_ref (forxx, get_identifier ("upper")); - expand_assignment (ptr, item_addr, 0, 0); - expand_assignment (lower, range_low, 0, 0); - expand_assignment (upper, range_high, 0, 0); - - fieldname = 0; - enumname = "__IO_BoolRangeLoc"; - } - else - { - to_assign = item_addr; - fieldname = "__locbool"; - enumname = "__IO_BoolLoc"; - } - } - else - { - to_assign = item; - enumname = "__IO_BoolVal"; - fieldname = "__valbool"; - } - if (fieldname) - { - tree t, forxx; - - t = build_component_ref (array_ref, get_identifier ("__t")); - forxx = build_component_ref (t, get_identifier (fieldname)); - expand_assignment (forxx, to_assign, 0, 0); - } - } - else if (TREE_CODE (item_type) == ENUMERAL_TYPE) - { - /* process an enum */ - tree table_name; - tree context_of_type; - tree t; - - /* determine the context of the type. - if TYPE_NAME (item_type) == NULL_TREE - if TREE_CODE (item) == INTEGER_CST - context = NULL_TREE -- this is wrong but should work for now - else - context = DECL_CONTEXT (item) - else - context = DECL_CONTEXT (TYPE_NAME (item_type)) */ - - if (TYPE_NAME (item_type) == NULL_TREE) - { - if (TREE_CODE (item) == INTEGER_CST) - context_of_type = NULL_TREE; - else - context_of_type = DECL_CONTEXT (item); - } - else - context_of_type = DECL_CONTEXT (TYPE_NAME (item_type)); - - table_name = add_enum_to_list (item_type, context_of_type); - t = build_component_ref (array_ref, get_identifier ("__t")); - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read) - { - if (! referable) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - if (have_range) - { - tree forxx, ptr, len, nametable, lower, upper; - - forxx = build_component_ref (t, get_identifier ("__locsetrange")); - ptr = build_component_ref (forxx, get_identifier ("ptr")); - len = build_component_ref (forxx, get_identifier ("length")); - nametable = build_component_ref (forxx, get_identifier ("name_table")); - lower = build_component_ref (forxx, get_identifier ("lower")); - upper = build_component_ref (forxx, get_identifier ("upper")); - expand_assignment (ptr, item_addr, 0, 0); - expand_assignment (len, size_in_bytes (item_type), 0, 0); - expand_assignment (nametable, table_name, 0, 0); - expand_assignment (lower, range_low, 0, 0); - expand_assignment (upper, range_high, 0, 0); - - enumname = "__IO_SetRangeLoc"; - } - else - { - tree forxx, ptr, len, nametable; - - forxx = build_component_ref (t, get_identifier ("__locset")); - ptr = build_component_ref (forxx, get_identifier ("ptr")); - len = build_component_ref (forxx, get_identifier ("length")); - nametable = build_component_ref (forxx, get_identifier ("name_table")); - expand_assignment (ptr, item_addr, 0, 0); - expand_assignment (len, size_in_bytes (item_type), 0, 0); - expand_assignment (nametable, table_name, 0, 0); - - enumname = "__IO_SetLoc"; - } - } - else - { - tree forxx, value, nametable; - - forxx = build_component_ref (t, get_identifier ("__valset")); - value = build_component_ref (forxx, get_identifier ("value")); - nametable = build_component_ref (forxx, get_identifier ("name_table")); - expand_assignment (value, item, 0, 0); - expand_assignment (nametable, table_name, 0, 0); - - enumname = "__IO_SetVal"; - } - } - else if (chill_varying_string_type_p (item_type)) - { - /* varying char string */ - tree t = build_component_ref (array_ref, get_identifier ("__t")); - tree forxx = build_component_ref (t, get_identifier ("__loccharstring")); - tree string = build_component_ref (forxx, get_identifier ("string")); - tree length = build_component_ref (forxx, get_identifier ("string_length")); - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read) - { - /* in this read case the argument must be referable */ - if (! referable) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - } - else if (! referable) - { - /* in the write case we create a temporary if not referable */ - rtx t; - tree loc = build_decl (VAR_DECL, - get_unique_identifier ("WRTEXTVS"), - item_type); - t = assign_temp (item_type, 0, 1, 0); - DECL_RTL (loc) = t; - expand_assignment (loc, item, 0, 0); - item_addr = force_addr_of (loc); - item = loc; - } - - expand_assignment (string, item_addr, 0, 0); - if (do_read) - /* we must pass the maximum length of the varying */ - expand_assignment (length, - size_in_bytes (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (item_type)))), - 0, 0); - else - /* we pass the actual length of the string */ - expand_assignment (length, - build_component_ref (item, var_length_id), - 0, 0); - - enumname = "__IO_CharVaryingLoc"; - } - else if (CH_CHARS_TYPE_P (item_type)) - { - /* fixed character string */ - tree the_size; - tree t = build_component_ref (array_ref, get_identifier ("__t")); - tree forxx = build_component_ref (t, get_identifier ("__loccharstring")); - tree string = build_component_ref (forxx, get_identifier ("string")); - tree length = build_component_ref (forxx, get_identifier ("string_length")); - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read) - { - /* in this read case the argument must be referable */ - if (! CH_REFERABLE (item)) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - else - item_addr = force_addr_of (item); - the_size = size_in_bytes (item_type); - enumname = "__IO_CharStrLoc"; - } - else - { - if (! CH_REFERABLE (item)) - { - /* in the write case we create a temporary if not referable */ - rtx t; - int howmuchbytes; - - howmuchbytes = int_size_in_bytes (item_type); - if (howmuchbytes != -1) - { - /* fixed size */ - tree loc = build_decl (VAR_DECL, - get_unique_identifier ("WRTEXTVS"), - item_type); - t = assign_temp (item_type, 0, 1, 0); - DECL_RTL (loc) = t; - expand_assignment (loc, item, 0, 0); - item_addr = force_addr_of (loc); - the_size = size_in_bytes (item_type); - enumname = "__IO_CharStrLoc"; - } - else - { - tree type, string, exp, loc; - - if ((howmuchbytes = intsize_of_charsexpr (item)) == -1) - { - error ("cannot process argument %d of WRITETEXT, unknown size", - idxcnt + 1 + argoffset); - continue; - } - string = build_string_type (char_type_node, - build_int_2 (howmuchbytes, 0)); - type = build_varying_struct (string); - loc = build_decl (VAR_DECL, - get_unique_identifier ("WRTEXTCS"), - type); - t = assign_temp (type, 0, 1, 0); - DECL_RTL (loc) = t; - exp = chill_convert_for_assignment (type, item, 0); - expand_assignment (loc, exp, 0, 0); - item_addr = force_addr_of (loc); - the_size = integer_zero_node; - enumname = "__IO_CharVaryingLoc"; - } - } - else - { - item_addr = force_addr_of (item); - the_size = size_in_bytes (item_type); - enumname = "__IO_CharStrLoc"; - } - } - - expand_assignment (string, item_addr, 0, 0); - expand_assignment (length, size_in_bytes (item_type), 0, 0); - - } - else if (CH_BOOLS_TYPE_P (item_type)) - { - /* we have a bitstring */ - tree t = build_component_ref (array_ref, get_identifier ("__t")); - tree forxx = build_component_ref (t, get_identifier ("__loccharstring")); - tree string = build_component_ref (forxx, get_identifier ("string")); - tree length = build_component_ref (forxx, get_identifier ("string_length")); - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read) - { - /* in this read case the argument must be referable */ - if (! referable) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - } - else if (! referable) - { - /* in the write case we create a temporary if not referable */ - tree loc = build_decl (VAR_DECL, - get_unique_identifier ("WRTEXTVS"), - item_type); - DECL_RTL (loc) = assign_temp (item_type, 0, 1, 0); - expand_assignment (loc, item, 0, 0); - item_addr = force_addr_of (loc); - } - - expand_assignment (string, item_addr, 0, 0); - expand_assignment (length, build_chill_length (item), 0, 0); - - enumname = "__IO_BitStrLoc"; - } - else if (TREE_CODE (item_type) == REAL_TYPE) - { - /* process a (long_)real */ - tree t, forxx, to_assign; - - if (do_read && readonly) - { - error ("argument %d is READonly", idxcnt + 1 + argoffset); - continue; - } - if (do_read && ! referable) - { - error ("argument %d must be referable", idxcnt + 1 + argoffset); - continue; - } - - if (lookup_name (ridpointers[RID_FLOAT]) == TYPE_NAME (item_type)) - { - /* we have a real */ - if (do_read) - { - enumname = "__IO_RealLoc"; - fieldname = "__locreal"; - to_assign = item_addr; - } - else - { - enumname = "__IO_RealVal"; - fieldname = "__valreal"; - to_assign = item; - } - } - else - { - /* we have a long_real */ - if (do_read) - { - enumname = "__IO_LongRealLoc"; - fieldname = "__loclongreal"; - to_assign = item_addr; - } - else - { - enumname = "__IO_LongRealVal"; - fieldname = "__vallongreal"; - to_assign = item; - } - } - t = build_component_ref (array_ref, get_identifier ("__t")); - forxx = build_component_ref (t, get_identifier (fieldname)); - expand_assignment (forxx, to_assign, 0, 0); - } -#if 0 - /* don't process them for now */ - else if (TREE_CODE (item_type) == POINTER_TYPE) - { - /* we have a pointer */ - tree __t, __forxx; - - __t = build_component_ref (array_ref, get_identifier ("__t")); - __forxx = build_component_ref (__t, get_identifier ("__forpointer")); - expand_assignment (__forxx, item, 0, 0); - enumname = "_IO_Pointer"; - } - else if (item_type == instance_type_node) - { - /* we have an INSTANCE */ - tree __t, __forxx; - - __t = build_component_ref (array_ref, get_identifier ("__t")); - __forxx = build_component_ref (__t, get_identifier ("__forinstance")); - expand_assignment (__forxx, item, 0, 0); - enumname = "_IO_Instance"; - } -#endif - else - { - /* datatype is not yet implemented, issue a warning */ - error ("cannot process mode of argument %d for %sTEXT.", idxcnt + 1 + argoffset, - do_read ? "READ" : "WRITE"); - enumname = "__IO_UNUSED"; - } - - /* do assignment of the enum */ - if (enumname) - { - tree descr = build_component_ref (array_ref, - get_identifier ("__descr")); - expand_assignment (descr, - lookup_name (get_identifier (enumname)), 0, 0); - } - } - - /* set up address and length of iolist */ - *iolist_addr = build_chill_addr_expr (iolist, (char *)0); - *iolist_length = build_int_2 (iolen, 0); -} - -/* check the format string */ -#define LET 0x0001 -#define BIN 0x0002 -#define DEC 0x0004 -#define OCT 0x0008 -#define HEX 0x0010 -#define USC 0x0020 -#define BIL 0x0040 -#define SPC 0x0080 -#define SCS 0x0100 -#define IOC 0x0200 -#define EDC 0x0400 -#define CVC 0x0800 - -#define isDEC(c) ( chartab[(c)] & DEC ) -#define isCVC(c) ( chartab[(c)] & CVC ) -#define isEDC(c) ( chartab[(c)] & EDC ) -#define isIOC(c) ( chartab[(c)] & IOC ) -#define isUSC(c) -#define isXXX(c,XXX) ( chartab[(c)] & XXX ) - -static -short int chartab[256] = { - 0, 0, 0, 0, 0, 0, 0, 0, - 0, SPC, SPC, SPC, SPC, SPC, 0, 0, - - 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, - - SPC, IOC, 0, 0, 0, 0, 0, 0, - SCS, SCS, SCS, SCS+IOC, SCS, SCS+IOC, SCS, SCS+IOC, - BIN+OCT+DEC+HEX, BIN+OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, - OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, - DEC+HEX, DEC+HEX, SCS, SCS, SCS+EDC, SCS+IOC, SCS+EDC, IOC, - - 0, LET+HEX+BIL, LET+HEX+BIL+CVC, LET+HEX+BIL+CVC, LET+HEX+BIL, LET+HEX, - LET+HEX+CVC, LET, - LET+BIL+CVC, LET, LET, LET, LET, LET, LET, LET+CVC, - - LET, LET, LET, LET, LET+EDC, LET, LET, LET, - LET+EDC, LET, LET, SCS, 0, SCS, 0, USC, - - 0, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET, - LET, LET, LET, LET, LET, LET, LET, LET, - - LET, LET, LET, LET, LET, LET, LET, LET, - LET, LET, LET, 0, 0, 0, 0, 0 -}; - -typedef enum -{ - FormatText, FirstPercent, RepFact, ConvClause, EditClause, ClauseEnd, - AfterWidth, FractWidth, FractWidthCont, ExpoWidth, ExpoWidthCont, - ClauseWidth, CatchPadding, LastPercent -} fcsstate_t; - -#define CONVERSIONCODES "CHOBF" -typedef enum -{ - DefaultConv, HexConv, OctalConv, BinaryConv, ScientConv -} convcode_t; -static convcode_t convcode; - -static tree check_exprlist PARAMS ((convcode_t, tree, int, - unsigned long)); - -typedef enum -{ - False, True, -} Boolean; - -static unsigned long fractionwidth; - -#define IOCODES "/+-?!=" -typedef enum { - NextRecord, NextPage, CurrentLine, Prompt, Emit, EndPage -} iocode_t; -static iocode_t iocode; - -#define EDITCODES "X<>T" -typedef enum { - SpaceSkip, SkipLeft, SkipRight, Tabulation -} editcode_t; -static editcode_t editcode; - -static unsigned long clausewidth; -static Boolean leftadjust; -static Boolean overflowev; -static Boolean dynamicwid; -static Boolean paddingdef; -static char paddingchar; -static Boolean fractiondef; -static Boolean exponentdef; -static unsigned long exponentwidth; -static unsigned long repetition; - -typedef enum { - NormalEnd, EndAtParen, TextFailEnd -} formatexit_t; - -static formatexit_t scanformcont PARAMS ((char *, int, char **, int *, - tree, tree *, int, int *)); - -/* NOTE: varibale have to be set to False before calling check_format_string */ -static Boolean empty_printed; - -static int formstroffset; - -static tree -check_exprlist (code, exprlist, argnum, repetition) - convcode_t code; - tree exprlist; - int argnum; - unsigned long repetition; -{ - tree expr, type, result = NULL_TREE; - - while (repetition--) - { - if (exprlist == NULL_TREE) - { - if (empty_printed == False) - { - warning ("too few arguments for this format string"); - empty_printed = True; - } - return NULL_TREE; - } - expr = TREE_VALUE (exprlist); - result = exprlist = TREE_CHAIN (exprlist); - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return result; - type = TREE_TYPE (expr); - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return result; - if (TREE_CODE (type) == REFERENCE_TYPE) - type = TREE_TYPE (type); - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return result; - - switch (code) - { - case DefaultConv: - /* %C, everything is allowed. Not know types are flaged later. */ - break; - case ScientConv: - /* %F, must be a REAL */ - if (TREE_CODE (type) != REAL_TYPE) - warning ("type of argument %d invalid for conversion code at offset %d", - argnum, formstroffset); - break; - case HexConv: - case OctalConv: - case BinaryConv: - case -1: - /* %H, %O, %B, and V as clause width */ - if (TREE_CODE (type) != INTEGER_TYPE) - warning ("type of argument %d invalid for conversion code at offset %d", - argnum, formstroffset); - break; - default: - /* there is an invalid conversion code */ - break; - } - } - return result; -} - -static formatexit_t -scanformcont (fcs, len, fcsptr, lenptr, exprlist, exprptr, - firstargnum, nextargnum) - char *fcs; - int len; - char **fcsptr; - int *lenptr; - tree exprlist; - tree *exprptr; - int firstargnum; - int *nextargnum; -{ - fcsstate_t state = FormatText; - unsigned char curr; - int dig; - - while (len--) - { - curr = *fcs++; - formstroffset++; - switch (state) - { - case FormatText: - if (curr == '%') - state = FirstPercent; - break; - - after_first_percent: ; - case FirstPercent: - if (curr == '%') - { - state = FormatText; - break; - } - if (curr == ')') - { - *lenptr = len; - *fcsptr = fcs; - *exprptr = exprlist; - *nextargnum = firstargnum; - return EndAtParen; - } - if (isDEC (curr)) - { - state = RepFact; - repetition = curr - '0'; - break; - } - - repetition = 1; - - test_for_control_codes: ; - if (isCVC (curr)) - { - state = ConvClause; - convcode = strchr (CONVERSIONCODES, curr) - CONVERSIONCODES; - leftadjust = False; - overflowev = False; - dynamicwid = False; - paddingdef = False; - paddingchar = ' '; - fractiondef = False; - /* fractionwidth = 0; default depends on mode ! */ - exponentdef = False; - exponentwidth = 3; - clausewidth = 0; - /* check the argument */ - exprlist = check_exprlist (convcode, exprlist, firstargnum, repetition); - firstargnum++; - break; - } - if (isEDC (curr)) - { - state = EditClause; - editcode = strchr (EDITCODES, curr) - EDITCODES; - dynamicwid = False; - clausewidth = editcode == Tabulation ? 0 : 1; - break; - } - if (isIOC (curr)) - { - state = ClauseEnd; - iocode = strchr (IOCODES, curr) - IOCODES; - break; - } - if (curr == '(') - { - unsigned long times = repetition; - int cntlen; - char* cntfcs; - tree cntexprlist; - int nextarg; - - while (times--) - { - if (scanformcont (fcs, len, &cntfcs, &cntlen, - exprlist, &cntexprlist, - firstargnum, &nextarg) != EndAtParen ) - { - warning ("unmatched open paren"); - break; - } - exprlist = cntexprlist; - } - fcs = cntfcs; - len = cntlen; - if (len < 0) - len = 0; - exprlist = cntexprlist; - firstargnum = nextarg; - state = FormatText; - break; - } - warning ("bad format specification character (offset %d)", formstroffset); - state = FormatText; - /* skip one argument */ - if (exprlist != NULL_TREE) - exprlist = TREE_CHAIN (exprlist); - break; - - case RepFact: - if (isDEC (curr)) - { - dig = curr - '0'; - if (repetition > (ULONG_MAX - dig)/10) - { - warning ("repetition factor overflow (offset %d)", formstroffset); - return TextFailEnd; - } - repetition = repetition*10 + dig; - break; - } - goto test_for_control_codes; - - case ConvClause: - if (isDEC (curr)) - { - state = ClauseWidth; - clausewidth = curr - '0'; - break; - } - if (curr == 'L') - { - if (leftadjust) - warning ("duplicate qualifier (offset %d)", formstroffset); - leftadjust = True; - break; - } - if (curr == 'E') - { - if (overflowev) - warning ("duplicate qualifier (offset %d)", formstroffset); - overflowev = True; - break; - } - if (curr == 'P') - { - if (paddingdef) - warning ("duplicate qualifier (offset %d)", formstroffset); - paddingdef = True; - state = CatchPadding; - break; - } - - test_for_variable_width: ; - if (curr == 'V') - { - dynamicwid = True; - state = AfterWidth; - exprlist = check_exprlist (-1, exprlist, firstargnum, 1); - firstargnum++; - break; - } - goto test_for_fraction_width; - - case ClauseWidth: - if (isDEC (curr)) - { - dig = curr - '0'; - if (clausewidth > (ULONG_MAX - dig)/10) - warning ("clause width overflow (offset %d)", formstroffset); - else - clausewidth = clausewidth*10 + dig; - break; - } - /* fall through */ - - test_for_fraction_width: ; - case AfterWidth: - if (curr == '.') - { - if (convcode != DefaultConv && convcode != ScientConv) - { - warning ("no fraction (offset %d)", formstroffset); - state = FormatText; - break; - } - fractiondef = True; - state = FractWidth; - break; - } - goto test_for_exponent_width; - - case FractWidth: - if (isDEC (curr)) - { - state = FractWidthCont; - fractionwidth = curr - '0'; - break; - } - else - warning ("no fraction width (offset %d)", formstroffset); - - case FractWidthCont: - if (isDEC (curr)) - { - dig = curr - '0'; - if (fractionwidth > (ULONG_MAX - dig)/10) - warning ("fraction width overflow (offset %d)", formstroffset); - else - fractionwidth = fractionwidth*10 + dig; - break; - } - - test_for_exponent_width: ; - if (curr == ':') - { - if (convcode != ScientConv) - { - warning ("no exponent (offset %d)", formstroffset); - state = FormatText; - break; - } - exponentdef = True; - state = ExpoWidth; - break; - } - goto test_for_final_percent; - - case ExpoWidth: - if (isDEC (curr)) - { - state = ExpoWidthCont; - exponentwidth = curr - '0'; - break; - } - else - warning ("no exponent width (offset %d)", formstroffset); - - case ExpoWidthCont: - if (isDEC (curr)) - { - dig = curr - '0'; - if (exponentwidth > (ULONG_MAX - dig)/10) - warning ("exponent width overflow (offset %d)", formstroffset); - else - exponentwidth = exponentwidth*10 + dig; - break; - } - /* fall through */ - - test_for_final_percent: ; - case ClauseEnd: - if (curr == '%') - { - state = LastPercent; - break; - } - - state = FormatText; - break; - - case CatchPadding: - paddingchar = curr; - state = ConvClause; - break; - - case EditClause: - if (isDEC (curr)) - { - state = ClauseWidth; - clausewidth = curr - '0'; - break; - } - goto test_for_variable_width; - - case LastPercent: - if (curr == '.') - { - state = FormatText; - break; - } - goto after_first_percent; - - default: - error ("internal error in check_format_string"); - } - } - - switch (state) - { - case FormatText: - break; - case FirstPercent: - case LastPercent: - case RepFact: - case FractWidth: - case ExpoWidth: - warning ("bad format specification character (offset %d)", formstroffset); - break; - case CatchPadding: - warning ("no padding character (offset %d)", formstroffset); - break; - default: - break; - } - *fcsptr = fcs; - *lenptr = len; - *exprptr = exprlist; - *nextargnum = firstargnum; - return NormalEnd; -} -static void -check_format_string (format_str, exprlist, firstargnum) - tree format_str; - tree exprlist; - int firstargnum; -{ - char *x; - int y, yy; - tree z = NULL_TREE; - - if (TREE_CODE (format_str) != STRING_CST) - /* do nothing if we don't have a string constant */ - return; - - formstroffset = -1; - scanformcont (TREE_STRING_POINTER (format_str), - TREE_STRING_LENGTH (format_str), &x, &y, - exprlist, &z, - firstargnum, &yy); - if (z != NULL_TREE) - /* too may arguments for format string */ - warning ("too many arguments for this format string"); -} - -static int -get_max_size (expr) - tree expr; -{ - if (TREE_CODE (expr) == INDIRECT_REF) - { - tree x = TREE_OPERAND (expr, 0); - tree y = TREE_OPERAND (x, 0); - return int_size_in_bytes (TREE_TYPE (y)); - } - else if (TREE_CODE (expr) == CONCAT_EXPR) - return intsize_of_charsexpr (expr); - else - return int_size_in_bytes (TREE_TYPE (expr)); -} - -static int -intsize_of_charsexpr (expr) - tree expr; -{ - int op0size, op1size; - - if (TREE_CODE (expr) != CONCAT_EXPR) - return -1; - - /* find maximum length of CONCAT_EXPR, this is the worst case */ - op0size = get_max_size (TREE_OPERAND (expr, 0)); - op1size = get_max_size (TREE_OPERAND (expr, 1)); - if (op0size == -1 || op1size == -1) - return -1; - return op0size + op1size; -} - -tree -build_chill_writetext (text_arg, exprlist) - tree text_arg, exprlist; -{ - tree iolist_addr = null_pointer_node; - tree iolist_length = integer_zero_node; - tree fstr_addr; - tree fstr_length; - tree outstr_addr; - tree outstr_length; - tree fstrtype; - tree outfunction; - tree filename, linenumber; - tree format_str = NULL_TREE, indexexpr = NULL_TREE; - rtx iolist_rtx = NULL_RTX; - int argoffset = 0; - - /* make some checks */ - if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK) - return error_mark_node; - - if (exprlist != NULL_TREE) - { - if (TREE_CODE (exprlist) != TREE_LIST) - return error_mark_node; - } - - /* check the text argument */ - if (chill_varying_string_type_p (TREE_TYPE (text_arg))) - { - /* build outstr-addr and outstr-length assuming that this is a CHAR (n) VARYING */ - outstr_addr = force_addr_of (text_arg); - outstr_length = size_in_bytes (CH_VARYING_ARRAY_TYPE (TREE_TYPE (text_arg))); - outfunction = lookup_name (get_identifier ("__writetext_s")); - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - } - else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg))) - { - /* we have a text mode */ - tree indexmode; - - if (! check_text (text_arg, 1, "WRITETEXT")) - return error_mark_node; - indexmode = text_indexmode (TREE_TYPE (text_arg)); - if (indexmode == void_type_node) - { - /* no index */ - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - } - else - { - /* we have an index. there must be an index argument before format string */ - indexexpr = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - if (! CH_COMPATIBLE (indexexpr, indexmode)) - { - if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) || - (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) || - (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST && - TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE))) - error ("missing index expression"); - else - error ("incompatible index mode"); - return error_mark_node; - } - if (exprlist == NULL_TREE) - { - error ("Too few arguments in call to `writetext'"); - return error_mark_node; - } - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - argoffset = 1; - } - outstr_addr = force_addr_of (text_arg); - outstr_length = convert (integer_type_node, indexexpr); - outfunction = lookup_name (get_identifier ("__writetext_f")); - } - else - { - error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location"); - return error_mark_node; - } - - /* check the format string */ - fstrtype = TREE_TYPE (format_str); - if (CH_CHARS_TYPE_P (fstrtype) || - (flag_old_strings && TREE_CODE (format_str) == INTEGER_CST && - TREE_CODE (fstrtype) == CHAR_TYPE)) - { - /* we have a character string */ - fstr_addr = force_addr_of (format_str); - fstr_length = size_in_bytes (fstrtype); - } - else if (chill_varying_string_type_p (TREE_TYPE (format_str))) - { - /* we have a varying char string */ - fstr_addr - = force_addr_of (build_component_ref (format_str, var_data_id)); - fstr_length = build_component_ref (format_str, var_length_id); - } - else - { - error ("`format string' for WRITETEXT must be a CHARACTER string"); - return error_mark_node; - } - - empty_printed = False; - check_format_string (format_str, exprlist, argoffset + 3); - process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 0, argoffset); - - /* tree to call the function */ - - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - expand_expr_stmt ( - build_chill_function_call (outfunction, - tree_cons (NULL_TREE, outstr_addr, - tree_cons (NULL_TREE, outstr_length, - tree_cons (NULL_TREE, fstr_addr, - tree_cons (NULL_TREE, fstr_length, - tree_cons (NULL_TREE, iolist_addr, - tree_cons (NULL_TREE, iolist_length, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, - NULL_TREE)))))))))); - - /* get rid of the iolist variable, if we have one */ - if (iolist_rtx != NULL_RTX) - { - free_temp_slots (); - pop_temp_slots (); - free_temp_slots (); - pop_temp_slots (); - } - - /* return something the rest of the machinery can work with, - i.e. (void)0 */ - return build1 (CONVERT_EXPR, void_type_node, integer_zero_node); -} - -tree -build_chill_readtext (text_arg, exprlist) - tree text_arg, exprlist; -{ - tree instr_addr, instr_length, infunction; - tree fstr_addr, fstr_length, fstrtype; - tree iolist_addr = null_pointer_node; - tree iolist_length = integer_zero_node; - tree filename, linenumber; - tree format_str = NULL_TREE, indexexpr = NULL_TREE; - rtx iolist_rtx = NULL_RTX; - int argoffset = 0; - - /* make some checks */ - if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK) - return error_mark_node; - - if (exprlist != NULL_TREE) - { - if (TREE_CODE (exprlist) != TREE_LIST) - return error_mark_node; - } - - /* check the text argument */ - if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg))) - { - instr_addr = force_addr_of (text_arg); - instr_length = size_in_bytes (TREE_TYPE (text_arg)); - infunction = lookup_name (get_identifier ("__readtext_s")); - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - } - else if (chill_varying_string_type_p (TREE_TYPE (text_arg))) - { - instr_addr - = force_addr_of (build_component_ref (text_arg, var_data_id)); - instr_length = build_component_ref (text_arg, var_length_id); - infunction = lookup_name (get_identifier ("__readtext_s")); - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - } - else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg))) - { - /* we have a text mode */ - tree indexmode; - - if (! check_text (text_arg, 1, "READTEXT")) - return error_mark_node; - indexmode = text_indexmode (TREE_TYPE (text_arg)); - if (indexmode == void_type_node) - { - /* no index */ - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - } - else - { - /* we have an index. there must be an index argument before format string */ - indexexpr = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - if (! CH_COMPATIBLE (indexexpr, indexmode)) - { - if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) || - (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) || - (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST && - TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE))) - error ("missing index expression"); - else - error ("incompatible index mode"); - return error_mark_node; - } - if (exprlist == NULL_TREE) - { - error ("Too few arguments in call to `readtext'"); - return error_mark_node; - } - format_str = TREE_VALUE (exprlist); - exprlist = TREE_CHAIN (exprlist); - argoffset = 1; - } - instr_addr = force_addr_of (text_arg); - instr_length = convert (integer_type_node, indexexpr); - infunction = lookup_name (get_identifier ("__readtext_f")); - } - else - { - error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression"); - return error_mark_node; - } - - /* check the format string */ - fstrtype = TREE_TYPE (format_str); - if (CH_CHARS_TYPE_P (fstrtype)) - { - /* we have a character string */ - fstr_addr = force_addr_of (format_str); - fstr_length = size_in_bytes (fstrtype); - } - else if (chill_varying_string_type_p (fstrtype)) - { - /* we have a CHARS(n) VARYING */ - fstr_addr - = force_addr_of (build_component_ref (format_str, var_data_id)); - fstr_length = build_component_ref (format_str, var_length_id); - } - else - { - error ("`format string' for READTEXT must be a CHARACTER string"); - return error_mark_node; - } - - empty_printed = False; - check_format_string (format_str, exprlist, argoffset + 3); - process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 1, argoffset); - - /* build the function call */ - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - expand_expr_stmt ( - build_chill_function_call (infunction, - tree_cons (NULL_TREE, instr_addr, - tree_cons (NULL_TREE, instr_length, - tree_cons (NULL_TREE, fstr_addr, - tree_cons (NULL_TREE, fstr_length, - tree_cons (NULL_TREE, iolist_addr, - tree_cons (NULL_TREE, iolist_length, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, - NULL_TREE)))))))))); - - /* get rid of the iolist variable, if we have one */ - if (iolist_rtx != NULL_RTX) - { - free_temp_slots (); - pop_temp_slots (); - free_temp_slots (); - pop_temp_slots (); - } - - /* return something the rest of the machinery can work with, - i.e. (void)0 */ - return build1 (CONVERT_EXPR, void_type_node, integer_zero_node); -} - -/* this function build all neccesary enum-tables used for - WRITETEXT or READTEXT of an enum */ - -void build_enum_tables () -{ - SAVE_ENUM_NAMES *names; - SAVE_ENUMS *wrk; - void *saveptr; - /* We temporarily reset the maximum_field_alignment to zero so the - compiler's init data structures can be compatible with the - run-time system, even when we're compiling with -fpack. */ - unsigned int save_maximum_field_alignment; - - if (pass == 1) - return; - - save_maximum_field_alignment = maximum_field_alignment; - maximum_field_alignment = 0; - - /* output all names */ - names = used_enum_names; - - while (names != (SAVE_ENUM_NAMES *)0) - { - tree var = get_unique_identifier ("ENUMNAME"); - tree type; - - type = build_string_type (char_type_node, - build_int_2 (IDENTIFIER_LENGTH (names->name) + 1, 0)); - names->decl = decl_temp1 (var, type, 1, - build_chill_string (IDENTIFIER_LENGTH (names->name) + 1, - IDENTIFIER_POINTER (names->name)), - 0, 0); - names = names->forward; - } - - /* output the tables and pointers to tables */ - wrk = used_enums; - while (wrk != (SAVE_ENUMS *)0) - { - tree varptr = wrk->ptrdecl; - tree table_addr = null_pointer_node; - tree init = NULL_TREE, one_entry; - tree table, idxlist, tabletype, addr; - SAVE_ENUM_VALUES *vals; - int i; - - vals = wrk->vals; - for (i = 0; i < wrk->num_vals; i++) - { - tree decl = vals->name->decl; - addr = build1 (ADDR_EXPR, - build_pointer_type (char_type_node), - decl); - TREE_CONSTANT (addr) = 1; - one_entry = tree_cons (NULL_TREE, build_int_2 (vals->val, 0), - tree_cons (NULL_TREE, addr, NULL_TREE)); - one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry); - init = tree_cons (NULL_TREE, one_entry, init); - vals++; - } - - /* add the terminator (name = null_pointer_node) to constructor */ - one_entry = tree_cons (NULL_TREE, integer_zero_node, - tree_cons (NULL_TREE, null_pointer_node, NULL_TREE)); - one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry); - init = tree_cons (NULL_TREE, one_entry, init); - init = nreverse (init); - init = build_nt (CONSTRUCTOR, NULL_TREE, init); - TREE_CONSTANT (init) = 1; - - /* generate table */ - idxlist = build_tree_list (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_zero_node, - build_int_2 (wrk->num_vals, 0))); - tabletype = build_chill_array_type (TREE_TYPE (enum_table_type), - idxlist, 0, NULL_TREE); - table = decl_temp1 (get_unique_identifier ("ENUMTAB"), tabletype, - 1, init, 0, 0); - table_addr = build1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (enum_table_type)), - table); - TREE_CONSTANT (table_addr) = 1; - - /* generate pointer to table */ - decl_temp1 (DECL_NAME (varptr), TREE_TYPE (table_addr), - 1, table_addr, 0, 0); - - /* free that stuff */ - saveptr = wrk->forward; - - free (wrk->vals); - free (wrk); - - /* next enum */ - wrk = saveptr; - } - - /* free all the names */ - names = used_enum_names; - while (names != (SAVE_ENUM_NAMES *)0) - { - saveptr = names->forward; - free (names); - names = saveptr; - } - - used_enums = (SAVE_ENUMS *)0; - used_enum_names = (SAVE_ENUM_NAMES *)0; - maximum_field_alignment = save_maximum_field_alignment; -} diff --git a/gcc/ch/lang-options.h b/gcc/ch/lang-options.h deleted file mode 100644 index 69797cbd491..00000000000 --- a/gcc/ch/lang-options.h +++ /dev/null @@ -1,40 +0,0 @@ -/* Definitions for switches for GNU CHILL. - Copyright (C) 1995, 1998 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* This is the contribution to the `documented_lang_options' array in - toplev.c for CHILL. */ - -DEFINE_LANG_NAME ("Chill") - - { "-lang-chill", "" }, - { "-flocal-loop-counter", "" }, - { "-fno-local-loop-counter", "Do not make separate scopes for every 'for' loop"}, - { "-fgrant-only", "Stop after successfully generating a grant file" }, - { "-fchill-grant-only", "" }, - { "-fold-strings", "Implement the 1984 Chill string semantics" }, - { "-fno-old-strings", "" }, - { "-fignore-case", "convert all idenitifers to lower case" }, - { "-fno-ignore-case", "" }, - { "-fpack", "Pack structures into available space"}, - { "-fno-pack", "" }, - { "-fspecial_UC", "Make special words be in uppercase" }, - { "-fspecial_LC", "" }, - { "-fruntime-checking", "" }, - { "-fno-runtime-checking", "Disable runtime checking of parameters" }, diff --git a/gcc/ch/lang-specs.h b/gcc/ch/lang-specs.h deleted file mode 100644 index 1ed4bac14cb..00000000000 --- a/gcc/ch/lang-specs.h +++ /dev/null @@ -1,30 +0,0 @@ -/* Definitions for specs for GNU CHILL. - Copyright (C) 1995, 1998, 1999 Free Software Foundation, Inc.. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* This is the contribution to the `default_compilers' array in gcc.c for - CHILL. */ - - {".ch", "@chill"}, - {".chi", "@chill"}, - {"@chill", - "tradcpp0 -lang-chill %{!no-gcc:-D__GNUCHILL__=%v1} %(cpp_options)\ - %{!M:%{!MM:%{!E:%{!pipe:%g.i} |\n\ - cc1chill %{!pipe:%g.i} %(cc1_options)\ - %{!fsyntax-only:%(invoke_as)}}}}\n"}, diff --git a/gcc/ch/lang.c b/gcc/ch/lang.c deleted file mode 100644 index 0c493b70bfe..00000000000 --- a/gcc/ch/lang.c +++ /dev/null @@ -1,305 +0,0 @@ -/* Language-specific hook definitions for CHILL front end. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "lex.h" -#include "input.h" -#include "toplev.h" -#include "rtl.h" -#include "expr.h" - -/* Type node for boolean types. */ - -tree boolean_type_node; - -/* True if STRING(INDEX) yields a CHARS(1) (or BOOLS(1)) rather than - a CHAR (or BOOL). Also, makes CHARS(1) similar for CHAR, - and BOOLS(1) similar to BOOL. This is for compatibility - for the 1984 version of Z.200.*/ -int flag_old_strings = 0; - -/* This is set non-zero to force user input tokens to lower case. - This is non-standard. See Z.200, page 8. */ -int ignore_case = 1; - -/* True if reserved and predefined words ('special' words in the Z.200 - terminology) are in uppercase. Obviously, this had better not be - true if we're ignoring input case. */ -int special_UC = 0; - -/* The actual name of the input file, regardless of any #line directives */ -const char* chill_real_input_filename; -extern FILE* finput; - -static int deep_const_expr PARAMS ((tree)); -static void chill_print_error_function PARAMS ((const char *)); - -/* Return 1 if the expression tree given has all - constant nodes as its leaves,otherwise. */ - -static int -deep_const_expr (exp) - tree exp; -{ - enum chill_tree_code code; - int length; - int i; - - if (exp == NULL_TREE) - return 0; - - code = TREE_CODE (exp); - length = first_rtl_op (TREE_CODE (exp)); - - /* constant leaf? return TRUE */ - if (TREE_CODE_CLASS (code) == 'c') - return 1; - - /* Recursively check next level down. */ - for (i = 0; i < length; i++) - if (! deep_const_expr (TREE_OPERAND (exp, i))) - return 0; - return 1; -} - - -tree -const_expr (exp) - tree exp; -{ - if (TREE_CODE (exp) == INTEGER_CST) - return exp; - if (TREE_CODE (exp) == CONST_DECL) - return const_expr (DECL_INITIAL (exp)); - if (TREE_CODE_CLASS (TREE_CODE (exp)) == 'd' - && DECL_INITIAL (exp) != NULL_TREE - && TREE_READONLY (exp)) - return DECL_INITIAL (exp); - if (deep_const_expr (exp)) - return exp; - if (TREE_CODE (exp) != ERROR_MARK) - error ("non-constant expression"); - return error_mark_node; -} - -/* Each of the functions defined here - is an alternative to a function in objc-actions.c. */ - -/* Used by c-lex.c, but only for objc. */ -tree -lookup_interface (arg) - tree arg ATTRIBUTE_UNUSED; -{ - return 0; -} - -int -maybe_objc_comptypes (lhs, rhs) - tree lhs ATTRIBUTE_UNUSED, rhs ATTRIBUTE_UNUSED; -{ - return -1; -} - -tree -maybe_building_objc_message_expr () -{ - return 0; -} - -int -recognize_objc_keyword () -{ - return 0; -} - -void -lang_init_options () -{ -} - -/* used by print-tree.c */ - -void -lang_print_xnode (file, node, indent) - FILE *file ATTRIBUTE_UNUSED; - tree node ATTRIBUTE_UNUSED; - int indent ATTRIBUTE_UNUSED; -{ -} - -/* - * process chill-specific compiler command-line options - * do not complain if the option is not recognised - */ -int -lang_decode_option (argc, argv) - int argc; - char **argv; -{ - char *p = argv[0]; - static int explicit_ignore_case = 0; - if (!strcmp(p, "-lang-chill")) - ; /* do nothing */ - else if (!strcmp (p, "-fruntime-checking")) - { - range_checking = 1; - empty_checking = 1; - } - else if (!strcmp (p, "-fno-runtime-checking")) - { - range_checking = 0; - empty_checking = 0; - runtime_checking_flag = 0; - } - else if (!strcmp (p, "-flocal-loop-counter")) - flag_local_loop_counter = 1; - else if (!strcmp (p, "-fno-local-loop-counter")) - flag_local_loop_counter = 0; - else if (!strcmp (p, "-fold-strings")) - flag_old_strings = 1; - else if (!strcmp (p, "-fno-old-strings")) - flag_old_strings = 0; - else if (!strcmp (p, "-fignore-case")) - { - explicit_ignore_case = 1; - if (special_UC) - { - error ("Ignoring case upon input and"); - error ("making special words uppercase wouldn't work."); - } - else - ignore_case = 1; - } - else if (!strcmp (p, "-fno-ignore-case")) - ignore_case = 0; - else if (!strcmp (p, "-fspecial_UC")) - { - if (explicit_ignore_case) - { - error ("Making special words uppercase and"); - error (" ignoring case upon input wouldn't work."); - } - else - special_UC = 1, ignore_case = 0; - } - else if (!strcmp (p, "-fspecial_LC")) - special_UC = 0; - else if (!strcmp (p, "-fpack")) - maximum_field_alignment = BITS_PER_UNIT; - else if (!strcmp (p, "-fno-pack")) - maximum_field_alignment = 0; - else if (!strcmp (p, "-fchill-grant-only")) - grant_only_flag = 1; - else if (!strcmp (p, "-fgrant-only")) - grant_only_flag = 1; - /* user has specified a seize-file path */ - else if (p[0] == '-' && p[1] == 'I') - register_seize_path (&p[2]); - if (!strcmp(p, "-itu")) /* Force Z.200 semantics */ - { - pedantic = 1; /* FIXME: new flag name? */ - flag_local_loop_counter = 1; - } - else - return c_decode_option (argc, argv); - - return 1; -} - -static void -chill_print_error_function (file) - const char *file; -{ - static tree last_error_function = NULL_TREE; - static struct module *last_error_module = NULL; - - if (last_error_function == current_function_decl - && last_error_module == current_module) - return; - - last_error_function = current_function_decl; - last_error_module = current_module; - - if (file) - fprintf (stderr, "%s: ", file); - - if (current_function_decl == global_function_decl - || current_function_decl == NULL_TREE) - { - if (current_module == NULL) - fprintf (stderr, "At top level:\n"); - else - fprintf (stderr, "In module %s:\n", - IDENTIFIER_POINTER (current_module->name)); - } - else - { - const char *kind = "function"; - const char *name = (*decl_printable_name) (current_function_decl, 2); - fprintf (stderr, "In %s `%s':\n", kind, name); - } -} - -/* Print an error message for invalid use of an incomplete type. - VALUE is the expression that was used (or 0 if that isn't known) - and TYPE is the type that was invalid. */ - -void -incomplete_type_error (value, type) - tree value ATTRIBUTE_UNUSED; - tree type ATTRIBUTE_UNUSED; -{ - error ("internal error - use of undefined type"); -} - -/* Return the typed-based alias set for T, which may be an expression - or a type. Return -1 if we don't do anything special. */ - -HOST_WIDE_INT -lang_get_alias_set (t) - tree t ATTRIBUTE_UNUSED; -{ - /* ??? Need to figure out what the rules are. Certainly we'd need - to handle union-like things, and probably variant records. - Until then, turn off type-based aliasing completely. */ - return 0; -} - -void -lang_init () -{ - chill_real_input_filename = input_filename; - - /* the beginning of the file is a new line; check for # */ - /* With luck, we discover the real source file's name from that - and put it in input_filename. */ - - ungetc (check_newline (), finput); - - /* set default grant file */ - set_default_grant_file (); - - print_error_function = chill_print_error_function; -} diff --git a/gcc/ch/lex.c b/gcc/ch/lex.c deleted file mode 100644 index 1a87025baae..00000000000 --- a/gcc/ch/lex.c +++ /dev/null @@ -1,2234 +0,0 @@ -/* Lexical analyzer for GNU CHILL. -*- C -*- - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include <setjmp.h> -#include <sys/stat.h> - -#include "tree.h" -#include "input.h" - -#include "lex.h" -#include "ch-tree.h" -#include "flags.h" -#include "parse.h" -#include "obstack.h" -#include "toplev.h" -#include "tm_p.h" - -#ifdef DWARF_DEBUGGING_INFO -#include "dwarfout.h" -#endif - -#ifdef MULTIBYTE_CHARS -#include <locale.h> -#endif - -/* include the keyword recognizers */ -#include "hash.h" - -FILE* finput; - -#if 0 -static int last_token = 0; -/* Sun's C compiler warns about the safer sequence - do { .. } while 0 - when there's a 'return' inside the braces, so don't use it */ -#define RETURN_TOKEN(X) { last_token = X; return (X); } -#endif - -/* This is set non-zero to force incoming tokens to lowercase. */ -extern int ignore_case; - -extern int module_number; -extern int serious_errors; - -/* This is non-zero to recognize only uppercase special words. */ -extern int special_UC; - -extern struct obstack permanent_obstack; -extern struct obstack temporary_obstack; - -/* forward declarations */ -static void close_input_file PARAMS ((const char *)); -static tree convert_bitstring PARAMS ((char *)); -static tree convert_integer PARAMS ((char *)); -static void maybe_downcase PARAMS ((char *)); -static int maybe_number PARAMS ((const char *)); -static tree equal_number PARAMS ((void)); -static void handle_use_seizefile_directive PARAMS ((int)); -static int handle_name PARAMS ((tree)); -static char *readstring PARAMS ((int, int *)); -static void read_directive PARAMS ((void)); -static tree read_identifier PARAMS ((int)); -static tree read_number PARAMS ((int)); -static void skip_c_comment PARAMS ((void)); -static void skip_line_comment PARAMS ((void)); -static int skip_whitespace PARAMS ((void)); -static tree string_or_char PARAMS ((int, const char *)); -static void ch_lex_init PARAMS ((void)); -static void skip_directive PARAMS ((void)); -static int same_file PARAMS ((const char *, const char *)); -static int getlc PARAMS ((FILE *)); - -/* next variables are public, because ch-actions uses them */ - -/* the default grantfile name, set by lang_init */ -tree default_grant_file = 0; - -/* These tasking-related variables are NULL at the start of each - compiler pass, and are set to an expression tree if and when - a compiler directive is parsed containing an expression. - The NULL state is significant; it means 'no user-specified - signal_code (or whatever) has been parsed'. */ - -/* process type, set by <> PROCESS_TYPE = number <> */ -tree process_type = NULL_TREE; - -/* send buffer default priority, - set by <> SEND_BUFFER_DEFAULT_PRIORITY = number <> */ -tree send_buffer_prio = NULL_TREE; - -/* send signal default priority, - set by <> SEND_SIGNAL_DEFAULT_PRIORITY = number <> */ -tree send_signal_prio = NULL_TREE; - -/* signal code, set by <> SIGNAL_CODE = number <> */ -tree signal_code = NULL_TREE; - -/* flag for range checking */ -int range_checking = 1; - -/* flag for NULL pointer checking */ -int empty_checking = 1; - -/* flag to indicate making all procedure local variables - to be STATIC */ -int all_static_flag = 0; - -/* flag to indicate -fruntime-checking command line option. - Needed for initializing range_checking and empty_checking - before pass 2 */ -int runtime_checking_flag = 1; - -/* The elements of `ridpointers' are identifier nodes - for the reserved type names and storage classes. - It is indexed by a RID_... value. */ -tree ridpointers[(int) RID_MAX]; - -/* Nonzero tells yylex to ignore \ in string constants. */ -static int ignore_escape_flag = 0; - -static int maxtoken; /* Current nominal length of token buffer. */ -char *token_buffer; /* Pointer to token buffer. - Actual allocated length is maxtoken + 2. - This is not static because objc-parse.y uses it. */ - -/* implement yylineno handling for flex */ -#define yylineno lineno - -static int inside_c_comment = 0; - -static int saw_eol = 0; /* 1 if we've just seen a '\n' */ -static int saw_eof = 0; /* 1 if we've just seen an EOF */ - -typedef struct string_list - { - struct string_list *next; - char *str; - } STRING_LIST; - -/* list of paths specified on the compiler command line by -L options. */ -static STRING_LIST *seize_path_list = (STRING_LIST *)0; - -/* List of seize file names. Each TREE_VALUE is an identifier - (file name) from a <>USE_SEIZE_FILE<> directive. - The TREE_PURPOSE is non-NULL if a USE_SEIZE_FILE directive has been - written to the grant file. */ -static tree files_to_seize = NULL_TREE; -/* Last node on files_to_seize list. */ -static tree last_file_to_seize = NULL_TREE; -/* Pointer into files_to_seize list: Next unparsed file to read. */ -static tree next_file_to_seize = NULL_TREE; - -/* The most recent use_seize_file directive. */ -tree use_seizefile_name = NULL_TREE; - -/* If non-NULL, the name of the seizefile we're currently processing. */ -tree current_seizefile_name = NULL_TREE; - -/* called to reset for pass 2 */ -static void -ch_lex_init () -{ - current_seizefile_name = NULL_TREE; - - lineno = 0; - - saw_eol = 0; - saw_eof = 0; - /* Initialize these compiler-directive variables. */ - process_type = NULL_TREE; - send_buffer_prio = NULL_TREE; - send_signal_prio = NULL_TREE; - signal_code = NULL_TREE; - all_static_flag = 0; - /* reinitialize rnage checking and empty checking */ - range_checking = runtime_checking_flag; - empty_checking = runtime_checking_flag; -} - - -const char * -init_parse (filename) - const char *filename; -{ - int lowercase_standard_names = ignore_case || ! special_UC; - - /* Open input file. */ - if (filename == 0 || !strcmp (filename, "-")) - { - finput = stdin; - filename = "stdin"; - } - else - finput = fopen (filename, "r"); - - if (finput == 0) - fatal_io_error ("can't open %s", filename); - -#ifdef IO_BUFFER_SIZE - setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE); -#endif - - /* Make identifier nodes long enough for the language-specific slots. */ - set_identifier_size (sizeof (struct lang_identifier)); - - /* Start it at 0, because check_newline is called at the very beginning - and will increment it to 1. */ - lineno = 0; - - /* Initialize these compiler-directive variables. */ - process_type = NULL_TREE; - send_buffer_prio = NULL_TREE; - send_signal_prio = NULL_TREE; - signal_code = NULL_TREE; - - maxtoken = 40; - token_buffer = xmalloc ((unsigned)(maxtoken + 2)); - - init_chill_expand (); - -#define ENTER_STANDARD_NAME(RID, LOWER, UPPER) \ - ridpointers[(int) RID] = \ - get_identifier (lowercase_standard_names ? LOWER : UPPER) - - ENTER_STANDARD_NAME (RID_ALL, "all", "ALL"); - ENTER_STANDARD_NAME (RID_ASSERTFAIL, "assertfail", "ASSERTFAIL"); - ENTER_STANDARD_NAME (RID_ASSOCIATION, "association", "ASSOCIATION"); - ENTER_STANDARD_NAME (RID_BIN, "bin", "BIN"); - ENTER_STANDARD_NAME (RID_BOOL, "bool", "BOOL"); - ENTER_STANDARD_NAME (RID_BOOLS, "bools", "BOOLS"); - ENTER_STANDARD_NAME (RID_BYTE, "byte", "BYTE"); - ENTER_STANDARD_NAME (RID_CHAR, "char", "CHAR"); - ENTER_STANDARD_NAME (RID_DOUBLE, "double", "DOUBLE"); - ENTER_STANDARD_NAME (RID_DURATION, "duration", "DURATION"); - ENTER_STANDARD_NAME (RID_DYNAMIC, "dynamic", "DYNAMIC"); - ENTER_STANDARD_NAME (RID_ELSE, "else", "ELSE"); - ENTER_STANDARD_NAME (RID_EMPTY, "empty", "EMPTY"); - ENTER_STANDARD_NAME (RID_FALSE, "false", "FALSE"); - ENTER_STANDARD_NAME (RID_FLOAT, "float", "FLOAT"); - ENTER_STANDARD_NAME (RID_GENERAL, "general", "GENERAL"); - ENTER_STANDARD_NAME (RID_IN, "in", "IN"); - ENTER_STANDARD_NAME (RID_INLINE, "inline", "INLINE"); - ENTER_STANDARD_NAME (RID_INOUT, "inout", "INOUT"); - ENTER_STANDARD_NAME (RID_INSTANCE, "instance", "INSTANCE"); - ENTER_STANDARD_NAME (RID_INT, "int", "INT"); - ENTER_STANDARD_NAME (RID_LOC, "loc", "LOC"); - ENTER_STANDARD_NAME (RID_LONG, "long", "LONG"); - ENTER_STANDARD_NAME (RID_LONG_REAL, "long_real", "LONG_REAL"); - ENTER_STANDARD_NAME (RID_NULL, "null", "NULL"); - ENTER_STANDARD_NAME (RID_OUT, "out", "OUT"); - ENTER_STANDARD_NAME (RID_OVERFLOW, "overflow", "OVERFLOW"); - ENTER_STANDARD_NAME (RID_PTR, "ptr", "PTR"); - ENTER_STANDARD_NAME (RID_READ, "read", "READ"); - ENTER_STANDARD_NAME (RID_REAL, "real", "REAL"); - ENTER_STANDARD_NAME (RID_RANGE, "range", "RANGE"); - ENTER_STANDARD_NAME (RID_RANGEFAIL, "rangefail", "RANGEFAIL"); - ENTER_STANDARD_NAME (RID_RECURSIVE, "recursive", "RECURSIVE"); - ENTER_STANDARD_NAME (RID_SHORT, "short", "SHORT"); - ENTER_STANDARD_NAME (RID_SIMPLE, "simple", "SIMPLE"); - ENTER_STANDARD_NAME (RID_TIME, "time", "TIME"); - ENTER_STANDARD_NAME (RID_TRUE, "true", "TRUE"); - ENTER_STANDARD_NAME (RID_UBYTE, "ubyte", "UBYTE"); - ENTER_STANDARD_NAME (RID_UINT, "uint", "UINT"); - ENTER_STANDARD_NAME (RID_ULONG, "ulong", "ULONG"); - ENTER_STANDARD_NAME (RID_UNSIGNED, "unsigned", "UNSIGNED"); - ENTER_STANDARD_NAME (RID_USHORT, "ushort", "USHORT"); - ENTER_STANDARD_NAME (RID_VOID, "void", "VOID"); - - return filename; -} - -void -finish_parse () -{ - if (finput != NULL) - fclose (finput); -} - -static int yywrap PARAMS ((void)); -static int yy_refill PARAMS ((void)); - -#define YY_PUTBACK_SIZE 5 -#define YY_BUF_SIZE 1000 - -static char yy_buffer[YY_PUTBACK_SIZE + YY_BUF_SIZE]; -static char *yy_cur = yy_buffer + YY_PUTBACK_SIZE; -static char *yy_lim = yy_buffer + YY_PUTBACK_SIZE; - -static int -yy_refill () -{ - char *buf = yy_buffer + YY_PUTBACK_SIZE; - int c, result; - bcopy (yy_cur - YY_PUTBACK_SIZE, yy_buffer, YY_PUTBACK_SIZE); - yy_cur = buf; - - retry: - if (saw_eof) - { - if (yywrap ()) - return EOF; - saw_eof = 0; - goto retry; - } - - result = 0; - while (saw_eol) - { - c = check_newline (); - if (c == EOF) - { - saw_eof = 1; - goto retry; - } - else if (c != '\n') - { - saw_eol = 0; - buf[result++] = c; - } - } - - while (result < YY_BUF_SIZE) - { - c = getc(finput); - if (c == EOF) - { - saw_eof = 1; - break; - } - buf[result++] = c; - - /* Because we might switch input files on a compiler directive - (that end with '>', don't read past a '>', just in case. */ - if (c == '>') - break; - - if (c == '\n') - { -#ifdef YYDEBUG - extern int yydebug; - if (yydebug) - fprintf (stderr, "-------------------------- finished Line %d\n", - yylineno); -#endif - saw_eol = 1; - break; - } - } - - yy_lim = yy_cur + result; - - return yy_lim > yy_cur ? *yy_cur++ : EOF; -} - -#define input() (yy_cur < yy_lim ? *yy_cur++ : yy_refill ()) - -#define unput(c) (*--yy_cur = (c)) - - -int starting_pass_2 = 0; - -int -yylex () -{ - int nextc; - int len; - char* tmp; - int base; - int ch; - retry: - ch = input (); - if (starting_pass_2) - { - starting_pass_2 = 0; - unput (ch); - return END_PASS_1; - } - switch (ch) - { - case ' ': case '\t': case '\n': case '\f': case '\b': case '\v': case '\r': - goto retry; - case '[': - return LPC; - case ']': - return RPC; - case '{': - return LC; - case '}': - return RC; - case '(': - nextc = input (); - if (nextc == ':') - return LPC; - unput (nextc); - return LPRN; - case ')': - return RPRN; - case ':': - nextc = input (); - if (nextc == ')') - return RPC; - else if (nextc == '=') - return ASGN; - unput (nextc); - return COLON; - case ',': - return COMMA; - case ';': - return SC; - case '+': - return PLUS; - case '-': - nextc = input (); - if (nextc == '>') - return ARROW; - if (nextc == '-') - { - skip_line_comment (); - goto retry; - } - unput (nextc); - return SUB; - case '*': - return MUL; - case '=': - return EQL; - case '/': - nextc = input (); - if (nextc == '/') - return CONCAT; - else if (nextc == '=') - return NE; - else if (nextc == '*') - { - skip_c_comment (); - goto retry; - } - unput (nextc); - return DIV; - case '<': - nextc = input (); - if (nextc == '=') - return LTE; - if (nextc == '>') - { - read_directive (); - goto retry; - } - unput (nextc); - return LT; - case '>': - nextc = input (); - if (nextc == '=') - return GTE; - unput (nextc); - return GT; - - case 'D': case 'd': - base = 10; - goto maybe_digits; - case 'B': case 'b': - base = 2; - goto maybe_digits; - case 'H': case 'h': - base = 16; - goto maybe_digits; - case 'O': case 'o': - base = 8; - goto maybe_digits; - case 'C': case 'c': - nextc = input (); - if (nextc == '\'') - { - int byte_val = 0; - char *start; - int len = 0; /* Number of hex digits seen. */ - for (;;) - { - ch = input (); - if (ch == '\'') - break; - if (ch == '_') - continue; - if (!ISXDIGIT (ch)) /* error on non-hex digit */ - { - if (pass == 1) - error ("invalid C'xx' "); - break; - } - if (ch >= 'a') - ch -= ' '; - ch -= '0'; - if (ch > 9) - ch -= 7; - byte_val *= 16; - byte_val += (int)ch; - - if (len & 1) /* collected two digits, save byte */ - obstack_1grow (&temporary_obstack, (char) byte_val); - len++; - } - start = obstack_finish (&temporary_obstack); - yylval.ttype = string_or_char (len >> 1, start); - obstack_free (&temporary_obstack, start); - return len == 2 ? SINGLECHAR : STRING; - } - unput (nextc); - goto letter; - - maybe_digits: - nextc = input (); - if (nextc == '\'') - { - char *start; - obstack_1grow (&temporary_obstack, ch); - obstack_1grow (&temporary_obstack, nextc); - for (;;) - { - ch = input (); - if (ISALNUM (ch)) - obstack_1grow (&temporary_obstack, ch); - else if (ch != '_') - break; - } - obstack_1grow (&temporary_obstack, '\0'); - start = obstack_finish (&temporary_obstack); - if (ch != '\'') - { - unput (ch); - yylval.ttype = convert_integer (start); /* Pass base? */ - return NUMBER; - } - else - { - yylval.ttype = convert_bitstring (start); - return BITSTRING; - } - } - unput (nextc); - goto letter; - - case 'A': case 'E': - case 'F': case 'G': case 'I': case 'J': - case 'K': case 'L': case 'M': case 'N': - case 'P': case 'Q': case 'R': case 'S': case 'T': - case 'U': case 'V': case 'W': case 'X': case 'Y': - case 'Z': - case 'a': case 'e': - case 'f': case 'g': case 'i': case 'j': - case 'k': case 'l': case 'm': case 'n': - case 'p': case 'q': case 'r': case 's': case 't': - case 'u': case 'v': case 'w': case 'x': case 'y': - case 'z': - case '_': - letter: - return handle_name (read_identifier (ch)); - case '\'': - tmp = readstring ('\'', &len); - yylval.ttype = string_or_char (len, tmp); - free (tmp); - return len == 1 ? SINGLECHAR : STRING; - case '\"': - tmp = readstring ('\"', &len); - yylval.ttype = build_chill_string (len, tmp); - free (tmp); - return STRING; - case '.': - nextc = input (); - unput (nextc); - if (ISDIGIT (nextc)) /* || nextc == '_') we don't start numbers with '_' */ - goto number; - return DOT; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - number: - yylval.ttype = read_number (ch); - return TREE_CODE (yylval.ttype) == REAL_CST ? FLOATING : NUMBER; - default: - return ch; - } -} - -static void -close_input_file (fn) - const char *fn; -{ - if (finput == NULL) - abort (); - - if (finput != stdin && fclose (finput) == EOF) - { - error ("can't close %s", fn); - abort (); - } - finput = NULL; -} - -/* Return an identifier, starting with FIRST and then reading - more characters using input(). Return an IDENTIFIER_NODE. */ - -static tree -read_identifier (first) - int first; /* First letter of identifier */ -{ - tree id; - char *start; - for (;;) - { - obstack_1grow (&temporary_obstack, first); - first = input (); - if (first == EOF) - break; - if (! ISALNUM (first) && first != '_') - { - unput (first); - break; - } - } - obstack_1grow (&temporary_obstack, '\0'); - start = obstack_finish (&temporary_obstack); - maybe_downcase (start); - id = get_identifier (start); - obstack_free (&temporary_obstack, start); - return id; -} - -/* Given an identifier ID, check to see if it is a reserved name, - and return the appropriate token type. */ - -static int -handle_name (id) - tree id; -{ - struct resword *tp; - tp = in_word_set (IDENTIFIER_POINTER (id), IDENTIFIER_LENGTH (id)); - if (tp != NULL - && special_UC == ISUPPER ((unsigned char) tp->name[0]) - && (tp->flags == RESERVED || tp->flags == PREDEF)) - { - if (tp->rid != NORID) - yylval.ttype = ridpointers[tp->rid]; - else if (tp->token == THIS) - yylval.ttype = lookup_name (get_identifier ("__whoami")); - return tp->token; - } - yylval.ttype = id; - return NAME; -} - -static tree -read_number (ch) - int ch; /* Initial character */ -{ - tree num; - char *start; - int is_float = 0; - for (;;) - { - if (ch != '_') - obstack_1grow (&temporary_obstack, ch); - ch = input (); - if (! ISDIGIT (ch) && ch != '_') - break; - } - if (ch == '.') - { - do - { - if (ch != '_') - obstack_1grow (&temporary_obstack, ch); - ch = input (); - } while (ISDIGIT (ch) || ch == '_'); - is_float++; - } - if (ch == 'd' || ch == 'D' || ch == 'e' || ch == 'E') - { - /* Convert exponent indication [eEdD] to 'e'. */ - obstack_1grow (&temporary_obstack, 'e'); - ch = input (); - if (ch == '+' || ch == '-') - { - obstack_1grow (&temporary_obstack, ch); - ch = input (); - } - if (ISDIGIT (ch) || ch == '_') - { - do - { - if (ch != '_') - obstack_1grow (&temporary_obstack, ch); - ch = input (); - } while (ISDIGIT (ch) || ch == '_'); - } - else - { - error ("malformed exponent part of floating-point literal"); - } - is_float++; - } - if (ch != EOF) - unput (ch); - obstack_1grow (&temporary_obstack, '\0'); - start = obstack_finish (&temporary_obstack); - if (is_float) - { - REAL_VALUE_TYPE value; - tree type = double_type_node; - errno = 0; - value = REAL_VALUE_ATOF (start, TYPE_MODE (type)); - obstack_free (&temporary_obstack, start); - if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT - && REAL_VALUE_ISINF (value) && pedantic) - pedwarn ("real number exceeds range of REAL"); - num = build_real (type, value); - } - else - num = convert_integer (start); - CH_DERIVED_FLAG (num) = 1; - return num; -} - -/* Skip to the end of a compiler directive. */ - -static void -skip_directive () -{ - int ch = input (); - for (;;) - { - if (ch == EOF) - { - error ("end-of-file in '<>' directive"); - break; - } - if (ch == '\n') - break; - if (ch == '<') - { - ch = input (); - if (ch == '>') - break; - } - ch = input (); - } - starting_pass_2 = 0; -} - -/* Read a compiler directive. ("<>{WS}" have already been read. ) */ -static void -read_directive () -{ - struct resword *tp; - tree id; - int ch = skip_whitespace(); - if (ISALPHA (ch) || ch == '_') - id = read_identifier (ch); - else if (ch == EOF) - { - error ("end-of-file in '<>' directive"); - to_global_binding_level (); - return; - } - else - { - warning ("unrecognized compiler directive"); - skip_directive (); - return; - } - tp = in_word_set (IDENTIFIER_POINTER (id), IDENTIFIER_LENGTH (id)); - if (tp == NULL || special_UC != ISUPPER ((unsigned char) tp->name[0])) - { - if (pass == 1) - warning ("unrecognized compiler directive `%s'", - IDENTIFIER_POINTER (id)); - } - else - switch (tp->token) - { - case ALL_STATIC_OFF: - all_static_flag = 0; - break; - case ALL_STATIC_ON: - all_static_flag = 1; - break; - case EMPTY_OFF: - empty_checking = 0; - break; - case EMPTY_ON: - empty_checking = 1; - break; - case IGNORED_DIRECTIVE: - break; - case PROCESS_TYPE_TOKEN: - process_type = equal_number (); - break; - case RANGE_OFF: - range_checking = 0; - break; - case RANGE_ON: - range_checking = 1; - break; - case SEND_SIGNAL_DEFAULT_PRIORITY: - send_signal_prio = equal_number (); - break; - case SEND_BUFFER_DEFAULT_PRIORITY: - send_buffer_prio = equal_number (); - break; - case SIGNAL_CODE: - signal_code = equal_number (); - break; - case USE_SEIZE_FILE: - handle_use_seizefile_directive (0); - break; - case USE_SEIZE_FILE_RESTRICTED: - handle_use_seizefile_directive (1); - break; - default: - if (pass == 1) - warning ("unrecognized compiler directive `%s'", - IDENTIFIER_POINTER (id)); - break; - } - skip_directive (); -} - - -tree -build_chill_string (len, str) - int len; - const char *str; -{ - tree t; - - push_obstacks (&permanent_obstack, &permanent_obstack); - t = build_string (len, str); - TREE_TYPE (t) = build_string_type (char_type_node, - build_int_2 (len, 0)); - CH_DERIVED_FLAG (t) = 1; - pop_obstacks (); - return t; -} - - -static tree -string_or_char (len, str) - int len; - const char *str; -{ - tree result; - - push_obstacks (&permanent_obstack, &permanent_obstack); - if (len == 1) - { - result = build_int_2 ((unsigned char)str[0], 0); - CH_DERIVED_FLAG (result) = 1; - TREE_TYPE (result) = char_type_node; - } - else - result = build_chill_string (len, str); - pop_obstacks (); - return result; -} - - -static void -maybe_downcase (str) - char *str; -{ - if (! ignore_case) - return; - while (*str) - { - *str = TOLOWER (*str); - str++; - } -} - - -static int -maybe_number (s) - const char *s; -{ - char fc; - - /* check for decimal number */ - if (*s >= '0' && *s <= '9') - { - while (*s) - { - if (*s >= '0' && *s <= '9') - s++; - else - return 0; - } - return 1; - } - - fc = *s; - if (s[1] != '\'') - return 0; - s += 2; - while (*s) - { - switch (fc) - { - case 'd': - case 'D': - if (*s < '0' || *s > '9') - return 0; - break; - case 'h': - case 'H': - if (!ISXDIGIT ((unsigned char) *s)) - return 0; - break; - case 'b': - case 'B': - if (*s < '0' || *s > '1') - return 0; - break; - case 'o': - case 'O': - if (*s < '0' || *s > '7') - return 0; - break; - default: - return 0; - } - s++; - } - return 1; -} - -static char * -readstring (terminator, len) - char terminator; - int *len; -{ - int c; - unsigned allocated = 1024; - char *tmp = xmalloc (allocated); - unsigned i = 0; - - for (;;) - { - c = input (); - if (c == terminator) - { - if ((c = input ()) != terminator) - { - unput (c); - break; - } - else - c = terminator; - } - if (c == '\n' || c == EOF) - goto unterminated; - if (c == '^') - { - c = input(); - if (c == EOF || c == '\n') - goto unterminated; - if (c == '^') - goto storeit; - if (c == '(') - { - int cc, count = 0; - int base = 10; - int next_apos = 0; - int check_base = 1; - c = 0; - while (1) - { - cc = input (); - if (cc == terminator) - { - if (!(terminator == '\'' && next_apos)) - { - error ("unterminated control sequence"); - serious_errors++; - goto done; - } - } - if (cc == EOF || cc == '\n') - { - c = cc; - goto unterminated; - } - if (next_apos) - { - next_apos = 0; - if (cc != '\'') - { - error ("invalid integer literal in control sequence"); - serious_errors++; - goto done; - } - continue; - } - if (cc == ' ' || cc == '\t') - continue; - if (cc == ')') - { - if ((c < 0 || c > 255) && (pass == 1)) - error ("control sequence overflow"); - if (! count && pass == 1) - error ("invalid control sequence"); - break; - } - else if (cc == ',') - { - if ((c < 0 || c > 255) && (pass == 1)) - error ("control sequence overflow"); - if (! count && pass == 1) - error ("invalid control sequence"); - tmp[i++] = c; - if (i == allocated) - { - allocated += 1024; - tmp = xrealloc (tmp, allocated); - } - c = count = 0; - base = 10; - check_base = 1; - continue; - } - else if (cc == '_') - { - if (! count && pass == 1) - error ("invalid integer literal in control sequence"); - continue; - } - if (check_base) - { - if (cc == 'D' || cc == 'd') - { - base = 10; - next_apos = 1; - } - else if (cc == 'H' || cc == 'h') - { - base = 16; - next_apos = 1; - } - else if (cc == 'O' || cc == 'o') - { - base = 8; - next_apos = 1; - } - else if (cc == 'B' || cc == 'b') - { - base = 2; - next_apos = 1; - } - check_base = 0; - if (next_apos) - continue; - } - if (base == 2) - { - if (cc < '0' || cc > '1') - cc = -1; - else - cc -= '0'; - } - else if (base == 8) - { - if (cc < '0' || cc > '8') - cc = -1; - else - cc -= '0'; - } - else if (base == 10) - { - if (! ISDIGIT (cc)) - cc = -1; - else - cc -= '0'; - } - else if (base == 16) - { - if (!ISXDIGIT (cc)) - cc = -1; - else - { - if (cc >= 'a') - cc -= ' '; - cc -= '0'; - if (cc > 9) - cc -= 7; - } - } - else - { - error ("invalid base in read control sequence"); - abort (); - } - if (cc == -1) - { - /* error in control sequence */ - if (pass == 1) - error ("invalid digit in control sequence"); - cc = 0; - } - c = (c * base) + cc; - count++; - } - } - else - c ^= 64; - } - storeit: - tmp[i++] = c; - if (i == allocated) - { - allocated += 1024; - tmp = xrealloc (tmp, allocated); - } - } - done: - tmp [*len = i] = '\0'; - return tmp; - -unterminated: - if (c == '\n') - unput ('\n'); - *len = 1; - if (pass == 1) - error ("unterminated string literal"); - to_global_binding_level (); - tmp[0] = '\0'; - return tmp; -} - -/* Convert an integer INTCHARS into an INTEGER_CST. - INTCHARS is on the temporary_obstack, and is popped by this function. */ - -static tree -convert_integer (intchars) - char *intchars; -{ -#ifdef YYDEBUG - extern int yydebug; -#endif - char *p = intchars; - char *oldp = p; - int base = 10, tmp; - int valid_chars = 0; - int overflow = 0; - tree type; - HOST_WIDE_INT val_lo = 0, val_hi = 0; - tree val; - - /* determine the base */ - switch (*p) - { - case 'd': - case 'D': - p += 2; - break; - case 'o': - case 'O': - p += 2; - base = 8; - break; - case 'h': - case 'H': - p += 2; - base = 16; - break; - case 'b': - case 'B': - p += 2; - base = 2; - break; - default: - if (!ISDIGIT (*p)) /* this test is for equal_number () */ - { - obstack_free (&temporary_obstack, intchars); - return 0; - } - break; - } - - while (*p) - { - tmp = *p++; - if ((tmp == '\'') || (tmp == '_')) - continue; - if (tmp < '0') - goto bad_char; - if (tmp >= 'a') /* uppercase the char */ - tmp -= ' '; - switch (base) /* validate the characters */ - { - case 2: - if (tmp > '1') - goto bad_char; - break; - case 8: - if (tmp > '7') - goto bad_char; - break; - case 10: - if (tmp > '9') - goto bad_char; - break; - case 16: - if (tmp > 'F') - goto bad_char; - if (tmp > '9' && tmp < 'A') - goto bad_char; - break; - default: - abort (); - } - tmp -= '0'; - if (tmp > 9) - tmp -= 7; - if (mul_double (val_lo, val_hi, base, 0, &val_lo, &val_hi)) - overflow++; - add_double (val_lo, val_hi, tmp, 0, &val_lo, &val_hi); - if (val_hi < 0) - overflow++; - valid_chars++; - } - bad_char: - obstack_free (&temporary_obstack, intchars); - if (!valid_chars) - { - if (pass == 2) - error ("invalid number format `%s'", oldp); - return 0; - } - val = build_int_2 (val_lo, val_hi); - /* We set the type to long long (or long long unsigned) so that - constant fold of literals is less likely to overflow. */ - if (int_fits_type_p (val, long_long_integer_type_node)) - type = long_long_integer_type_node; - else - { - if (! int_fits_type_p (val, long_long_unsigned_type_node)) - overflow++; - type = long_long_unsigned_type_node; - } - TREE_TYPE (val) = type; - CH_DERIVED_FLAG (val) = 1; - - if (overflow) - error ("integer literal too big"); - - return val; -} - -/* Convert a bitstring literal on the temporary_obstack to - a bitstring CONSTRUCTOR. Free the literal from the obstack. */ - -static tree -convert_bitstring (p) - char *p; -{ -#ifdef YYDEBUG - extern int yydebug; -#endif - int bl = 0, valid_chars = 0, bits_per_char = 0, c, k; - tree initlist = NULL_TREE; - tree val; - - /* Move p to stack so we can re-use temporary_obstack for result. */ - char *oldp = (char*) alloca (strlen (p) + 1); - strcpy (oldp, p); - obstack_free (&temporary_obstack, p); - p = oldp; - - switch (*p) - { - case 'h': - case 'H': - bits_per_char = 4; - break; - case 'o': - case 'O': - bits_per_char = 3; - break; - case 'b': - case 'B': - bits_per_char = 1; - break; - } - p += 2; - - while (*p) - { - c = *p++; - if (c == '_' || c == '\'') - continue; - if (c >= 'a') - c -= ' '; - c -= '0'; - if (c > 9) - c -= 7; - valid_chars++; - - for (k = BYTES_BIG_ENDIAN ? bits_per_char - 1 : 0; - BYTES_BIG_ENDIAN ? k >= 0 : k < bits_per_char; - bl++, BYTES_BIG_ENDIAN ? k-- : k++) - { - if (c & (1 << k)) - initlist = tree_cons (NULL_TREE, build_int_2 (bl, 0), initlist); - } - } -#if 0 - /* as long as BOOLS(0) is valid it must tbe possible to - specify an empty bitstring */ - if (!valid_chars) - { - if (pass == 2) - error ("invalid number format `%s'", oldp); - return 0; - } -#endif - val = build (CONSTRUCTOR, - build_bitstring_type (size_int (bl)), - NULL_TREE, nreverse (initlist)); - TREE_CONSTANT (val) = 1; - CH_DERIVED_FLAG (val) = 1; - return val; -} - -/* Check if two filenames name the same file. - This is done by stat'ing both files and comparing their inodes. - - Note: we have to take care of seize_path_list. Therefore do it the same - way as in yywrap. FIXME: This probably can be done better. */ - -static int -same_file (filename1, filename2) - const char *filename1; - const char *filename2; -{ - struct stat s[2]; - const char *fn_input[2]; - int i, stat_status; - - if (grant_only_flag) - /* do nothing in this case */ - return 0; - - /* if filenames are equal -- return 1, cause there is no need - to search in the include list in this case */ - if (strcmp (filename1, filename2) == 0) - return 1; - - fn_input[0] = filename1; - fn_input[1] = filename2; - - for (i = 0; i < 2; i++) - { - stat_status = stat (fn_input[i], &s[i]); - if (stat_status < 0 - && strchr (fn_input[i], '/') == 0) - { - STRING_LIST *plp; - char *path; - - for (plp = seize_path_list; plp != 0; plp = plp->next) - { - path = (char *) xmalloc (strlen (fn_input[i]) - + strlen (plp->str) + 2); - sprintf (path, "%s/%s", plp->str, fn_input[i]); - stat_status = stat (path, &s[i]); - free (path); - if (stat_status >= 0) - break; - } - } - - if (stat_status < 0) - fatal_io_error ("can't find %s", fn_input[i]); - } - return s[0].st_ino == s[1].st_ino && s[0].st_dev == s[1].st_dev; -} - -/* - * Note that simply appending included file names to a list in this - * way completely eliminates the need for nested files, and the - * associated book-keeping, since the EOF processing in the lexer - * will simply process the files one at a time, in the order that the - * USE_SEIZE_FILE directives were scanned. - */ -static void -handle_use_seizefile_directive (restricted) - int restricted; -{ - tree seen; - int len; - int c = skip_whitespace (); - char *use_seizefile_str = readstring (c, &len); - - if (pass > 1) - return; - - if (c != '\'' && c != '\"') - { - error ("USE_SEIZE_FILE directive must be followed by string"); - return; - } - - use_seizefile_name = get_identifier (use_seizefile_str); - CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name) = restricted; - - if (!grant_only_flag) - { - /* If file foo.ch contains a <> use_seize_file "bar.grt" <>, - and file bar.ch contains a <> use_seize_file "foo.grt" <>, - then if we're compiling foo.ch, we will indirectly be - asked to seize foo.grt. Don't. */ - extern char *grant_file_name; - if (strcmp (use_seizefile_str, grant_file_name) == 0) - return; - - /* Check if the file is already on the list. */ - for (seen = files_to_seize; seen != NULL_TREE; seen = TREE_CHAIN (seen)) - if (same_file (IDENTIFIER_POINTER (TREE_VALUE (seen)), - use_seizefile_str)) - return; /* Previously seen; nothing to do. */ - } - - /* Haven't been asked to seize this file yet, so add - its name to the list. */ - { - tree pl = perm_tree_cons (0, use_seizefile_name, NULL_TREE); - if (files_to_seize == NULL_TREE) - files_to_seize = pl; - else - TREE_CHAIN (last_file_to_seize) = pl; - if (next_file_to_seize == NULL_TREE) - next_file_to_seize = pl; - last_file_to_seize = pl; - } -} - - -/* - * get input, convert to lower case for comparison - */ -static int -getlc (file) - FILE *file; -{ - register int c; - - c = getc (file); - if (ignore_case) - c = TOLOWER (c); - return c; -} - -#if defined HANDLE_PRAGMA -/* Local versions of these macros, that can be passed as function pointers. */ -static int -pragma_getc () -{ - return getc (finput); -} - -static void -pragma_ungetc (arg) - int arg; -{ - ungetc (arg, finput); -} -#endif /* HANDLE_PRAGMA */ - -#ifdef HANDLE_GENERIC_PRAGMAS -/* Handle a generic #pragma directive. - BUFFER contains the text we read after `#pragma'. Processes the entire input - line and return non-zero iff the pragma was successfully processed. */ - -static int -handle_generic_pragma (buffer) - char * buffer; -{ - register int c; - - for (;;) - { - char * buff; - - handle_pragma_token (buffer, NULL); - - c = getc (finput); - - while (c == ' ' || c == '\t') - c = getc (finput); - ungetc (c, finput); - - if (c == '\n' || c == EOF) - return handle_pragma_token (NULL, NULL); - - /* Read the next word of the pragma into the buffer. */ - buff = buffer; - do - { - * buff ++ = c; - c = getc (finput); - } - while (c != EOF && ! ISSPACE (c) && buff < buffer + 128); - /* XXX shared knowledge about size of buffer. */ - - ungetc (c, finput); - - * -- buff = 0; - } -} -#endif /* HANDLE_GENERIC_PRAGMAS */ - -/* At the beginning of a line, increment the line number and process - any #-directive on this line. If the line is a #-directive, read - the entire line and return a newline. Otherwise, return the line's - first non-whitespace character. - - (Each language front end has a check_newline() function that is called - from lang_init() for that language. One of the things this function - must do is read the first line of the input file, and if it is a #line - directive, extract the filename from it and use it to initialize - main_input_filename. Proper generation of debugging information in - the normal "front end calls cpp then calls cc1XXXX environment" depends - upon this being done.) */ - -int -check_newline () -{ - register int c; - - lineno++; - - /* Read first nonwhite char on the line. */ - - c = getc (finput); - - while (c == ' ' || c == '\t') - c = getc (finput); - - if (c != '#' || inside_c_comment) - { - /* If not #, return it so caller will use it. */ - return c; - } - - /* Read first nonwhite char after the `#'. */ - - c = getc (finput); - while (c == ' ' || c == '\t') - c = getc (finput); - - /* If a letter follows, then if the word here is `line', skip - it and ignore it; otherwise, ignore the line, with an error - if the word isn't `pragma', `ident', `define', or `undef'. */ - - if (ignore_case) - c = TOLOWER (c); - - if (c >= 'a' && c <= 'z') - { - if (c == 'p') - { - if (getlc (finput) == 'r' - && getlc (finput) == 'a' - && getlc (finput) == 'g' - && getlc (finput) == 'm' - && getlc (finput) == 'a' - && (c = getlc (finput), ISSPACE (c))) - { -#ifdef HANDLE_PRAGMA - static char buffer [128]; - char * buff = buffer; - - /* Read the pragma name into a buffer. */ - while (c = getlc (finput), ISSPACE (c)) - continue; - - do - { - * buff ++ = c; - c = getlc (finput); - } - while (c != EOF && ! ISSPACE (c) && c != '\n' - && buff < buffer + 128); - - pragma_ungetc (c); - - * -- buff = 0; - - if (HANDLE_PRAGMA (pragma_getc, pragma_ungetc, buffer)) - goto skipline; -#endif /* HANDLE_PRAGMA */ - -#ifdef HANDLE_GENERIC_PRAGMAS - if (handle_generic_pragma (buffer)) - goto skipline; -#endif /* HANDLE_GENERIC_PRAGMAS */ - - goto skipline; - } - } - - else if (c == 'd') - { - if (getlc (finput) == 'e' - && getlc (finput) == 'f' - && getlc (finput) == 'i' - && getlc (finput) == 'n' - && getlc (finput) == 'e' - && (c = getlc (finput), ISSPACE (c))) - { -#if 0 /*def DWARF_DEBUGGING_INFO*/ - if (c != '\n' - && (debug_info_level == DINFO_LEVEL_VERBOSE) - && (write_symbols == DWARF_DEBUG)) - dwarfout_define (lineno, get_directive_line (finput)); -#endif /* DWARF_DEBUGGING_INFO */ - goto skipline; - } - } - else if (c == 'u') - { - if (getlc (finput) == 'n' - && getlc (finput) == 'd' - && getlc (finput) == 'e' - && getlc (finput) == 'f' - && (c = getlc (finput), ISSPACE (c))) - { -#if 0 /*def DWARF_DEBUGGING_INFO*/ - if (c != '\n' - && (debug_info_level == DINFO_LEVEL_VERBOSE) - && (write_symbols == DWARF_DEBUG)) - dwarfout_undef (lineno, get_directive_line (finput)); -#endif /* DWARF_DEBUGGING_INFO */ - goto skipline; - } - } - else if (c == 'l') - { - if (getlc (finput) == 'i' - && getlc (finput) == 'n' - && getlc (finput) == 'e' - && ((c = getlc (finput)) == ' ' || c == '\t')) - goto linenum; - } -#if 0 - else if (c == 'i') - { - if (getlc (finput) == 'd' - && getlc (finput) == 'e' - && getlc (finput) == 'n' - && getlc (finput) == 't' - && ((c = getlc (finput)) == ' ' || c == '\t')) - { - /* #ident. The pedantic warning is now in cpp. */ - - /* Here we have just seen `#ident '. - A string constant should follow. */ - - while (c == ' ' || c == '\t') - c = getlc (finput); - - /* If no argument, ignore the line. */ - if (c == '\n') - return c; - - ungetc (c, finput); - token = yylex (); - if (token != STRING - || TREE_CODE (yylval.ttype) != STRING_CST) - { - error ("invalid #ident"); - goto skipline; - } - - if (!flag_no_ident) - { -#ifdef ASM_OUTPUT_IDENT - extern FILE *asm_out_file; - ASM_OUTPUT_IDENT (asm_out_file, TREE_STRING_POINTER (yylval.ttype)); -#endif - } - - /* Skip the rest of this line. */ - goto skipline; - } - } -#endif - - error ("undefined or invalid # directive"); - goto skipline; - } - -linenum: - /* Here we have either `#line' or `# <nonletter>'. - In either case, it should be a line number; a digit should follow. */ - - while (c == ' ' || c == '\t') - c = getlc (finput); - - /* If the # is the only nonwhite char on the line, - just ignore it. Check the new newline. */ - if (c == '\n') - return c; - - /* Something follows the #; read a token. */ - - if (ISDIGIT(c)) - { - int old_lineno = lineno; - int used_up = 0; - int l = 0; - extern struct obstack permanent_obstack; - - do - { - l = l * 10 + (c - '0'); /* FIXME Not portable */ - c = getlc(finput); - } while (ISDIGIT(c)); - /* subtract one, because it is the following line that - gets the specified number */ - - l--; - - /* Is this the last nonwhite stuff on the line? */ - c = getlc (finput); - while (c == ' ' || c == '\t') - c = getlc (finput); - if (c == '\n') - { - /* No more: store the line number and check following line. */ - lineno = l; - return c; - } - - /* More follows: it must be a string constant (filename). */ - - /* Read the string constant, but don't treat \ as special. */ - ignore_escape_flag = 1; - ignore_escape_flag = 0; - - if (c != '\"') - { - error ("invalid #line"); - goto skipline; - } - - for (;;) - { - c = getc (finput); - if (c == EOF || c == '\n') - { - error ("invalid #line"); - return c; - } - if (c == '\"') - { - obstack_1grow(&permanent_obstack, 0); - input_filename = obstack_finish (&permanent_obstack); - break; - } - obstack_1grow(&permanent_obstack, c); - } - - lineno = l; - - /* Each change of file name - reinitializes whether we are now in a system header. */ - in_system_header = 0; - - if (main_input_filename == 0) - main_input_filename = input_filename; - - /* Is this the last nonwhite stuff on the line? */ - c = getlc (finput); - while (c == ' ' || c == '\t') - c = getlc (finput); - if (c == '\n') - return c; - - used_up = 0; - - /* `1' after file name means entering new file. - `2' after file name means just left a file. */ - - if (ISDIGIT (c)) - { - if (c == '1') - { - /* Pushing to a new file. */ - struct file_stack *p - = (struct file_stack *) xmalloc (sizeof (struct file_stack)); - input_file_stack->line = old_lineno; - p->next = input_file_stack; - p->name = input_filename; - input_file_stack = p; - input_file_stack_tick++; -#ifdef DWARF_DEBUGGING_INFO - if (debug_info_level == DINFO_LEVEL_VERBOSE - && write_symbols == DWARF_DEBUG) - dwarfout_start_new_source_file (input_filename); -#endif /* DWARF_DEBUGGING_INFO */ - - used_up = 1; - } - else if (c == '2') - { - /* Popping out of a file. */ - if (input_file_stack->next) - { - struct file_stack *p = input_file_stack; - input_file_stack = p->next; - free (p); - input_file_stack_tick++; -#ifdef DWARF_DEBUGGING_INFO - if (debug_info_level == DINFO_LEVEL_VERBOSE - && write_symbols == DWARF_DEBUG) - dwarfout_resume_previous_source_file (input_file_stack->line); -#endif /* DWARF_DEBUGGING_INFO */ - } - else - error ("#-lines for entering and leaving files don't match"); - - used_up = 1; - } - } - - /* If we have handled a `1' or a `2', - see if there is another number to read. */ - if (used_up) - { - /* Is this the last nonwhite stuff on the line? */ - c = getlc (finput); - while (c == ' ' || c == '\t') - c = getlc (finput); - if (c == '\n') - return c; - used_up = 0; - } - - /* `3' after file name means this is a system header file. */ - - if (c == '3') - in_system_header = 1; - } - else - error ("invalid #-line"); - - /* skip the rest of this line. */ - skipline: - while (c != '\n' && c != EOF) - c = getc (finput); - return c; -} - - -tree -get_chill_filename () -{ - return (build_chill_string ( - strlen (input_filename) + 1, /* +1 to get a zero terminated string */ - input_filename)); -} - -tree -get_chill_linenumber () -{ - return build_int_2 ((HOST_WIDE_INT)lineno, 0); -} - - -/* Assuming '/' and '*' have been read, skip until we've - read the terminating '*' and '/'. */ - -static void -skip_c_comment () -{ - int c = input(); - int start_line = lineno; - - inside_c_comment++; - for (;;) - if (c == EOF) - { - error_with_file_and_line (input_filename, start_line, - "unterminated comment"); - break; - } - else if (c != '*') - c = input(); - else if ((c = input ()) == '/') - break; - inside_c_comment--; -} - - -/* Assuming "--" has been read, skip until '\n'. */ - -static void -skip_line_comment () -{ - for (;;) - { - int c = input (); - - if (c == EOF) - return; - if (c == '\n') - break; - } - unput ('\n'); -} - - -static int -skip_whitespace () -{ - for (;;) - { - int c = input (); - - if (c == EOF) - return c; - if (c == ' ' || c == '\t' || c == '\r' || c == '\n' || c == '\v') - continue; - if (c == '/') - { - c = input (); - if (c == '*') - { - skip_c_comment (); - continue; - } - else - { - unput (c); - return '/'; - } - } - if (c == '-') - { - c = input (); - if (c == '-') - { - skip_line_comment (); - continue; - } - else - { - unput (c); - return '-'; - } - } - return c; - } -} - -/* - * avoid recursive calls to yylex to parse the ' = digits' or - * ' = SYNvalue' which are supposed to follow certain compiler - * directives. Read the input stream, and return the value parsed. - */ - /* FIXME: overflow check in here */ - /* FIXME: check for EOF around here */ -static tree -equal_number () -{ - int c, result; - char *tokenbuf; - char *cursor; - tree retval = integer_zero_node; - - c = skip_whitespace(); - if ((char)c != '=') - { - if (pass == 2) - error ("missing `=' in compiler directive"); - return integer_zero_node; - } - c = skip_whitespace(); - - /* collect token into tokenbuf for later analysis */ - while (TRUE) - { - if (ISSPACE (c) || c == '<') - break; - obstack_1grow (&temporary_obstack, c); - c = input (); - } - unput (c); /* put uninteresting char back */ - obstack_1grow (&temporary_obstack, '\0'); /* terminate token */ - tokenbuf = obstack_finish (&temporary_obstack); - maybe_downcase (tokenbuf); - - if (*tokenbuf == '-') - /* will fail in the next test */ - result = BITSTRING; - else if (maybe_number (tokenbuf)) - { - if (pass == 1) - return integer_zero_node; - push_obstacks_nochange (); - end_temporary_allocation (); - yylval.ttype = convert_integer (tokenbuf); - tokenbuf = 0; /* Was freed by convert_integer. */ - result = yylval.ttype ? NUMBER : 0; - pop_obstacks (); - } - else - result = 0; - - if (result == NUMBER) - { - retval = yylval.ttype; - } - else if (result == BITSTRING) - { - if (pass == 1) - error ("invalid value follows `=' in compiler directive"); - goto finish; - } - else /* not a number */ - { - cursor = tokenbuf; - c = *cursor; - if (!ISALPHA (c) && c != '_') - { - if (pass == 1) - error ("invalid value follows `=' in compiler directive"); - goto finish; - } - - for (cursor = &tokenbuf[1]; *cursor != '\0'; cursor++) - if (ISALPHA ((unsigned char) *cursor) || *cursor == '_' || - ISDIGIT (*cursor)) - continue; - else - { - if (pass == 1) - error ("invalid `%c' character in name", *cursor); - goto finish; - } - if (pass == 1) - goto finish; - else - { - tree value = lookup_name (get_identifier (tokenbuf)); - if (value == NULL_TREE - || TREE_CODE (value) != CONST_DECL - || TREE_CODE (DECL_INITIAL (value)) != INTEGER_CST) - { - if (pass == 2) - error ("`%s' not integer constant synonym ", - tokenbuf); - goto finish; - } - obstack_free (&temporary_obstack, tokenbuf); - tokenbuf = 0; - push_obstacks_nochange (); - end_temporary_allocation (); - retval = convert (chill_taskingcode_type_node, DECL_INITIAL (value)); - pop_obstacks (); - } - } - - /* check the value */ - if (TREE_CODE (retval) != INTEGER_CST) - { - if (pass == 2) - error ("invalid value follows `=' in compiler directive"); - } - else if (TREE_INT_CST_HIGH (retval) != 0 || - TREE_INT_CST_LOW (retval) > TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_unsigned_type_node))) - { - if (pass == 2) - error ("value out of range in compiler directive"); - } - finish: - if (tokenbuf) - obstack_free (&temporary_obstack, tokenbuf); - return retval; -} - -/* - * add a possible grant-file path to the list - */ -void -register_seize_path (path) - const char *path; -{ - int pathlen = strlen (path); - char *new_path = (char *)xmalloc (pathlen + 1); - STRING_LIST *pl = (STRING_LIST *)xmalloc (sizeof (STRING_LIST)); - - /* strip off trailing slash if any */ - if (path[pathlen - 1] == '/') - pathlen--; - - memcpy (new_path, path, pathlen); - pl->str = new_path; - pl->next = seize_path_list; - seize_path_list = pl; -} - - -/* Used by decode_decl to indicate that a <> use_seize_file NAME <> - directive has been written to the grantfile. */ - -void -mark_use_seizefile_written (name) - tree name; -{ - tree node; - - for (node = files_to_seize; node != NULL_TREE; node = TREE_CHAIN (node)) - if (TREE_VALUE (node) == name) - { - TREE_PURPOSE (node) = integer_one_node; - break; - } -} - - -static int -yywrap () -{ - extern char *chill_real_input_filename; - - close_input_file (input_filename); - - use_seizefile_name = NULL_TREE; - - if (next_file_to_seize && !grant_only_flag) - { - FILE *grt_in = NULL; - const char *seizefile_name_chars - = IDENTIFIER_POINTER (TREE_VALUE (next_file_to_seize)); - - /* find a seize file, open it. If it's not at the path the - * user gave us, and that path contains no slashes, look on - * the seize_file paths, specified by the '-I' options. - */ - grt_in = fopen (seizefile_name_chars, "r"); - if (grt_in == NULL - && strchr (seizefile_name_chars, '/') == NULL) - { - STRING_LIST *plp; - char *path; - - for (plp = seize_path_list; plp != NULL; plp = plp->next) - { - path = (char *)xmalloc (strlen (seizefile_name_chars) - + strlen (plp->str) + 2); - - sprintf (path, "%s/%s", plp->str, seizefile_name_chars); - grt_in = fopen (path, "r"); - if (grt_in == NULL) - free (path); - else - { - seizefile_name_chars = path; - break; - } - } - } - - if (grt_in == NULL) - fatal_io_error ("can't open %s", seizefile_name_chars); - - finput = grt_in; - input_filename = seizefile_name_chars; - - lineno = 0; - current_seizefile_name = TREE_VALUE (next_file_to_seize); - - next_file_to_seize = TREE_CHAIN (next_file_to_seize); - - saw_eof = 0; - return 0; - } - - if (pass == 1) - { - next_file_to_seize = files_to_seize; - current_seizefile_name = NULL_TREE; - - if (strcmp (main_input_filename, "stdin")) - finput = fopen (chill_real_input_filename, "r"); - else - finput = stdin; - if (finput == NULL) - { - error ("can't reopen %s", chill_real_input_filename); - return 1; - } - input_filename = main_input_filename; - ch_lex_init (); - lineno = 0; - /* Read a line directive if there is one. */ - ungetc (check_newline (), finput); - starting_pass_2 = 1; - saw_eof = 0; - if (module_number == 0) - warning ("no modules seen"); - return 0; - } - return 1; -} diff --git a/gcc/ch/lex.h b/gcc/ch/lex.h deleted file mode 100644 index 4bf748c7da6..00000000000 --- a/gcc/ch/lex.h +++ /dev/null @@ -1,98 +0,0 @@ -/* Define constants for communication with the CHILL parser. - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1999, 2000 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - - -enum rid -{ - RID_UNUSED, /* keep this one first, please */ - RID_ALL, - RID_ASSERTFAIL, - RID_ASSOCIATION, - RID_BIN, - RID_BIT, - RID_BOOL, - RID_BOOLS, - RID_BYTE, - RID_CHAR, - RID_CHARS, - RID_DOUBLE, - RID_DURATION, - RID_DYNAMIC, - RID_ELSE, - RID_EMPTY, - RID_FALSE, - RID_FLOAT, - RID_GENERAL, - RID_IN, - RID_INLINE, - RID_INOUT, - RID_INSTANCE, - RID_INT, - RID_LOC, - RID_LONG, - RID_LONG_REAL, - RID_NULL, - RID_OUT, - RID_OVERFLOW, - RID_PTR, - RID_RANGE, - RID_RANGEFAIL, - RID_READ, - RID_REAL, - RID_RECURSIVE, - RID_SHORT, - RID_SIMPLE, - RID_TIME, - RID_TRUE, - RID_UBYTE, - RID_UINT, - RID_ULONG, - RID_UNSIGNED, - RID_USHORT, - RID_VOID, - RID_MAX /* Last element */ -}; - -#define NORID RID_UNUSED - -#define RID_FIRST_MODIFIER RID_UNSIGNED - -/* The elements of `ridpointers' are identifier nodes - for the reserved type names and storage classes. - It is indexed by a RID_... value. */ -extern tree ridpointers[(int) RID_MAX]; - -extern char *token_buffer; /* Pointer to token buffer. */ - -extern tree make_pointer_declarator PARAMS ((tree, tree)); -extern void reinit_parse_for_function PARAMS ((void)); -extern int yylex PARAMS ((void)); - -extern tree default_grant_file; -extern tree current_grant_file; - -extern tree current_seize_file; - -extern int chill_at_module_level; -extern tree chill_initializer_name; - -extern void prepare_paren_colon PARAMS ((void)); diff --git a/gcc/ch/loop.c b/gcc/ch/loop.c deleted file mode 100644 index d42c65f8077..00000000000 --- a/gcc/ch/loop.c +++ /dev/null @@ -1,1234 +0,0 @@ -/* Implement looping actions for CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "lex.h" -#include "flags.h" -#include "actions.h" -#include "input.h" -#include "obstack.h" -#include "assert.h" -#include "rtl.h" -#include "toplev.h" - -/* if the user codes '-flocal-loop-counter' on the command line, - ch-actions.c (lang_decode_option) will set this flag. */ -int flag_local_loop_counter = 1; - -/* forward declarations */ -static int declare_temps PARAMS ((void)); -static int initialize_iter_var PARAMS ((void)); -static void maybe_skip_loop PARAMS ((void)); -static int bottom_loop_end_check PARAMS ((void)); -static int increment_temps PARAMS ((void)); -static tree build_temporary_variable PARAMS ((const char *, tree)); -static tree maybe_make_for_temp PARAMS ((tree, const char *, tree)); -#if 0 -static tree chill_unsigned_type PARAMS ((tree)); -#endif - -/* In terms of the parameters passed to build_loop_iterator, - * there are several types of loops. They are encoded by - * the ITER_TYPE enumeration. - * - * 1) DO FOR EVER; ... OD - * indicated by a NULL_TREE start_exp, step_exp and end_exp, - * condition == NULL, in_flag = 0, and ever_flag == 1 in the - * first ITERATOR. - * - * 2) DO WHILE cond; ... OD - * indicated by NULL_TREE start_exp, step_exp and end_exp, - * in_flag = 0, and condition != NULL. - * - * 3) DO; ... OD - * indicated by NULL_TREEs in start_exp, step_exp and end_exp, - * condition != NULL, in_flag == 0 and ever_flag == 0. This - * is not really a loop, but a compound statement. - * - * 4) DO FOR user_var := start_exp - * [DOWN] TO end_exp BY step_exp; ... DO - * indicated by non-NULL_TREE start_exp, step_exp and end_exp. - * - * 5) DO FOR user_var [DOWN] IN discrete_mode; ... OD - * indicated by in_flag == 1. start_exp is a non-NULL_TREE - * discrete mode, with an optional down_flag. - * - * 6) DO FOR user_var [DOWN] IN powerset_expr; ... OD - * indicated by in_flag == 1. start_exp is a non-NULL_TREE - * powerset mode, with an optional down_flag. - * - * 7) DO FOR user_var [DOWN] IN location; ... OD - * indicated by in_flag == 1. start_exp is a non-NULL_TREE - * location mode, with an optional down_flag. - */ -typedef enum -{ - DO_FOREVER, - DO_OD, - DO_STEP, - DO_POWERSET, - DO_LOC, - DO_LOC_VARYING -} ITER_TYPE; - - -typedef struct iterator -{ -/* These variables only have meaning in the first ITERATOR structure. */ - ITER_TYPE itype; /* type of this iterator */ - int error_flag; /* TRUE if no loop was started due to - user error */ - int down_flag; /* TRUE if DOWN was coded */ - -/* These variables have meaning in every ITERATOR structure. */ - tree user_var; /* user's explicit iteration variable */ - tree start_exp; /* user's start expression - or IN expression of a FOR .. IN*/ - tree step_exp; /* user's step expression */ - tree end_exp; /* user's end expression */ - tree start_temp; /* temp holding evaluated start_exp */ - tree end_temp; /* temp holding evaluated end_exp */ - tree step_temp; /* temp holding evaluated step_exp */ - tree powerset_temp; /* temp holding user's initial powerset expression */ - tree loc_ptr_temp; /* temp holding count for LOC enumeration ptr */ - tree iter_var; /* hidden variable for the loop */ - tree iter_type; /* hidden variable's type */ - tree stepin_type; /* saved type for a DO FOR IN loop */ - tree base_type; /* LOC enumeration base type */ - struct iterator *next; /* ptr to next iterator for this loop */ -} ITERATOR; - -/* - * There's an entry like this for each nested DO loop. - * The list is maintained by push_loop_block - * and pop_loop_block. - */ -typedef struct loop { - struct loop *nxt_level; /* pointer to enclosing loop */ - ITERATOR *iter_list; /* iterators for the current loop */ -} LOOP; - -static LOOP *loopstack = (LOOP *)0; - -#if 0 - -Here is a CHILL DO FOR statement: - -DO FOR user_var := start_exp BY step_exp [DOWN] TO end_exp - WHILE condition; - -For this loop to be 'safe', like a Pascal FOR loop, the start, -end, and increment expressions are computed once, before the -assignment to the iteration variable and saved in temporaries, -before the first assignment of the iteration variable, so the -following works: - - FOR i := (i+1) TO (i+10) DO - -To prevent changes to the start/end/step expressions from -effecting the loop''s termination, and to make the loop end-check -as simple as possible, we evaluate the step expression into -a temporary and compute a hidden iteration count before entering -the loop''s body. User code cannot effect the counter, and the -end-loop check simply decrements the counter and checks for zero. - -The whole phrase FOR iter := ... TO end_exp can be repeated -multiple times, with different user-iteration variables. This -is discussed later. - -The loop counter calculations need careful design since a loop -from MININT TO MAXINT must work, in the precision of integers. - -Here''s how it works, in C: - - 0) The DO ... OD loop is simply a block with - its own scope. - - 1) The DO FOR EVER is simply implemented: - - loop_top: - . - . body of loop - . - goto loop_top - end_loop: - - 2) The DO WHILE is also simple: - - - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - goto loop_top - end_loop: - - - 3) The DO FOR [while condition] loop (no DOWN) - - push a new scope, - decl iter_var - - step_temp = step_exp - start_temp = start_exp - end_temp = end_exp - if (end_exp < start_exp) goto end_loop - /* following line is all unsigned arithmetic */ - iter_var = (end_exp - start_exp) / step_exp - user_var = start_temp - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - if (iter_var == 0) goto end_loop - iter_var-- - user_var += step_temp - goto loop_top - end_loop: - pop scope - - 4) The for [while condition] loop (with DOWN) - - push a new scope, - decl iter - step_temp = step_exp - start_temp = start_exp - end_temp = end_exp - if (end_exp > start_exp) goto end_loop - /* following line is all unsigned arithmetic */ - iter_var = (start_exp - end_exp) / step_exp - user_var = start_temp - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - if (iter_var == 0) goto end_loop - iter_var-- - user_var -= step_temp - goto loop_top - end_loop: - pop scope - - - 5) The range loop, which iterates over a mode''s possible - values, works just like the above step loops, but with - the start and end values taken from the mode''s lower - and upper domain values. - - - 6) The FOR IN loop, where a location enumeration is - specified (see spec on page 81 of Z.200, bottom - of page 186): - - push a new scope, - decl iter_var as an unsigned integer - loc_ptr_temp as pointer to a composite base type - - if array is varying - iter_var = array''s length field - else - iter_var = sizeof array / sizeof base_type - loc_ptr_temp = &of highest or lowest indexable entry - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - iter_var-- - if (iter_var == 0) goto end_loop - loc_ptr_temp +/-= sizeof array base_type - goto loop_top - end_loop: - pop scope - - 7) The DO FOR (DOWN) IN powerset_exp - - push a new scope, - decl iterator as basetype of powerset - - powerset_temp := save_expr (start_exp) - iter_var := DOWN ? length : 0 - loop_top: - if (DOWN) - iter_var := __ffsetclrpowerset (powerset_temp, length, - iter_var); - else - iter_var := __ffsetclrpowerset (powrset_temp, iter_var, 0); - if (iter_var < 0) goto end_loop; - user_var = iter_var + min_value; - if (!condition) goto end_loop - if (!DOWN) iter_var +:= 1; - . - . body of loop - . - goto loop_top - end_loop: - pop scope - - -So, here''s the general DO FOR schema, as implemented here: - - expand_start_loop -- start the loop''s control scope - -- start scope for synthesized loop variables - declare_temps -- create, initialize temporary variables - maybe_skip_loop -- skip loop if end conditions unsatisfiable - initialize_iter_var -- initialize the iteration counter - -- initialize user''s loop variable - expand_start_loop -- generate top-of-loop label - top_loop_end_check -- generate while code and/or - powerset find-a-bit function call - . - . - . user''s loop body code - . - . - bottom_loop_end_check -- exit if counter has become zero - increment_temps -- update temps for next iteration - expand_end_loop -- generate jump back to top of loop - expand_end_cond -- generate label for end of conditional - -- end of scope for synthesized loop variables - free_iterators -- free up iterator space - -When there are two or more iterator phrases, each of the -above loop steps must act upon all iterators. For example, -the 'increment_temps' step must increment all temporaries -(associated with all iterators). - - NOTE: Z.200, section 10.1 says that a block is ... - "the actions statement list in a do action, including any - loop counter and while control". This means that an exp- - ression in a WHILE control can include references to the - loop counters created for the loop''s exclusive use. - Example: - - DCL a (1:10) INT; - DCL j INT; - DO FOR j IN a WHILE j > 0; - ... - OD; - The 'j' referenced in the while is the loc-identity 'j' - created inside the loop''s scope, and NOT the 'j' declared - before the loop. -#endif - -/* - * The following routines are called directly by the - * CHILL parser. - */ -void -push_loop_block () -{ - LOOP *temp = (LOOP *)xmalloc (sizeof (LOOP)); - - /* push a new loop onto the stack */ - temp->nxt_level = loopstack; - temp->iter_list = (ITERATOR *)0; - loopstack = temp; -} - -void -pop_loop_block () -{ - LOOP *do_temp = loopstack; - ITERATOR *ip; - - /* pop loop block off the list */ - loopstack = do_temp->nxt_level; - - /* free the loop's iterator blocks */ - ip = do_temp->iter_list; - while (ip != NULL) - { - ITERATOR *temp = ip->next; - free (ip); - ip = temp; - } - free (do_temp); -} - -void -begin_loop_scope () -{ - pushlevel (1); - - if (pass >= 2) - { - declare_temps (); - - clear_last_expr (); - push_momentary (); - expand_start_bindings (0); - } - - push_handler (); - -} - - -void -end_loop_scope (opt_label) - tree opt_label; -{ - if (opt_label) - possibly_define_exit_label (opt_label); - - if (pass == 2) - { - expand_end_bindings (getdecls (), kept_level_p (), 0); - pop_momentary (); - } - poplevel (kept_level_p (), 1, 0); -} - - -/* we need the above 2 functions somehow modified for initialising - of non-value arrays */ - -void -nonvalue_begin_loop_scope () -{ - pushlevel (0); /* this happens only in pass 2 */ - - declare_temps (); - - clear_last_expr (); - push_momentary (); - expand_start_bindings (0); -} - -void -nonvalue_end_loop_scope () -{ - expand_end_bindings (getdecls (), kept_level_p (), 0); - pop_momentary (); - poplevel (kept_level_p (), 1, 0); -} - -/* The iterator structure records all aspects of a - * 'FOR i := start [DOWN] TO end' clause or - * 'FOR i IN modename' or 'FOR i IN powerset' clause. - * It's saved on the iter_list of the current LOOP. - */ -void -build_loop_iterator (user_var, start_exp, step_exp, end_exp, - down_flag, in_flag, ever_flag) - tree user_var, start_exp, step_exp, end_exp; - int down_flag, in_flag, ever_flag; -{ - ITERATOR *ip = (ITERATOR *)xmalloc (sizeof (ITERATOR)); - - /* chain this iterator onto the current loop */ - if (loopstack->iter_list == NULL) - loopstack->iter_list = ip; - else - { - ITERATOR *temp = loopstack->iter_list; - while (temp->next != NULL) - temp = temp->next; - temp->next = ip; - } - - ip->user_var = user_var; - ip->start_exp = start_exp; - ip->step_exp = step_exp; - ip->end_exp = end_exp; - ip->start_temp = NULL_TREE; - ip->end_temp = NULL_TREE; - ip->step_temp = NULL_TREE; - ip->down_flag = down_flag; - ip->powerset_temp = NULL_TREE; - ip->iter_var = NULL_TREE; - ip->iter_type = NULL_TREE; - ip->stepin_type = NULL_TREE; - ip->loc_ptr_temp = NULL_TREE; - ip->error_flag = 1; /* assume error will be found */ - ip->next = (ITERATOR *)0; - - if (ever_flag) - ip->itype = DO_FOREVER; - else if (in_flag && start_exp != NULL_TREE) - { - if (TREE_CODE (start_exp) == ERROR_MARK) - return; - if (TREE_TYPE (start_exp) == NULL_TREE) - { - if (TREE_CODE (start_exp) == CONSTRUCTOR) - error ("modeless tuple not allowed in this context"); - else - error ("IN expression does not have a mode"); - return; - } - if (TREE_CODE (TREE_TYPE (start_exp)) == SET_TYPE) - { - if (CH_BOOLS_TYPE_P (TREE_TYPE (start_exp))) - { - sorry ("location enumeration for BOOLS"); - return; - } - ip->itype = DO_POWERSET; - } - else if (discrete_type_p (TREE_TYPE (ip->start_exp))) - { - /* range enumeration */ - tree type = TREE_TYPE (ip->start_exp); - /* save the original type for later use in determine to do a - rangecheck or not */ - ip->stepin_type = type; - ip->itype = DO_STEP; - if (ip->down_flag) - { - ip->start_exp = build_chill_upper (type); - ip->end_exp = build_chill_lower (type); - } - else - { - ip->start_exp = build_chill_lower (type); - ip->end_exp = build_chill_upper (type); - } - } - else if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ARRAY_TYPE) - { - if (TYPE_PACKED (TREE_TYPE (ip->start_exp))) - { - sorry ("location enumeration for bit-packed arrays"); - return; - } - ip->itype = DO_LOC; - } - else if (chill_varying_type_p (TREE_TYPE (ip->start_exp))) - ip->itype = DO_LOC_VARYING; - else - { - error ("Loop's IN expression is not a composite object"); - return; - } - } - else - ip->itype = DO_STEP; - if (ip->itype == DO_STEP) - { - struct ch_class class; - - if (ip->step_exp == NULL_TREE) - ip->step_exp = integer_one_node; - - if (! discrete_type_p (TREE_TYPE (ip->start_exp))) - { - error ("start expr must have discrete mode"); - return; - } - if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ENUMERAL_TYPE - && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->start_exp))) - { - error ("DO FOR start expression is a numbered SET"); - return; - } - if (TREE_CODE (ip->end_exp) == ERROR_MARK) - return; - if (TREE_CODE (TREE_TYPE (ip->end_exp)) == ENUMERAL_TYPE - && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->end_exp))) - { - error ("TO expression is a numbered SET"); - return; - } - if (! discrete_type_p (TREE_TYPE (ip->end_exp))) - { - error ("TO expr must have discrete mode"); - return; - } - if (! CH_COMPATIBLE_CLASSES (ip->start_exp, ip->end_exp)) - { - error ("start expr and TO expr must be compatible"); - return; - } - if (step_exp != NULL_TREE) - { - if (TREE_CODE (step_exp) == ERROR_MARK) - return; - if (! discrete_type_p (TREE_TYPE (step_exp))) - { - error ("BY expr must have discrete mode"); - return; - } - if (! CH_COMPATIBLE_CLASSES (ip->start_exp, step_exp)) - { - error ("start expr and BY expr must be compatible"); - return; - } - } - - if (! flag_local_loop_counter) - { - /* In this case, it's a previously-declared VAR_DECL node. */ - tree id_node = ip->user_var; - if (TREE_CODE (ip->user_var) == IDENTIFIER_NODE) - ip->user_var = lookup_name (ip->user_var); - - /* Chill 1984 allows the name to be a defining occurrence, - but does not require it. */ - if (ip->user_var == NULL_TREE) - { - warning ("loop identifier undeclared"); - ip->user_var = id_node; - /* We declare a local name below. */ - } - else - { - if (TREE_CODE (TREE_TYPE (ip->user_var)) == REFERENCE_TYPE) - ip->user_var = convert_from_reference (ip->user_var); - - if (! CH_COMPATIBLE_CLASSES (ip->start_exp, ip->user_var)) - { - error ("loop variable incompatible with start expression"); - return; - } - class = chill_expr_class (ip->user_var); - } - } - /* Otherwise, declare a new name. */ - if (TREE_CODE (ip->user_var) == IDENTIFIER_NODE) - { - class = CH_RESULTING_CLASS (chill_expr_class (ip->start_exp), - chill_expr_class (ip->end_exp)); - if (step_exp) - class = CH_RESULTING_CLASS (class, chill_expr_class (step_exp)); - - /* Integer literals noramally have type 'long long' - (see convert_integer in lex.c). That is usually overkill. */ - if (class.kind == CH_DERIVED_CLASS - && class.mode == long_long_integer_type_node - && int_fits_type_p (ip->start_exp, integer_type_node) - && int_fits_type_p (ip->end_exp, integer_type_node)) - class.mode = integer_type_node; - } - - if (TREE_CODE (ip->start_exp) == INTEGER_CST - && TREE_CODE (ip->end_exp) == INTEGER_CST - && compare_int_csts (ip->down_flag ? LT_EXPR : GT_EXPR, - ip->start_exp, ip->end_exp)) - warning ("body of DO FOR will never execute"); - - ip->start_exp = convert_to_class (class, ip->start_exp); - ip->end_exp = convert_to_class (class, ip->end_exp); - ip->step_exp = convert_to_class (class, ip->step_exp); - - if (TREE_CODE (ip->step_exp) != INTEGER_CST) - { - /* generate runtime check for negative BY expr */ - ip->step_exp = - check_range (ip->step_exp, ip->step_exp, - integer_zero_node, NULL_TREE); - } - else if (compare_int_csts (LE_EXPR, ip->step_exp, integer_zero_node)) - { - error ("BY expression is negative or zero"); - return; - } - } - - ip->error_flag = 0; /* no errors! */ -} - -void -build_loop_start (start_label) - tree start_label; -{ - ITERATOR *firstp = loopstack->iter_list; - - if (firstp->error_flag) - return; - - maybe_skip_loop (); - - if (initialize_iter_var ()) - return; - - /* use the label as an 'exit' label, - 'goto' needs another sort of label */ - expand_start_loop (start_label != NULL_TREE); -} - -/* - * Called after the last action of the loop body - * has been parsed. - */ -void -build_loop_end () -{ - ITERATOR *ip = loopstack->iter_list; - - emit_line_note (input_filename, lineno); - - if (ip->error_flag) - return; - - if (bottom_loop_end_check ()) - return; - - if (increment_temps ()) - return; - - expand_end_loop (); - - for (; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_LOC_VARYING: - case DO_STEP: - expand_end_cond (); - break; - default: - break; - } - } -} - -/* - * Reserve space for any loop-control temporaries, initialize them - */ -static int -declare_temps () -{ - ITERATOR *firstp = loopstack->iter_list, *ip; - tree start_ptr; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - break; - case DO_STEP: - ip->iter_type - = type_for_size (TYPE_PRECISION (TREE_TYPE (ip->start_exp)), 1); - - /* create, initialize temporaries if expressions aren't constant */ - ip->start_temp = maybe_make_for_temp (ip->start_exp, "for_start", - TREE_TYPE (ip->start_exp)); - ip->end_temp = maybe_make_for_temp (ip->end_exp, "for_end", - TREE_TYPE (ip->end_exp)); - /* this is just the step-expression */ - ip->step_temp = maybe_make_for_temp (ip->step_exp, "for_step", - TREE_TYPE (ip->step_exp)); - if (TREE_CODE (ip->user_var) == IDENTIFIER_NODE) - { - /* (re-)declare the user's iteration variable in the - loop's scope. */ - tree id_node = ip->user_var; - ip->user_var = - decl_temp1 (id_node, TREE_TYPE (ip->start_exp), 0, NULL_TREE, - 0, 0); - CH_DERIVED_FLAG (ip->user_var) = CH_DERIVED_FLAG (ip->start_exp); - pushdecl (ip->user_var); - } - ip->iter_var = - decl_temp1 (get_unique_identifier ("iter_var"), - ip->iter_type, 0, NULL_TREE, 0, 0); - break; - - case DO_POWERSET: - /* the user's powerset-expression */ - ip->powerset_temp = save_expr (ip->start_exp); - mark_addressable (ip->powerset_temp); - - ip->iter_type = integer_type_node; - ip->iter_var = decl_temp1 (get_unique_identifier ("iter_var"), - ip->iter_type, 0, - !ip->down_flag ? integer_zero_node - : powersetlen (ip->powerset_temp), - 0, 0); - - if (flag_local_loop_counter) - { - /* declare the user's iteration variable in the loop's scope. */ - /* in this case, it's just an IDENTIFIER_NODE */ - ip->user_var = - decl_temp1 (ip->user_var, - TYPE_DOMAIN (TREE_TYPE (ip->start_exp)), - 0, NULL_TREE, 0, 0); - pushdecl (ip->user_var); - } - else - { - /* in this case, it's a previously-declared VAR_DECL node */ - ip->user_var = lookup_name (ip->user_var); - } - break; - - case DO_LOC: - case DO_LOC_VARYING: - ip->iter_type = chill_unsigned_type_node; - /* create the counter temp */ - ip->iter_var = - build_temporary_variable ("iter_var", ip->iter_type); - - if (!CH_LOCATION_P (ip->start_exp)) - ip->start_exp - = decl_temp1 (get_unique_identifier ("iter_loc"), - TREE_TYPE (ip->start_exp), 0, - ip->start_exp, 0, 0); - - if (ip->itype == DO_LOC) - { - tree array_type = TREE_TYPE (ip->start_exp); - tree ptr_type; - tree temp; - - /* FIXME: check for array type in ip->start_exp */ - - /* create pointer temporary */ - ip->base_type = TREE_TYPE (array_type); - ptr_type = build_pointer_type (ip->base_type); - ip->loc_ptr_temp = - build_temporary_variable ("loc_ptr_tmp", ptr_type); - - /* declare the user's iteration variable in - the loop's scope, as an expression, to be - passed to build_component_ref later */ - save_expr_under_name (ip->user_var, - build1 (INDIRECT_REF, ip->base_type, - ip->loc_ptr_temp)); - - /* FIXME: see stor_layout */ - ip->step_temp = size_in_bytes (ip->base_type); - - temp = TYPE_DOMAIN (array_type); - - /* pointer to first array entry to look at */ - start_ptr = build1 (ADDR_EXPR, ptr_type, ip->start_exp); - mark_addressable (ip->start_exp); - ip->start_temp = ip->down_flag ? - fold (build (PLUS_EXPR, ptr_type, - start_ptr, - fold (build (MULT_EXPR, integer_type_node, ip->step_temp, - fold (build (MINUS_EXPR, integer_type_node, - TYPE_MAX_VALUE (temp), - TYPE_MIN_VALUE (temp))))))) - : start_ptr; - } - else - { - tree array_length = - convert (integer_type_node, - build_component_ref (ip->start_exp, var_length_id)); - tree array_type = TREE_TYPE (TREE_CHAIN ( - TYPE_FIELDS (TREE_TYPE (ip->start_exp)))); - tree array_data_ptr = - build_component_ref (ip->start_exp, var_data_id); - tree ptr_type; - - if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE) - { - error ("Can't iterate through array of BOOL"); - firstp->error_flag = 1; - return firstp->error_flag; - } - - /* create pointer temporary */ - ip->base_type = TREE_TYPE (array_type); - ptr_type = build_pointer_type (ip->base_type); - ip->loc_ptr_temp = - build_temporary_variable ("loc_ptr_temp", ptr_type); - - - /* declare the user's iteration variable in - the loop's scope, as an expression, to be - passed to build_component_ref later */ - save_expr_under_name (ip->user_var, - build1 (INDIRECT_REF, ip->base_type, - ip->loc_ptr_temp)); - - /* FIXME: see stor_layout */ - ip->step_temp = size_in_bytes (ip->base_type); - - /* pointer to first array entry to look at */ - start_ptr = build1 (ADDR_EXPR, ptr_type, array_data_ptr); - mark_addressable (array_data_ptr); - ip->start_temp = ip->down_flag ? - fold (build (PLUS_EXPR, ptr_type, - start_ptr, - fold (build (MULT_EXPR, integer_type_node, ip->step_temp, - fold (build (MINUS_EXPR, integer_type_node, - array_length, - integer_one_node)))))) - : start_ptr; - } - default: - ; - } - } - return firstp->error_flag; -} - -/* - * Initialize the hidden iteration-control variables, - * and the user's explicit loop variable. - */ -static int -initialize_iter_var () -{ - ITERATOR *firstp = loopstack->iter_list, *ip; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - tree array_type, array_length; - case DO_FOREVER: - break; - case DO_STEP: - { - tree count; - count = build (MINUS_EXPR, ip->iter_type, - convert (ip->iter_type, - ip->down_flag ? ip->start_temp : ip->end_temp), - convert (ip->iter_type, - ip->down_flag ? ip->end_temp : ip->start_temp)); - count = fold (build (TRUNC_DIV_EXPR, ip->iter_type, - fold (count), - ip->step_temp)); - /* The count in this case is actually one less than the - number of iterations, to avoid overflow problems - if we iterate *all* the values of iter_type. */ - /* initialize the loop's hidden counter variable */ - expand_expr_stmt ( - build_chill_modify_expr (ip->iter_var, count)); - - /* initialize user's variable */ - expand_expr_stmt ( - build_chill_modify_expr (ip->user_var, ip->start_temp)); - } - break; - case DO_POWERSET: - break; - case DO_LOC: - array_type = TREE_TYPE (ip->start_exp); - array_length = fold (build (TRUNC_DIV_EXPR, integer_type_node, - size_in_bytes (array_type), - size_in_bytes (TREE_TYPE (array_type)))); - goto do_loc_common; - - case DO_LOC_VARYING: - array_length - = convert (integer_type_node, - build_component_ref (ip->start_exp, var_length_id)); - - do_loc_common: - expand_expr_stmt (build_chill_modify_expr (ip->iter_var, - array_length)); - expand_expr_stmt ( - build_chill_modify_expr (ip->loc_ptr_temp, - ip->start_temp)); - break; - - default: - ; - } - } - return firstp->error_flag; -} - -/* Generate code to skip the whole loop, if start expression not - * <= end expression (or >= for DOWN loops). This comparison must - * *NOT* be done in unsigned mode, or it will fail. - * Also, skip processing an empty VARYING array. - */ -static void -maybe_skip_loop () -{ - ITERATOR *firstp = loopstack->iter_list, *ip; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_STEP: - expand_start_cond ( - build_compare_discrete_expr (ip->down_flag ? GE_EXPR : LE_EXPR, - ip->start_temp, ip->end_temp), 0); - break; - - case DO_LOC_VARYING: - { tree array_length = - convert (integer_type_node, - build_component_ref (ip->start_exp, var_length_id)); - expand_start_cond ( - build (NE_EXPR, TREE_TYPE (array_length), - array_length, integer_zero_node), 0); - break; - } - default: - break; - } - } -} - -/* - * Check at the top of the loop for a termination - */ -void -top_loop_end_check (condition) - tree condition; -{ - ITERATOR *ip; - - for (ip = loopstack->iter_list; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_STEP: - break; - case DO_POWERSET: - { - tree temp1; - const char *func_name; - tree user_type = TREE_TYPE (ip->user_var); - - if (ip->down_flag) - func_name = "__flsetclrpowerset"; - else - func_name = "__ffsetclrpowerset"; - - temp1 = lookup_name (get_identifier (func_name)); - if (ip->down_flag) - temp1 = build_chill_function_call (temp1, - tree_cons (NULL_TREE, force_addr_of (ip->powerset_temp), - tree_cons (NULL_TREE, ip->iter_var, - tree_cons (NULL_TREE, integer_zero_node, NULL_TREE)))); - else - temp1 = build_chill_function_call (temp1, - tree_cons (NULL_TREE, force_addr_of (ip->powerset_temp), - tree_cons (NULL_TREE, powersetlen (ip->powerset_temp), - tree_cons (NULL_TREE, ip->iter_var, NULL_TREE)))); - expand_assignment (ip->iter_var, temp1, 0, 0); - expand_exit_loop_if_false (0, build (GE_EXPR, boolean_type_node, - ip->iter_var, - integer_zero_node)); - temp1 = TYPE_MIN_VALUE - (TYPE_DOMAIN (TREE_TYPE (ip->powerset_temp))); - expand_assignment (ip->user_var, - build (PLUS_EXPR, user_type, - convert (user_type, ip->iter_var), - convert (user_type, temp1)), - 0, 0); - } - break; - case DO_LOC: - case DO_LOC_VARYING: - break; - default: - ; - } - } - emit_line_note (input_filename, lineno); - - /* now, exit the loop if the condition isn't TRUE. */ - if (condition) - expand_exit_loop_if_false (0, truthvalue_conversion (condition)); -} - -/* - * Check generated temporaries for loop's end - */ -static int -bottom_loop_end_check () -{ - ITERATOR *firstp = loopstack->iter_list, *ip; - - emit_line_note (input_filename, lineno); - - /* now, generate code to check each loop counter for termination */ - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - break; - case DO_STEP: - /* exit if it's zero */ - expand_exit_loop_if_false (0, - build (NE_EXPR, boolean_type_node, - ip->iter_var, - integer_zero_node)); - /* decrement iteration counter by one */ - chill_expand_assignment (ip->iter_var, MINUS_EXPR, integer_one_node); - break; - case DO_LOC: - case DO_LOC_VARYING: - /* decrement iteration counter by one */ - chill_expand_assignment (ip->iter_var, MINUS_EXPR, integer_one_node); - /* exit if it's zero */ - expand_exit_loop_if_false (0, - build (NE_EXPR, boolean_type_node, - ip->iter_var, - integer_zero_node)); - break; - case DO_POWERSET: - break; - default: - ; - } - } - - return firstp->error_flag; -} - -/* - * increment the loop-control variables. - */ -static int -increment_temps () -{ - ITERATOR *firstp = loopstack->iter_list, *ip; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - break; - case DO_STEP: - { - tree delta = - fold (build (ip->down_flag ? MINUS_EXPR : PLUS_EXPR, - TREE_TYPE (ip->user_var), ip->user_var, - ip->step_temp)); - expand_expr_stmt ( - build_chill_modify_expr (ip->user_var, delta)); - } - break; - case DO_LOC: - case DO_LOC_VARYING: - /* This statement uses the C semantics, so that - the pointer is actually incremented by the - length of the object pointed to. */ - { - enum tree_code op = ip->down_flag ? MINUS_EXPR : PLUS_EXPR; - tree el_type = TREE_TYPE (TREE_TYPE (ip->loc_ptr_temp)); - chill_expand_assignment (ip->loc_ptr_temp, NOP_EXPR, - build (op, - TREE_TYPE (ip->loc_ptr_temp), - ip->loc_ptr_temp, - size_in_bytes (el_type))); - } - break; - case DO_POWERSET: - if (!ip->down_flag) - expand_assignment (ip->iter_var, - build (PLUS_EXPR, ip->iter_type, - ip->iter_var, - integer_one_node), - 0, 0); - break; - default: - ; - } - } - return firstp->error_flag; -} - -/* - * Generate a (temporary) unique identifier_node of - * the form "__tmp_%s_%d" - */ -tree -get_unique_identifier (lead) - const char *lead; -{ - char idbuf [256]; - static int idcount = 0; - - sprintf (idbuf, "__tmp_%s_%d", lead ? lead : "", idcount++); - return get_identifier (idbuf); -} - -/* - * build a temporary variable, given its NAME and TYPE. - * The name will have a number appended to assure uniqueness. - * return its DECL node. - */ -static tree -build_temporary_variable (name, type) - const char *name; - tree type; -{ - return decl_temp1 (get_unique_identifier (name), type, 0, NULL_TREE, 0, 0); -} - - -/* - * If the given expression isn't a constant, build a temp for it - * and evaluate the expression into the temp. Return the tree - * representing either the original constant expression or the - * temp which now contains the expression's value. - */ -static tree -maybe_make_for_temp (exp, temp_name, exp_type) - tree exp; - const char *temp_name; - tree exp_type; -{ - tree result = exp; - - if (exp != NULL_TREE) - { - /* if exp isn't constant, create a temporary for its value */ - if (TREE_CONSTANT (exp)) - { - /* FIXME: assure that TREE_TYPE (result) == ip->exp_type */ - result = convert (exp_type, exp); - } - else { - /* build temp, assign the value */ - result = decl_temp1 (get_unique_identifier (temp_name), exp_type, 0, - exp, 0, 0); - } - } - return result; -} - -#if 0 -/* - * Adapt the C unsigned_type function to CHILL - we need to - * account for any CHILL-specific integer types here. So far, - * the 16-bit integer type is the only one. - */ -static tree -chill_unsigned_type (type) - tree type; -{ - extern tree chill_unsigned_type_node; - tree type1 = TYPE_MAIN_VARIANT (type); - - if (type1 == chill_integer_type_node) - return chill_unsigned_type_node; - else - return unsigned_type (type); -} -#endif diff --git a/gcc/ch/nloop.c b/gcc/ch/nloop.c deleted file mode 100644 index 51ffbaba3fb..00000000000 --- a/gcc/ch/nloop.c +++ /dev/null @@ -1,1246 +0,0 @@ -/* Implement looping actions for CHILL. - Copyright (C) 1992, 1993, 1994, 2000 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include <stdio.h> -#include <limits.h> -#include "config.h" -#include "tree.h" -#include "ch-tree.h" -#include "lex.h" -#include "flags.h" -#include "actions.h" -#include "input.h" -#include "obstack.h" -#include "assert.h" -#include "rtl.h" - -/* if the user codes '-flocal-loop-counter' on the command line, - ch-actions.c (lang_decode_option) will set this flag. */ -int flag_local_loop_counter = 0; - -extern tree chill_truthvalue_conversion PARAMS ((tree)); -extern rtx emit_line_note PARAMS ((char *, int)); -extern void error PARAMS ((char *, ...)); -extern rtx expand_assignment PARAMS ((tree, tree, int, int)); -extern void save_expr_under_name PARAMS ((tree, tree)); -extern void stamp_nesting_label PARAMS ((tree)); -extern int int_fits_type_p PARAMS ((tree, tree)); -extern void warning PARAMS ((char *, ...)); - -/* forward declarations */ -static int classify_loop PARAMS ((void)); -static int declare_temps PARAMS ((void)); -static int initialize_iter_var PARAMS ((void)); -static int maybe_skip_loop PARAMS ((void)); -static int top_loop_end_check PARAMS ((void)); -static int bottom_loop_end_check PARAMS ((void)); -static int increment_temps PARAMS ((void)); -static tree build_temporary_variable PARAMS ((char *, tree)); -static tree maybe_make_for_temp PARAMS ((tree, char *, tree)); -static tree chill_unsigned_type PARAMS ((tree)); - -/* In terms of the parameters passed to build_loop_iterator, - * there are several types of loops. They are encoded by - * the ITER_TYPE enumeration. - * - * 1) DO FOR EVER; ... OD - * indicated by a NULL_TREE start_exp, step_exp and end_exp, - * condition == NULL, in_flag = 0, and ever_flag == 1 in the - * first ITERATOR. - * - * 2) DO WHILE cond; ... OD - * indicated by NULL_TREE start_exp, step_exp and end_exp, - * in_flag = 0, and condition != NULL. - * - * 3) DO; ... OD - * indicated by NULL_TREEs in start_exp, step_exp and end_exp, - * condition != NULL, in_flag == 0 and ever_flag == 0. This - * is not really a loop, but a compound statement. - * - * 4) DO FOR user_var := start_exp - * [DOWN] TO end_exp BY step_exp; ... DO - * indicated by non-NULL_TREE start_exp, step_exp and end_exp. - * - * 5) DO FOR user_var [DOWN] IN discrete_mode; ... OD - * indicated by in_flag == 1. start_exp is a non-NULL_TREE - * discrete mode, with an optional down_flag. - * - * 6) DO FOR user_var [DOWN] IN powerset_expr; ... OD - * indicated by in_flag == 1. start_exp is a non-NULL_TREE - * powerset mode, with an optional down_flag. - * - * 7) DO FOR user_var [DOWN] IN location; ... OD - * indicated by in_flag == 1. start_exp is a non-NULL_TREE - * location mode, with an optional down_flag. - */ -typedef enum -{ - DO_UNUSED, - DO_FOREVER, - DO_WHILE, - DO_OD, - DO_STEP, - DO_RANGE, - DO_POWERSET, - DO_LOC, - DO_LOC_VARYING -} ITER_TYPE; - - -typedef struct iterator -{ -/* These variables only have meaning in the first ITERATOR structure. */ - ITER_TYPE itype; /* type of this iterator */ - int error_flag; /* TRUE if no loop was started due to - user error */ - tree condition; /* WHILE condition expression */ - int down_flag; /* TRUE if DOWN was coded */ - -/* These variables have meaning in every ITERATOR structure. */ - tree user_var; /* user's explicit iteration variable */ - tree start_exp; /* user's start expression - or IN expression of a FOR .. IN*/ - tree step_exp; /* user's step expression */ - tree end_exp; /* user's end expression */ - tree start_temp; /* temp holding evaluated start_exp */ - tree end_temp; /* temp holding evaluated end_exp */ - tree step_temp; /* temp holding evaluated step_exp */ - tree powerset_temp; /* temp holding user's initial powerset expression */ - tree loc_ptr_temp; /* temp holding count for LOC enumeration ptr */ - tree iter_var; /* hidden variable for the loop */ - tree iter_type; /* hidden variable's type */ - tree base_type; /* LOC enumeration base type */ - struct iterator *next; /* ptr to next iterator for this loop */ -} ITERATOR; - -/* - * There's an entry like this for each nested DO loop. - * The list is maintained by push_loop_block - * and pop_loop_block. - */ -typedef struct loop { - struct loop *nxt_level; /* pointer to enclosing loop */ - ITERATOR *iter_list; /* iterators for the current loop */ -} LOOP; - -static LOOP *loop_stack = (LOOP *)0; - -#if 0 - -Here is a CHILL DO FOR statement: - -DO FOR user_var := start_exp BY step_exp [DOWN] TO end_exp - WHILE condition; - -For this loop to be 'safe', like a Pascal FOR loop, the start, -end, and increment expressions are computed once, before the -assignment to the iteration variable and saved in temporaries, -before the first assignment of the iteration variable, so the -following works: - - FOR i := (i+1) TO (i+10) DO - -To prevent changes to the start/end/step expressions from -effecting the loop''s termination, and to make the loop end-check -as simple as possible, we evaluate the step expression into -a temporary and compute a hidden iteration count before entering -the loop''s body. User code cannot effect the counter, and the -end-loop check simply decrements the counter and checks for zero. - -The whole phrase FOR iter := ... TO end_exp can be repeated -multiple times, with different user-iteration variables. This -is discussed later. - -The loop counter calculations need careful design since a loop -from MININT TO MAXINT must work, in the precision of integers. - -Here''s how it works, in C: - - 0) The DO ... OD loop is simply a block with - its own scope. - - 1) The DO FOR EVER is simply implemented: - - loop_top: - . - . body of loop - . - goto loop_top - end_loop: - - 2) The DO WHILE is also simple: - - - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - goto loop_top - end_loop: - - - 3) The DO FOR [while condition] loop (no DOWN) - - push a new scope, - decl iter_var - - step_temp = step_exp - start_temp = start_exp - end_temp = end_exp - if (end_exp < start_exp) goto end_loop - /* following line is all unsigned arithmetic */ - iter_var = (end_exp - start_exp + step_exp) / step_exp - user_var = start_temp - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - iter_var-- - if (iter_var == 0) goto end_loop - user_var += step_temp - goto loop_top - end_loop: - pop scope - - 4) The proposed CHILL for [while condition] loop (with DOWN) - - push a new scope, - decl iter - step_temp = step_exp - start_temp = start_exp - end_temp = end_exp - if (end_exp > start_exp) goto end_loop - /* following line is all unsigned arithmetic */ - iter_var = (start_exp - end_exp + step_exp) / step_exp - user_var = start_temp - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - iter_var-- - if (iter_var == 0) goto end_loop - user_var -= step_temp - goto loop_top - end_loop: - pop scope - - - 5) The range loop, which iterates over a mode''s possible - values, works just like the above step loops, but with - the start and end values taken from the mode''s lower - and upper domain values. - - - 6) The FOR IN loop, where a location enumeration is - specified (see spec on page 81 of Z.200, bottom - of page 186): - - push a new scope, - decl iter_var as an unsigned integer - loc_ptr_temp as pointer to a composite base type - - if array is varying - iter_var = array''s length field - else - iter_var = sizeof array / sizeof base_type - loc_ptr_temp = &of highest or lowest indexable entry - loop_top: - if (!condition) goto end_loop - . - . body of loop - . - iter_var-- - if (iter_var == 0) goto end_loop - loc_ptr_temp +/-= sizeof array base_type - goto loop_top - end_loop: - pop scope - - 7) The DO FOR (DOWN) IN powerset_exp - - push a new scope, - decl powerset_temp - decl iterator as basetype of powerset - - powerset_temp := start_exp - loop_top: - /* if DOWN */ - if (__flsetclrpowerset () == 0) goto end_loop; - /* not DOWN */ - if (__ffsetclrpowerset () == 0) goto end_loop; - if (!condition) goto end_loop - . - . body of loop - . - goto loop_top - end_loop: - pop scope - - -So, here''s the general DO FOR schema, as implemented here: - - classify_loop -- what type of loop have we? - -- build_iterator does some of this, also - expand_start_loop -- start the loop''s control scope - -- start scope for synthesized loop variables - declare_temps -- create, initialize temporary variables - maybe_skip_loop -- skip loop if end conditions unsatisfiable - initialize_iter_var -- initialize the iteration counter - -- initialize user''s loop variable - expand_start_loop -- generate top-of-loop label - top_loop_end_check -- generate while code and/or - powerset find-a-bit function call - . - . - . user''s loop body code - . - . - bottom_loop_end_check -- exit if counter has become zero - increment_temps -- update temps for next iteration - expand_end_loop -- generate jump back to top of loop - expand_end_cond -- generate label for end of conditional - -- end of scope for synthesized loop variables - free_iterators -- free up iterator space - -When there are two or more iterator phrases, each of the -above loop steps must act upon all iterators. For example, -the 'increment_temps' step must increment all temporaries -(associated with all iterators). - - NOTE: Z.200, section 10.1 says that a block is ... - "the actions statement list in a do action, including any - loop counter and while control". This means that an exp- - ression in a WHILE control can include references to the - loop counters created for the loop''s exclusive use. - Example: - - DCL a (1:10) INT; - DCL j INT; - DO FOR j IN a WHILE j > 0; - ... - OD; - The 'j' referenced in the while is the loc-identity 'j' - created inside the loop''s scope, and NOT the 'j' declared - before the loop. -#endif - -/* - * The following routines are called directly by the - * CHILL parser. - */ -void -push_loop_block () -{ - LOOP *temp = (LOOP *)xmalloc (sizeof (LOOP)); - - /* push a new loop onto the stack */ - temp->nxt_level = loop_stack; - temp->iter_list = (ITERATOR *)0; - loop_stack = temp; -} - -void -pop_loop_block () -{ - LOOP *do_temp = loop_stack; - ITERATOR *ip; - - /* pop loop block off the list */ - loop_stack = do_temp->nxt_level; - - /* free the loop's iterator blocks */ - ip = do_temp->iter_list; - while (ip != NULL) - { - ITERATOR *temp = ip->next; - free (ip); - ip = temp; - } - free (do_temp); -} - -void -begin_loop_scope () -{ - ITERATOR *firstp = loop_stack->iter_list; - - if (pass < 2) - return; - - /* - * We need to classify the loop and declare its temporaries - * here, so as to define them before the WHILE condition - * (if any) is parsed. The WHILE expression may refer to - * a temporary. - */ - if (classify_loop ()) - return; - - if (firstp->itype != DO_OD) - declare_temps (); - - clear_last_expr (); - push_momentary (); - expand_start_bindings (0); -} - - -void -end_loop_scope (opt_label) - tree opt_label; -{ - if (opt_label) - possibly_define_exit_label (opt_label); - poplevel (0, 0, 0); - - if (pass < 2) - return; - - expand_end_bindings (getdecls (), kept_level_p (), 0); - pop_momentary (); -} - -/* The iterator structure records all aspects of a - * 'FOR i := start [DOWN] TO end' clause or - * 'FOR i IN modename' or 'FOR i IN powerset' clause. - * It's saved on the iter_list of the current LOOP. - */ -void -build_loop_iterator (user_var, start_exp, step_exp, end_exp, - down_flag, in_flag, ever_flag) - tree user_var, start_exp, step_exp, end_exp; - int down_flag, in_flag, ever_flag; -{ - ITERATOR *ip = (ITERATOR *)xmalloc (sizeof (ITERATOR)); - - /* chain this iterator onto the current loop */ - if (loop_stack->iter_list == NULL) - loop_stack->iter_list = ip; - else - { - ITERATOR *temp = loop_stack->iter_list; - while (temp->next != NULL) - temp = temp->next; - temp->next = ip; - } - - ip->itype = DO_UNUSED; - ip->user_var = user_var; - ip->start_exp = start_exp; - ip->step_exp = step_exp; - ip->end_exp = end_exp; - ip->condition = NULL_TREE; - ip->start_temp = NULL_TREE; - ip->end_temp = NULL_TREE; - ip->step_temp = NULL_TREE; - ip->down_flag = down_flag; - ip->powerset_temp = NULL_TREE; - ip->iter_var = NULL_TREE; - ip->iter_type = NULL_TREE; - ip->loc_ptr_temp = NULL_TREE; - ip->error_flag = 1; /* assume error will be found */ - ip->next = (ITERATOR *)0; - - if (ever_flag) - ip->itype = DO_FOREVER; - else if (in_flag && start_exp != NULL_TREE) - { - if (TREE_CODE (start_exp) == ERROR_MARK) - return; - if (TREE_CODE (TREE_TYPE (start_exp)) == SET_TYPE) - ip->itype = DO_POWERSET; - else if (discrete_type_p (TREE_TYPE (ip->start_exp))) - ip->itype = DO_RANGE; - else if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ARRAY_TYPE) - ip->itype = DO_LOC; - else if (chill_varying_type_p (TREE_TYPE (ip->start_exp))) - ip->itype = DO_LOC_VARYING; - else - { - error ("Loop's IN expression is not a composite object"); - return; - } - } - else if (start_exp == NULL_TREE && end_exp == NULL_TREE - && step_exp == NULL_TREE && !down_flag) - ip->itype = DO_OD; - else - { - /* FIXME: Move this to the lexer? */ -#define CST_FITS_INT(NODE) (TREE_CODE(NODE) == INTEGER_CST &&\ - int_fits_type_p (NODE, integer_type_node)) - - tree max_prec_type = integer_type_node; - - if (! discrete_type_p (TREE_TYPE (ip->start_exp))) - { - error ("start expr must have discrete mode"); - return; - } - if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ENUMERAL_TYPE - && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->start_exp))) - { - error ("DO FOR start expression is a numbered SET"); - return; - } - if (TREE_CODE (TREE_TYPE (ip->end_exp)) == ENUMERAL_TYPE - && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->end_exp))) - { - error ("TO expression is a numbered SET"); - return; - } - /* Convert all three expressions to a common precision, - which is the largest precision they exhibit, but - INTEGER_CST nodes are built in the lexer as - long_integer_type nodes. We'll treat convert them to - integer_type_nodes if possible, for faster loop times. */ - - if (TYPE_PRECISION (max_prec_type) < - TYPE_PRECISION (TREE_TYPE (ip->start_exp)) - && !CST_FITS_INT (ip->start_exp)) - max_prec_type = TREE_TYPE (ip->start_exp); - if (! discrete_type_p (TREE_TYPE (ip->end_exp))) - { - error ("TO expr must have discrete mode"); - return; - } - if (! CH_COMPATIBLE (ip->start_exp, - TREE_TYPE (ip->end_exp))) - { - error ("start expr and TO expr must be compatible"); - return; - } - if (TYPE_PRECISION (max_prec_type) < - TYPE_PRECISION (TREE_TYPE (ip->end_exp)) - && !CST_FITS_INT (ip->end_exp)) - max_prec_type = TREE_TYPE (ip->end_exp); - if (ip->step_exp != NULL_TREE) - { - /* assure that default 'BY 1' gets a useful type */ - if (ip->step_exp == integer_one_node) - ip->step_exp = convert (TREE_TYPE (ip->start_exp), - ip->step_exp); - if (! discrete_type_p (TREE_TYPE (ip->step_exp))) - { - error ("BY expr must have discrete mode"); - return; - } - if (! CH_COMPATIBLE (ip->start_exp, - TREE_TYPE (ip->step_exp))) - { - error ("start expr and BY expr must be compatible"); - return; - } - if (TYPE_PRECISION (max_prec_type) < - TYPE_PRECISION (TREE_TYPE (ip->step_exp)) - && !CST_FITS_INT (ip->step_exp)) - max_prec_type = TREE_TYPE (ip->step_exp); - } - if (TREE_CODE (ip->start_exp) == INTEGER_CST - && TREE_CODE (ip->end_exp) == INTEGER_CST - && compare_int_csts (ip->down_flag ? LT_EXPR : GT_EXPR, - ip->start_exp, ip->end_exp)) - warning ("body of DO FOR will never execute"); - - ip->start_exp = - convert (max_prec_type, ip->start_exp); - ip->end_exp = - convert (max_prec_type, ip->end_exp); - - if (ip->step_exp != NULL_TREE) - { - ip->step_exp = - convert (max_prec_type, ip->step_exp); - - if (TREE_CODE (ip->step_exp) != INTEGER_CST) - { - /* generate runtime check for negative BY expr */ - ip->step_exp = - check_range (ip->step_exp, ip->step_exp, - integer_zero_node, NULL_TREE); - } - else if (compare_int_csts (LE_EXPR, ip->step_exp, integer_zero_node)) - { - error ("BY expression is negative or zero"); - return; - } - } - ip->itype = DO_STEP; - } - - ip->error_flag = 0; /* no errors! */ -} - -void -build_loop_start (while_control, start_label) - tree while_control, start_label; -{ - ITERATOR *firstp = loop_stack->iter_list; - - firstp->condition = while_control; - - if (firstp->error_flag) - return; - - /* We didn't know at begin_loop_scope time about the condition; - adjust iterator type now. */ - if (firstp->itype == DO_OD && firstp->condition) - firstp->itype = DO_WHILE; - - if (initialize_iter_var ()) - return; - - if (maybe_skip_loop ()) - return; - - /* use the label as an 'exit' label, - 'goto' needs another sort of label */ - expand_start_loop (start_label != NULL_TREE); - - if (top_loop_end_check ()) - return; - emit_line_note (input_filename, lineno); -} - -/* - * Called after the last action of the loop body - * has been parsed. - */ -void -build_loop_end () -{ - ITERATOR *ip = loop_stack->iter_list; - - emit_line_note (input_filename, lineno); - - if (ip->error_flag) - return; - - if (bottom_loop_end_check ()) - return; - - if (increment_temps ()) - return; - - if (ip->itype != DO_OD) - { - expand_end_loop (); - - for (; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_LOC_VARYING: - case DO_STEP: - expand_end_cond (); - break; - default: - break; - } - } - } -} - -/* - * The rest of the routines in this file are called from - * the above three routines. - */ -static int -classify_loop () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - - firstp->error_flag = 0; - if (firstp->itype == DO_UNUSED || firstp->itype == DO_OD) - { - /* if we have just DO .. OD, do nothing - this is just a - BEGIN .. END without creating a new scope, and no looping */ - if (firstp->condition != NULL_TREE) - firstp->itype = DO_WHILE; - else - firstp->itype = DO_OD; - } - - /* Issue a warning if the any loop counter is mentioned more - than once in the iterator list. */ - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_WHILE: - break; - case DO_STEP: - case DO_RANGE: - case DO_POWERSET: - case DO_LOC: - case DO_LOC_VARYING: - /* FIXME: check for name uniqueness */ - break; - default: - ; - } - } - return firstp->error_flag; -} - -/* - * Reserve space for any loop-control temporaries, initialize them - */ -static int -declare_temps () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - tree start_ptr; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_WHILE: - break; - case DO_STEP: - ip->iter_type = chill_unsigned_type (TREE_TYPE (ip->start_exp)); - - /* create, initialize temporaries if expressions aren't constant */ - ip->start_temp = maybe_make_for_temp (ip->start_exp, "for_start", - ip->iter_type); - ip->end_temp = maybe_make_for_temp (ip->end_exp, "for_end", - ip->iter_type); - /* this is just the step-expression */ - ip->step_temp = maybe_make_for_temp (ip->step_exp, "for_step", - ip->iter_type); - goto do_step_range; - - case DO_RANGE: - ip->iter_type = chill_unsigned_type_node; - - ip->start_temp = - (ip->down_flag ? build_chill_upper : build_chill_lower)(TREE_TYPE (ip->start_exp)); - ip->end_temp = - (ip->down_flag ? build_chill_lower : build_chill_upper)(TREE_TYPE (ip->start_exp)); - - ip->step_temp = integer_one_node; - - do_step_range: - if (flag_local_loop_counter) - { - /* (re-)declare the user's iteration variable in the - loop's scope. */ - tree id_node = ip->user_var; - IDENTIFIER_LOCAL_VALUE (id_node) = ip->user_var = - decl_temp1 (id_node, ip->iter_type, 0, NULL_TREE, - 0, 0); - } - else - { - /* in this case, it's a previously-declared - VAR_DECL node, checked in build_loop_iterator. */ - if (TREE_CODE (ip->user_var) == IDENTIFIER_NODE) - ip->user_var = lookup_name (ip->user_var); - if (ip->user_var == NULL_TREE) - { - error ("loop identifier undeclared"); - ip->error_flag = 1; - return 1; - } - } - ip->iter_var = - decl_temp1 (get_unique_identifier ("iter_var"), - ip->iter_type, 0, NULL_TREE, 0, 0); - break; - - case DO_POWERSET: - ip->iter_type = chill_unsigned_type ( - TYPE_DOMAIN (TREE_TYPE (ip->start_exp))); - if (flag_local_loop_counter) - { - /* declare the user's iteration variable in the loop's scope. */ - /* in this case, it's just an IDENTIFIER_NODE */ - ip->user_var = - decl_temp1 (ip->user_var, ip->iter_type, 0, NULL_TREE, 0, 0); - } - else - { - /* in this case, it's a previously-declared VAR_DECL node */ - ip->user_var = lookup_name (ip->user_var); - } - /* the user's powerset-expression, evaluated and saved in a temp */ - ip->powerset_temp = maybe_make_for_temp (ip->start_exp, "for_set", - TREE_TYPE (ip->start_exp)); - mark_addressable (ip->powerset_temp); - break; - - case DO_LOC: - case DO_LOC_VARYING: - ip->iter_type = chill_unsigned_type_node; - /* create the counter temp */ - ip->iter_var = - build_temporary_variable ("iter_var", ip->iter_type); - - if (!CH_LOCATION_P (ip->start_exp)) - ip->start_exp - = decl_temp1 (get_unique_identifier ("iter_loc"), - TREE_TYPE (ip->start_exp), 0, - ip->start_exp, 0, 0); - - if (ip->itype == DO_LOC) - { - tree array_type = TREE_TYPE (ip->start_exp); - tree ptr_type; - tree temp; - - if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE) - { - error ("Can't iterate through array of BOOL"); - ip->error_flag = 1; - return ip->error_flag; - } - - /* FIXME: check for array type in ip->start_exp */ - - /* create pointer temporary */ - ip->base_type = TREE_TYPE (array_type); - ptr_type = build_pointer_type (ip->base_type); - ip->loc_ptr_temp = - build_temporary_variable ("loc_ptr_tmp", ptr_type); - - /* declare the user's iteration variable in - the loop's scope, as an expression, to be - passed to build_component_ref later */ - save_expr_under_name (ip->user_var, - build1 (INDIRECT_REF, ip->base_type, - ip->loc_ptr_temp)); - - /* FIXME: see stor_layout */ - ip->step_temp = size_in_bytes (ip->base_type); - - temp = TYPE_DOMAIN (array_type); - - /* pointer to first array entry to look at */ - start_ptr = build1 (ADDR_EXPR, ptr_type, ip->start_exp); - mark_addressable (ip->start_exp); - ip->start_temp = ip->down_flag ? - fold (build (PLUS_EXPR, ptr_type, - start_ptr, - fold (build (MULT_EXPR, integer_type_node, ip->step_temp, - fold (build (MINUS_EXPR, integer_type_node, - TYPE_MAX_VALUE (temp), - TYPE_MIN_VALUE (temp))))))) - : start_ptr; - } - else - { - tree array_length = - convert (integer_type_node, - build_component_ref (ip->start_exp, var_length_id)); - tree array_type = TREE_TYPE (TREE_CHAIN ( - TYPE_FIELDS (TREE_TYPE (ip->start_exp)))); - tree array_data_ptr = - build_component_ref (ip->start_exp, var_data_id); - tree ptr_type; - - if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE) - { - error ("Can't iterate through array of BOOL"); - firstp->error_flag = 1; - return firstp->error_flag; - } - - /* create pointer temporary */ - ip->base_type = TREE_TYPE (array_type); - ptr_type = build_pointer_type (ip->base_type); - ip->loc_ptr_temp = - build_temporary_variable ("loc_ptr_temp", ptr_type); - - - /* declare the user's iteration variable in - the loop's scope, as an expression, to be - passed to build_component_ref later */ - save_expr_under_name (ip->user_var, - build1 (INDIRECT_REF, ip->base_type, - ip->loc_ptr_temp)); - - /* FIXME: see stor_layout */ - ip->step_temp = size_in_bytes (ip->base_type); - - /* pointer to first array entry to look at */ - start_ptr = build1 (ADDR_EXPR, ptr_type, array_data_ptr); - mark_addressable (array_data_ptr); - ip->start_temp = ip->down_flag ? - fold (build (PLUS_EXPR, ptr_type, - start_ptr, - fold (build (MULT_EXPR, integer_type_node, ip->step_temp, - fold (build (MINUS_EXPR, integer_type_node, - array_length, - integer_one_node)))))) - : start_ptr; - } - default: - ; - } - } - return firstp->error_flag; -} - -/* - * Initialize the hidden iteration-control variables, - * and the user's explicit loop variable. - */ -static int -initialize_iter_var () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_WHILE: - break; - case DO_STEP: - case DO_RANGE: - { - tree count = - fold (build (PLUS_EXPR, ip->iter_type, integer_one_node, - fold (build (TRUNC_DIV_EXPR, ip->iter_type, - convert (ip->iter_type, - fold (build (MINUS_EXPR, ip->iter_type, - ip->down_flag ? ip->start_temp : ip->end_temp, - ip->down_flag ? ip->end_temp : ip->start_temp))), - ip->step_temp)))); - /* initialize the loop's hidden counter variable */ - expand_expr_stmt ( - build_chill_modify_expr (ip->iter_var, count)); - - /* initialize user's variable */ - expand_expr_stmt ( - build_chill_modify_expr (ip->user_var, ip->start_temp)); - } - break; - case DO_POWERSET: - break; - case DO_LOC: - { - tree array_type = TREE_TYPE (ip->start_exp); - tree array_length = - fold (build (TRUNC_DIV_EXPR, integer_type_node, - size_in_bytes (array_type), - size_in_bytes (TREE_TYPE (array_type)))); - - expand_expr_stmt ( - build_chill_modify_expr (ip->iter_var, array_length)); - goto do_loc_common; - } - - case DO_LOC_VARYING: - expand_expr_stmt ( - build_chill_modify_expr (ip->iter_var, - convert (integer_type_node, - build_component_ref (ip->start_exp, var_length_id)))); - - do_loc_common: - expand_expr_stmt ( - build_chill_modify_expr (ip->loc_ptr_temp, - ip->start_temp)); - break; - - default: - ; - } - } - return firstp->error_flag; -} - -/* Generate code to skip the whole loop, if start expression not - * <= end expression (or >= for DOWN loops). This comparison must - * *NOT* be done in unsigned mode, or it will fail. - * Also, skip processing an empty VARYING array. - */ -static int -maybe_skip_loop () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_STEP: - expand_start_cond ( - build (ip->down_flag ? GE_EXPR : LE_EXPR, - TREE_TYPE (ip->start_exp), - ip->start_exp, ip->end_exp), 0); - break; - - case DO_LOC_VARYING: - { tree array_length = - convert (integer_type_node, - build_component_ref (ip->start_exp, var_length_id)); - expand_start_cond ( - build (NE_EXPR, TREE_TYPE (array_length), - array_length, integer_zero_node), 0); - break; - } - default: - break; - } - } - return 0; -} - -/* - * Check at the top of the loop for a termination - */ -static int -top_loop_end_check () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - - /* now, exit the loop if the condition isn't TRUE. */ - if (firstp->condition) - { - expand_exit_loop_if_false (0, - chill_truthvalue_conversion (firstp->condition)); - } - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_WHILE: - case DO_STEP: - case DO_RANGE: - break; - case DO_POWERSET: - { - tree temp1; - char *func_name; - - if (ip->down_flag) - func_name = "__flsetclrpowerset"; - else - func_name = "__ffsetclrpowerset"; - - temp1 = TYPE_MIN_VALUE - (TYPE_DOMAIN (TREE_TYPE (ip->powerset_temp))); - expand_exit_loop_if_false (0, - build_chill_function_call (lookup_name (get_identifier (func_name)), - tree_cons (NULL_TREE, force_addr_of (ip->powerset_temp), - tree_cons (NULL_TREE, powersetlen (ip->powerset_temp), - tree_cons (NULL_TREE, force_addr_of (ip->user_var), - tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (ip->user_var)), - tree_cons (NULL_TREE, - convert (long_integer_type_node, temp1), - NULL_TREE))))))); - } - break; - case DO_LOC: - case DO_LOC_VARYING: - break; - default: - ; - } - } - return firstp->error_flag; -} - -/* - * Check generated temporaries for loop's end - */ -static int -bottom_loop_end_check () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - - emit_line_note (input_filename, lineno); - - /* now, generate code to check each loop counter for termination */ - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_WHILE: - break; - case DO_STEP: - case DO_RANGE: - case DO_LOC: - case DO_LOC_VARYING: - /* decrement iteration counter by one */ - chill_expand_assignment (ip->iter_var, MINUS_EXPR, integer_one_node); - /* exit if it's zero */ - expand_exit_loop_if_false (0, - build (NE_EXPR, boolean_type_node, - ip->iter_var, - integer_zero_node)); - break; - case DO_POWERSET: - break; - default: - ; - } - } - - return firstp->error_flag; -} - -/* - * increment the loop-control variables. - */ -static int -increment_temps () -{ - ITERATOR *firstp = loop_stack->iter_list, *ip; - - for (ip = firstp; ip != NULL; ip = ip->next) - { - switch (ip->itype) - { - case DO_FOREVER: - case DO_WHILE: - break; - case DO_STEP: - case DO_RANGE: - { - tree delta = - fold (build (ip->down_flag ? MINUS_EXPR : PLUS_EXPR, - TREE_TYPE (ip->user_var), ip->user_var, - ip->step_temp)); - expand_expr_stmt ( - build_chill_modify_expr (ip->user_var, delta)); - } - break; - case DO_LOC: - case DO_LOC_VARYING: - /* This statement uses the C semantics, so that - the pointer is actually incremented by the - length of the object pointed to. */ -#if 1 - expand_expr_stmt ( - build_modify_expr (ip->loc_ptr_temp, - ip->down_flag ? MINUS_EXPR : PLUS_EXPR, - integer_one_node)); -#else - { - enum tree_code op = ip->down_flag ? MINUS_EXPR : PLUS_EXPR; - tree el_type = TREE_TYPE (TREE_TYPE (ip->loc_ptr_temp)); - chill_expand_assignment (ip->loc_ptr_temp, NOP_EXPR, - build (op, - TREE_TYPE (ip->loc_ptr_temp), - ip->loc_ptr_temp, - size_in_bytes (el_type))); - } -#endif - break; - case DO_POWERSET: - break; - default: - ; - } - } - return firstp->error_flag; -} - -/* - * Generate a (temporary) unique identifier_node of - * the form "__tmp_%s_%d" - */ -tree -get_unique_identifier (lead) - char *lead; -{ - char idbuf [256]; - static int idcount = 0; - - sprintf (idbuf, "__tmp_%s_%d", lead ? lead : "", idcount++); - return get_identifier (idbuf); -} - -/* - * build a temporary variable, given its NAME and TYPE. - * The name will have a number appended to assure uniqueness. - * return its DECL node. - */ -static tree -build_temporary_variable (name, type) - char *name; - tree type; -{ - return decl_temp1 (get_unique_identifier (name), type, 0, NULL_TREE, 0, 0); -} - - -/* - * If the given expression isn't a constant, build a temp for it - * and evaluate the expression into the temp. Return the tree - * representing either the original constant expression or the - * temp which now contains the expression's value. - */ -static tree -maybe_make_for_temp (exp, temp_name, exp_type) - tree exp; - char *temp_name; - tree exp_type; -{ - tree result = exp; - - if (exp != NULL_TREE) - { - /* if exp isn't constant, create a temporary for its value */ - if (TREE_CONSTANT (exp)) - { - /* FIXME: assure that TREE_TYPE (result) == ip->exp_type */ - result = convert (exp_type, exp); - } - else { - /* build temp, assign the value */ - result = decl_temp1 (get_unique_identifier (temp_name), exp_type, 0, - exp, 0, 0); - } - } - return result; -} - - -/* - * Adapt the C unsigned_type function to CHILL - we need to - * account for any CHILL-specific integer types here. So far, - * the 16-bit integer type is the only one. - */ -static tree -chill_unsigned_type (type) - tree type; -{ - extern tree chill_unsigned_type_node; - tree type1 = TYPE_MAIN_VARIANT (type); - - if (type1 == chill_integer_type_node) - return chill_unsigned_type_node; - else - return unsigned_type (type); -} diff --git a/gcc/ch/parse.c b/gcc/ch/parse.c deleted file mode 100644 index afcf1427fd8..00000000000 --- a/gcc/ch/parse.c +++ /dev/null @@ -1,4332 +0,0 @@ -/* Parser for GNU CHILL (CCITT High-Level Language) -*- C -*- - Copyright (C) 1992, 1993, 1998, 1999, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* - * This is a two-pass parser. In pass 1, we collect declarations, - * ignoring actions and most expressions. We store only the - * declarations and close, open and re-lex the input file to save - * main memory. We anticipate that the compiler will be processing - * *very* large single programs which are mechanically generated, - * and so we want to store a minimum of information between passes. - * - * yylex detects the end of the main input file and returns the - * END_PASS_1 token. We then re-initialize each CHILL compiler - * module's global variables and re-process the input file. The - * grant file is output. If the user has requested it, GNU CHILL - * exits at this time - its only purpose was to generate the grant - * file. Optionally, the compiler may exit if errors were detected - * in pass 1. - * - * As each symbol scope is entered, we install its declarations into - * the symbol table. Undeclared types and variables are announced - * now. - * - * Then code is generated. - */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "lex.h" -#include "actions.h" -#include "tasking.h" -#include "parse.h" -#include "toplev.h" - -/* Since parsers are distinct for each language, put the - language string definition here. (fnf) */ -const char * const language_string = "GNU CHILL"; - -/* Common code to be done before expanding any action. */ -#define INIT_ACTION { \ - if (! ignoring) emit_line_note (input_filename, lineno); } - -/* Pop a scope for an ON handler. */ -#define POP_USED_ON_CONTEXT pop_handler(1) - -/* Pop a scope for an ON handler that wasn't there. */ -#define POP_UNUSED_ON_CONTEXT pop_handler(0) - -#define PUSH_ACTION push_action() - -/* Cause the `yydebug' variable to be defined. */ -#define YYDEBUG 1 - -extern struct rtx_def* gen_label_rtx PARAMS ((void)); -extern void emit_jump PARAMS ((struct rtx_def *)); -extern struct rtx_def* emit_label PARAMS ((struct rtx_def *)); - -/* This is a hell of a lot easier than getting expr.h included in - by parse.c. */ -extern struct rtx_def *expand_expr PARAMS ((tree, struct rtx_def *, - enum machine_mode, int)); - -static int parse_action PARAMS ((void)); -static void ch_parse_init PARAMS ((void)); -static void check_end_label PARAMS ((tree, tree)); -static void end_function PARAMS ((void)); -static tree build_prefix_clause PARAMS ((tree)); -static enum terminal PEEK_TOKEN PARAMS ((void)); -static int peek_token_ PARAMS ((int)); -static void pushback_token PARAMS ((int, tree)); -static void forward_token_ PARAMS ((void)); -static void require PARAMS ((enum terminal)); -static int check_token PARAMS ((enum terminal)); -static int expect PARAMS ((enum terminal, const char *)); -static void define__PROCNAME__ PARAMS ((void)); - -extern int lineno; -extern tree generic_signal_type_node; -extern tree signal_code; -extern int all_static_flag; -extern int ignore_case; - -#if 0 -static int quasi_signal = 0; /* 1 if processing a quasi signal decl */ -#endif - -int parsing_newmode; /* 0 while parsing SYNMODE; - 1 while parsing NEWMODE. */ -int expand_exit_needed = 0; - -/* Gets incremented if we see errors such that we don't want to run pass 2. */ - -int serious_errors = 0; - -static tree current_fieldlist; - -/* We don't care about expressions during pass 1, except while we're - parsing the RHS of a SYN definition, or while parsing a mode that - we need. NOTE: This also causes mode expressions to be ignored. */ -int ignoring = 1; /* 1 to ignore expressions */ - -/* True if we have seen an action not in a (user) function. */ -int seen_action = 0; -int build_constructor = 0; - -/* The action_nesting_level of the current procedure body. */ -int proc_action_level = 0; - -/* This is the identifier of the label that prefixes the current action, - or NULL if there was none. It is cleared at the end of an action, - or when starting a nested action list, so get it while you can! */ -static tree label = NULL_TREE; /* for statement labels */ - -#if 0 -static tree current_block; -#endif - -int in_pseudo_module = 0; -int pass = 0; /* 0 for init_decl_processing, - 1 for pass 1, 2 for pass 2 */ - -/* re-initialize global variables for pass 2 */ -static void -ch_parse_init () -{ - expand_exit_needed = 0; - label = NULL_TREE; /* for statement labels */ - current_module = NULL; - in_pseudo_module = 0; -} - -static void -check_end_label (start, end) - tree start, end; -{ - if (end != NULL_TREE) - { - if (start == NULL_TREE && pass == 1) - error ("there was no start label to match the end label '%s'", - IDENTIFIER_POINTER(end)); - else if (start != end && pass == 1) - error ("start label '%s' does not match end label '%s'", - IDENTIFIER_POINTER(start), - IDENTIFIER_POINTER(end)); - } -} - - -/* - * given a tree which is an id, a type or a decl, - * return the associated type, or issue an error and - * return error_mark_node. - */ -tree -get_type_of (id_or_decl) - tree id_or_decl; -{ - tree type = id_or_decl; - - if (id_or_decl == NULL_TREE - || TREE_CODE (id_or_decl) == ERROR_MARK) - return error_mark_node; - - if (pass == 1 || ignoring == 1) - return id_or_decl; - - if (TREE_CODE (type) == IDENTIFIER_NODE) - { - type = lookup_name (id_or_decl); - if (type == NULL_TREE) - { - error ("`%s' not declared", IDENTIFIER_POINTER (id_or_decl)); - type = error_mark_node; - } - } - if (TREE_CODE (type) == TYPE_DECL) - type = TREE_TYPE (type); - return type; /* was a type all along */ -} - - -static void -end_function () -{ - if (CH_DECL_PROCESS (current_function_decl)) - { - /* finishing a process */ - if (! ignoring) - { - tree result = - build_chill_function_call - (lookup_name (get_identifier ("__stop_process")), - NULL_TREE); - expand_expr_stmt (result); - emit_line_note (input_filename, lineno); - } - } - else - { - /* finishing a procedure.. */ - if (! ignoring) - { - if (result_never_set - && TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl))) - != VOID_TYPE) - warning ("No RETURN or RESULT in procedure"); - chill_expand_return (NULL_TREE, 1); - } - } - finish_chill_function (); - pop_chill_function_context (); -} - -static tree -build_prefix_clause (id) - tree id; -{ - if (!id) - { - if (current_module && current_module->name) - { const char *module_name = IDENTIFIER_POINTER (current_module->name); - if (module_name[0] && module_name[0] != '_') - return current_module->name; - } - error ("PREFIXED clause with no prelix in unlabeled module"); - } - return id; -} - -void -possibly_define_exit_label (label) - tree label; -{ - if (label) - define_label (input_filename, lineno, munge_exit_label (label)); -} - -#define MAX_LOOK_AHEAD 2 -static enum terminal terminal_buffer[MAX_LOOK_AHEAD+1]; -YYSTYPE yylval; -static YYSTYPE val_buffer[MAX_LOOK_AHEAD+1]; - -/*enum terminal current_token, lookahead_token;*/ - -#define TOKEN_NOT_READ dummy_last_terminal - -#ifdef __GNUC__ -__inline__ -#endif -static enum terminal -PEEK_TOKEN() -{ - if (terminal_buffer[0] == TOKEN_NOT_READ) - { - terminal_buffer[0] = yylex(); - val_buffer[0] = yylval; - } - return terminal_buffer[0]; -} -#define PEEK_TREE() val_buffer[0].ttype -#define PEEK_TOKEN1() peek_token_ (1) -#define PEEK_TOKEN2() peek_token_ (2) - -static int -peek_token_ (i) - int i; -{ - if (i > MAX_LOOK_AHEAD) - abort (); - if (terminal_buffer[i] == TOKEN_NOT_READ) - { - terminal_buffer[i] = yylex(); - val_buffer[i] = yylval; - } - return terminal_buffer[i]; -} - -static void -pushback_token (code, node) - int code; - tree node; -{ - int i; - if (terminal_buffer[MAX_LOOK_AHEAD] != TOKEN_NOT_READ) - abort (); - for (i = MAX_LOOK_AHEAD; i > 0; i--) - { - terminal_buffer[i] = terminal_buffer[i - 1]; - val_buffer[i] = val_buffer[i - 1]; - } - terminal_buffer[0] = code; - val_buffer[0].ttype = node; -} - -static void -forward_token_() -{ - int i; - for (i = 0; i < MAX_LOOK_AHEAD; i++) - { - terminal_buffer[i] = terminal_buffer[i+1]; - val_buffer[i] = val_buffer[i+1]; - } - terminal_buffer[MAX_LOOK_AHEAD] = TOKEN_NOT_READ; -} -#define FORWARD_TOKEN() forward_token_ () - -/* Skip the next token. - if it isn't TOKEN, the parser is broken. */ - -static void -require (token) - enum terminal token; -{ - if (PEEK_TOKEN() != token) - internal_error ("internal parser error - expected token %d", (int) token); - FORWARD_TOKEN(); -} - -static int -check_token (token) - enum terminal token; -{ - if (PEEK_TOKEN() != token) - return 0; - FORWARD_TOKEN (); - return 1; -} - -/* return 0 if expected token was not found, - else return 1. -*/ -static int -expect(token, message) - enum terminal token; - const char *message; -{ - if (PEEK_TOKEN() != token) - { - if (pass == 1) - error("%s", message ? message : "syntax error"); - return 0; - } - else - FORWARD_TOKEN(); - return 1; -} - -/* define a SYNONYM __PROCNAME__ (__procname__) which holds - the name of the current procedure. - This should be quit the same as __FUNCTION__ in C */ -static void -define__PROCNAME__ () -{ - const char *fname; - tree string; - tree procname; - - if (current_function_decl == NULL_TREE) - fname = "toplevel"; - else - fname = IDENTIFIER_POINTER (DECL_NAME (current_function_decl)); - - string = build_chill_string (strlen (fname), fname); - procname = get_identifier (ignore_case ? "__procname__" : "__PROCNAME__"); - push_syndecl (procname, NULL_TREE, string); -} - -/* Forward declarations. */ -static tree parse_expression PARAMS ((void)); -static tree parse_primval PARAMS ((void)); -static tree parse_mode PARAMS ((void)); -static tree parse_opt_mode PARAMS ((void)); -static tree parse_untyped_expr PARAMS ((void)); -static tree parse_opt_untyped_expr PARAMS ((void)); -static int parse_definition PARAMS ((int)); -static void parse_opt_actions PARAMS ((void)); -static void parse_body PARAMS ((void)); -static tree parse_if_expression_body PARAMS ((void)); -static tree parse_opt_handler PARAMS ((void)); -static tree parse_opt_name_string PARAMS ((int)); -static tree parse_simple_name_string PARAMS ((void)); -static tree parse_name_string PARAMS ((void)); -static tree parse_defining_occurrence PARAMS ((void)); -static tree parse_name PARAMS ((void)); -static tree parse_optlabel PARAMS ((void)); -static void parse_opt_end_label_semi_colon PARAMS ((tree)); -static void parse_modulion PARAMS ((tree)); -static void parse_spec_module PARAMS ((tree)); -static void parse_semi_colon PARAMS ((void)); -static tree parse_defining_occurrence_list PARAMS ((void)); -static void parse_mode_definition PARAMS ((int)); -static void parse_mode_definition_statement PARAMS ((int)); -static void parse_synonym_definition PARAMS ((void)); -static void parse_synonym_definition_statement PARAMS ((void)); -static tree parse_on_exception_list PARAMS ((void)); -static void parse_on_alternatives PARAMS ((void)); -static void parse_loc_declaration PARAMS ((int)); -static void parse_declaration_statement PARAMS ((int)); -static tree parse_optforbid PARAMS ((void)); -static tree parse_postfix PARAMS ((enum terminal)); -static tree parse_postfix_list PARAMS ((enum terminal)); -static void parse_rename_clauses PARAMS ((enum terminal)); -static tree parse_opt_prefix_clause PARAMS ((void)); -static void parse_grant_statement PARAMS ((void)); -static void parse_seize_statement PARAMS ((void)); -static tree parse_param_name_list PARAMS ((void)); -static tree parse_param_attr PARAMS ((void)); -static tree parse_formpar PARAMS ((void)); -static tree parse_formparlist PARAMS ((void)); -static tree parse_opt_result_spec PARAMS ((void)); -static tree parse_opt_except PARAMS ((void)); -static tree parse_opt_recursive PARAMS ((void)); -static tree parse_procedureattr PARAMS ((void)); -static void parse_proc_body PARAMS ((tree, tree)); -static void parse_procedure_definition PARAMS ((int)); -static tree parse_processpar PARAMS ((void)); -static tree parse_processparlist PARAMS ((void)); -static void parse_process_definition PARAMS ((int)); -static void parse_signal_definition PARAMS ((void)); -static void parse_signal_definition_statement PARAMS ((void)); -static void parse_then_clause PARAMS ((void)); -static void parse_opt_else_clause PARAMS ((void)); -static tree parse_expr_list PARAMS ((void)); -static tree parse_range_list_clause PARAMS ((void)); -static void pushback_paren_expr PARAMS ((tree)); -static tree parse_case_label PARAMS ((void)); -static tree parse_case_label_list PARAMS ((tree, int)); -static tree parse_case_label_specification PARAMS ((tree)); -static void parse_single_dimension_case_action PARAMS ((tree)); -static void parse_multi_dimension_case_action PARAMS ((tree)); -static void parse_case_action PARAMS ((tree)); -static tree parse_asm_operands PARAMS ((void)); -static tree parse_asm_clobbers PARAMS ((void)); -static void ch_expand_asm_operands PARAMS ((tree, tree, tree, tree, - int, const char *, int)); -static void parse_asm_action PARAMS ((void)); -static void parse_begin_end_block PARAMS ((tree)); -static void parse_if_action PARAMS ((tree)); -static void parse_iteration PARAMS ((void)); -static tree parse_delay_case_event_list PARAMS ((void)); -static void parse_delay_case_action PARAMS ((tree)); -static void parse_do_action PARAMS ((tree)); -static tree parse_receive_spec PARAMS ((void)); -static void parse_receive_case_action PARAMS ((tree)); -static void parse_send_action PARAMS ((void)); -static void parse_start_action PARAMS ((void)); -static tree parse_call PARAMS ((tree)); -static tree parse_tuple_fieldname_list PARAMS ((void)); -static tree parse_tuple_element PARAMS ((void)); -static tree parse_opt_element_list PARAMS ((void)); -static tree parse_tuple PARAMS ((tree)); -static tree parse_operand6 PARAMS ((void)); -static tree parse_operand5 PARAMS ((void)); -static tree parse_operand4 PARAMS ((void)); -static tree parse_operand3 PARAMS ((void)); -static tree parse_operand2 PARAMS ((void)); -static tree parse_operand1 PARAMS ((void)); -static tree parse_operand0 PARAMS ((void)); -static tree parse_case_expression PARAMS ((void)); -static tree parse_then_alternative PARAMS ((void)); -static tree parse_else_alternative PARAMS ((void)); -static tree parse_if_expression PARAMS ((void)); -static tree parse_index_mode PARAMS ((void)); -static tree parse_set_mode PARAMS ((void)); -static tree parse_pos PARAMS ((void)); -static tree parse_step PARAMS ((void)); -static tree parse_opt_layout PARAMS ((int)); -static tree parse_field_name_list PARAMS ((void)); -static tree parse_fixed_field PARAMS ((void)); -static tree parse_variant_field_list PARAMS ((void)); -static tree parse_variant_alternative PARAMS ((void)); -static tree parse_field PARAMS ((void)); -static tree parse_structure_mode PARAMS ((void)); -static tree parse_opt_queue_size PARAMS ((void)); -static tree parse_procedure_mode PARAMS ((void)); -static void parse_program PARAMS ((void)); -static void parse_pass_1_2 PARAMS ((void)); - -static tree -parse_opt_name_string (allow_all) - int allow_all; /* 1 if ALL is allowed as a postfix */ -{ - enum terminal token = PEEK_TOKEN(); - tree name; - if (token != NAME) - { - if (token == ALL && allow_all) - { - FORWARD_TOKEN (); - return ALL_POSTFIX; - } - return NULL_TREE; - } - name = PEEK_TREE(); - for (;;) - { - FORWARD_TOKEN (); - token = PEEK_TOKEN(); - if (token != '!') - return name; - FORWARD_TOKEN(); - token = PEEK_TOKEN(); - if (token == ALL && allow_all) - return get_identifier3(IDENTIFIER_POINTER (name), "!", "*"); - if (token != NAME) - { - if (pass == 1) - error ("'%s!' is not followed by an identifier", - IDENTIFIER_POINTER (name)); - return name; - } - name = get_identifier3(IDENTIFIER_POINTER(name), - "!", IDENTIFIER_POINTER(PEEK_TREE())); - } -} - -static tree -parse_simple_name_string () -{ - enum terminal token = PEEK_TOKEN(); - tree name; - if (token != NAME) - { - error ("expected a name here"); - return error_mark_node; - } - name = PEEK_TREE (); - FORWARD_TOKEN (); - return name; -} - -static tree -parse_name_string () -{ - tree name = parse_opt_name_string (0); - if (name) - return name; - if (pass == 1) - error ("expected a name string here"); - return error_mark_node; -} - -static tree -parse_defining_occurrence () -{ - if (PEEK_TOKEN () == NAME) - { - tree id = PEEK_TREE(); - FORWARD_TOKEN (); - return id; - } - return NULL; -} - -/* Matches: <name_string> - Returns if pass 1: the identifier. - Returns if pass 2: a decl or value for identifier. */ - -static tree -parse_name () -{ - tree name = parse_name_string (); - if (pass == 1 || ignoring) - return name; - else - { - tree decl = lookup_name (name); - if (decl == NULL_TREE) - { - error ("`%s' undeclared", IDENTIFIER_POINTER (name)); - return error_mark_node; - } - else if (TREE_CODE (TREE_TYPE (decl)) == ERROR_MARK) - return error_mark_node; - else if (TREE_CODE (decl) == CONST_DECL) - return DECL_INITIAL (decl); - else if (TREE_CODE (TREE_TYPE (decl)) == REFERENCE_TYPE) - return convert_from_reference (decl); - else - return decl; - } -} - -static tree -parse_optlabel() -{ - tree label = parse_defining_occurrence(); - if (label != NULL) - expect(COLON, "expected a ':' here"); - return label; -} - -static void -parse_semi_colon () -{ - enum terminal token = PEEK_TOKEN (); - if (token == SC) - FORWARD_TOKEN (); - else if (pass == 1) - (token == END ? pedwarn : error) ("expected ';' here"); - label = NULL_TREE; -} - -static void -parse_opt_end_label_semi_colon (start_label) - tree start_label; -{ - if (PEEK_TOKEN() == NAME) - { - tree end_label = parse_name_string (); - check_end_label (start_label, end_label); - } - parse_semi_colon (); -} - -static void -parse_modulion (label) - tree label; -{ - tree module_name; - - label = set_module_name (label); - module_name = push_module (label, 0); - FORWARD_TOKEN(); - - push_action (); - parse_body(); - expect(END, "expected END here"); - parse_opt_handler (); - parse_opt_end_label_semi_colon (label); - find_granted_decls (); - pop_module (); -} - -static void -parse_spec_module (label) - tree label; -{ - int save_ignoring = ignoring; - - push_module (set_module_name (label), 1); - ignoring = pass == 2; - FORWARD_TOKEN(); /* SKIP SPEC */ - expect (MODULE, "expected 'MODULE' here"); - - while (parse_definition (1)) { } - if (parse_action ()) - error ("action not allowed in SPEC MODULE"); - expect(END, "expected END here"); - parse_opt_end_label_semi_colon (label); - find_granted_decls (); - pop_module (); - ignoring = save_ignoring; -} - -/* Matches: <name_string> ( "," <name_string> )* - Returns either a single IDENTIFIER_NODE, - or a chain (TREE_LIST) of IDENTIFIER_NODES. - (Since a single identifier is the common case, we avoid wasting space - (twice, once for each pass) with extra TREE_LIST nodes in that case.) - (Will not return NULL_TREE even if ignoring is true.) */ - -static tree -parse_defining_occurrence_list () -{ - tree chain = NULL_TREE; - tree name = parse_defining_occurrence (); - if (name == NULL_TREE) - { - error("missing defining occurrence"); - return NULL_TREE; - } - if (! check_token (COMMA)) - return name; - chain = build_tree_list (NULL_TREE, name); - for (;;) - { - name = parse_defining_occurrence (); - if (name == NULL) - { - error ("bad defining occurrence following ','"); - break; - } - chain = tree_cons (NULL_TREE, name, chain); - if (! check_token (COMMA)) - break; - } - return nreverse (chain); -} - -static void -parse_mode_definition (is_newmode) - int is_newmode; -{ - tree mode, names; - int save_ignoring = ignoring; - ignoring = pass == 2; - names = parse_defining_occurrence_list (); - expect (EQL, "missing '=' in mode definition"); - mode = parse_mode (); - if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST) - { - for ( ; names != NULL_TREE; names = TREE_CHAIN (names)) - push_modedef (names, mode, is_newmode); - } - else - push_modedef (names, mode, is_newmode); - ignoring = save_ignoring; -} - -static void -parse_mode_definition_statement (is_newmode) - int is_newmode; -{ - FORWARD_TOKEN (); /* skip SYNMODE or NEWMODE */ - parse_mode_definition (is_newmode); - while (PEEK_TOKEN () == COMMA) - { - FORWARD_TOKEN (); - parse_mode_definition (is_newmode); - } - parse_semi_colon (); -} - -static void -parse_synonym_definition () -{ tree expr = NULL_TREE; - tree names = parse_defining_occurrence_list (); - tree mode = parse_opt_mode (); - if (! expect (EQL, "missing '=' in synonym definition")) - mode = error_mark_node; - else - { - if (mode) - expr = parse_untyped_expr (); - else - expr = parse_expression (); - } - if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST) - { - for ( ; names != NULL_TREE; names = TREE_CHAIN (names)) - push_syndecl (names, mode, expr); - } - else - push_syndecl (names, mode, expr); -} - -static void -parse_synonym_definition_statement() -{ - int save_ignoring= ignoring; - ignoring = pass == 2; - require (SYN); - parse_synonym_definition (); - while (PEEK_TOKEN () == COMMA) - { - FORWARD_TOKEN (); - parse_synonym_definition (); - } - ignoring = save_ignoring; - parse_semi_colon (); -} - -/* Attempts to match: "(" <exception list> ")" ":". - Return NULL_TREE on failure, and non-NULL on success. - On success, if pass 1, return a TREE_LIST of IDENTIFIER_NODEs. */ - -static tree -parse_on_exception_list () -{ - tree name; - tree list = NULL_TREE; - int tok1 = PEEK_TOKEN (); - int tok2 = PEEK_TOKEN1 (); - - /* This requires a lot of look-ahead, because we cannot - easily a priori distinguish an exception-list from an expression. */ - if (tok1 != LPRN || tok2 != NAME) - { - if (tok1 == NAME && tok2 == COLON && pass == 1) - error ("missing '(' in exception list"); - return 0; - } - require (LPRN); - name = parse_name_string (); - if (PEEK_TOKEN () == RPRN && PEEK_TOKEN1 () == COLON) - { - /* Matched: '(' <name_string> ')' ':' */ - FORWARD_TOKEN (); FORWARD_TOKEN (); - return pass == 1 ? build_tree_list (NULL_TREE, name) : name; - } - if (PEEK_TOKEN() == COMMA) - { - if (pass == 1) - list = build_tree_list (NULL_TREE, name); - while (check_token (COMMA)) - { - tree old_names = list; - name = parse_name_string (); - if (pass == 1) - { - for ( ; old_names != NULL_TREE; old_names = TREE_CHAIN (old_names)) - { - if (TREE_VALUE (old_names) == name) - { - error ("ON exception names must be unique"); - goto continue_parsing; - } - } - list = tree_cons (NULL_TREE, name, list); - continue_parsing: - ; - } - } - if (! check_token (RPRN) || ! check_token(COLON)) - error ("syntax error in exception list"); - return pass == 1 ? nreverse (list) : name; - } - /* Matched: '(' name_string - but it doesn't match the syntax of an exception list. - It could be the beginning of an expression, so back up. */ - pushback_token (NAME, name); - pushback_token (LPRN, 0); - return NULL_TREE; -} - -static void -parse_on_alternatives () -{ - for (;;) - { - tree except_list = parse_on_exception_list (); - if (except_list != NULL) - chill_handle_on_labels (except_list); - else if (parse_action ()) - expand_exit_needed = 1; - else - break; - } -} - -static tree -parse_opt_handler () -{ - if (! check_token (ON)) - { - POP_UNUSED_ON_CONTEXT; - return NULL_TREE; - } - if (check_token (END)) - { - pedwarn ("empty ON-condition"); - POP_UNUSED_ON_CONTEXT; - return NULL_TREE; - } - if (! ignoring) - { - chill_start_on (); - expand_exit_needed = 0; - } - if (PEEK_TOKEN () != ELSE) - { - parse_on_alternatives (); - if (! ignoring && expand_exit_needed) - expand_exit_something (); - } - if (check_token (ELSE)) - { - chill_start_default_handler (); - label = NULL_TREE; - parse_opt_actions (); - if (! ignoring) - { - emit_line_note (input_filename, lineno); - expand_exit_something (); - } - } - expect (END, "missing 'END' after"); - if (! ignoring) - chill_finish_on (); - POP_USED_ON_CONTEXT; - return integer_zero_node; -} - -static void -parse_loc_declaration (in_spec_module) - int in_spec_module; -{ - tree names = parse_defining_occurrence_list (); - int save_ignoring = ignoring; - int is_static, lifetime_bound; - tree mode, init_value = NULL_TREE; - int loc_decl = 0; - - ignoring = pass == 2; - mode = parse_mode (); - ignoring = save_ignoring; - is_static = check_token (STATIC); - if (check_token (BASED)) - { - expect(LPRN, "BASED must be followed by (NAME)"); - do_based_decls (names, mode, parse_name_string ()); - expect(RPRN, "BASED must be followed by (NAME)"); - return; - } - if (check_token (LOC)) - { - /* loc-identity declaration */ - if (pass == 1) - mode = build_chill_reference_type (mode); - loc_decl = 1; - } - lifetime_bound = check_token (INIT); - if (lifetime_bound && loc_decl) - { - if (pass == 1) - error ("INIT not allowed at loc-identity declaration"); - lifetime_bound = 0; - } - if (PEEK_TOKEN () == ASGN || PEEK_TOKEN() == EQL) - { - save_ignoring = ignoring; - ignoring = pass == 1; - if (PEEK_TOKEN() == EQL) - { - if (pass == 1) - error ("'=' used where ':=' is required"); - } - FORWARD_TOKEN(); - if (! lifetime_bound) - push_handler (); - init_value = parse_untyped_expr (); - if (in_spec_module) - { - error ("initialization is not allowed in spec module"); - init_value = NULL_TREE; - } - if (! lifetime_bound) - parse_opt_handler (); - ignoring = save_ignoring; - } - if (init_value == NULL_TREE && loc_decl && pass == 1) - error ("loc-identity declaration without initialisation"); - do_decls (names, mode, - is_static || global_bindings_p () - /* the variable becomes STATIC if all_static_flag is set and - current functions doesn't have the RECURSIVE attribute */ - || (all_static_flag && !CH_DECL_RECURSIVE (current_function_decl)), - lifetime_bound, init_value, in_spec_module); - - /* Free any temporaries we made while initializing the decl. */ - free_temp_slots (); -} - -static void -parse_declaration_statement (in_spec_module) - int in_spec_module; -{ - int save_ignoring = ignoring; - ignoring = pass == 2; - require (DCL); - parse_loc_declaration (in_spec_module); - while (PEEK_TOKEN () == COMMA) - { - FORWARD_TOKEN (); - parse_loc_declaration (in_spec_module); - } - ignoring = save_ignoring; - parse_semi_colon (); -} - -static tree -parse_optforbid () -{ - if (check_token (FORBID) == 0) - return NULL_TREE; - if (check_token (ALL)) - return ignoring ? NULL_TREE : build_int_2 (-1, -1); -#if 0 - if (check_token (LPRN)) - { - tree list = parse_forbidlist (); - expect (RPRN, "missing ')' after FORBID list"); - return list; - } -#endif - error ("bad syntax following FORBID"); - return NULL_TREE; -} - -/* Matches: <grant postfix> or <seize postfix> - Returns: A (singleton) TREE_LIST. */ - -static tree -parse_postfix (grant_or_seize) - enum terminal grant_or_seize; -{ - tree name = parse_opt_name_string (1); - tree forbid = NULL_TREE; - if (name == NULL_TREE) - { - error ("expected a postfix name here"); - name = error_mark_node; - } - if (grant_or_seize == GRANT) - forbid = parse_optforbid (); - return build_tree_list (forbid, name); -} - -static tree -parse_postfix_list (grant_or_seize) - enum terminal grant_or_seize; -{ - tree list = parse_postfix (grant_or_seize); - while (check_token (COMMA)) - list = chainon (list, parse_postfix (grant_or_seize)); - return list; -} - -static void -parse_rename_clauses (grant_or_seize) - enum terminal grant_or_seize; -{ - for (;;) - { - tree rename_old_prefix, rename_new_prefix, postfix; - require (LPRN); - rename_old_prefix = parse_opt_name_string (0); - expect (ARROW, "missing '->' in rename clause"); - rename_new_prefix = parse_opt_name_string (0); - expect (RPRN, "missing ')' in rename clause"); - expect ('!', "missing '!' in rename clause"); - postfix = parse_postfix (grant_or_seize); - - if (grant_or_seize == GRANT) - chill_grant (rename_old_prefix, rename_new_prefix, - TREE_VALUE (postfix), TREE_PURPOSE (postfix)); - else - chill_seize (rename_old_prefix, rename_new_prefix, - TREE_VALUE (postfix)); - - if (PEEK_TOKEN () != COMMA) - break; - FORWARD_TOKEN (); - if (PEEK_TOKEN () != LPRN) - { - error ("expected another rename clause"); - break; - } - } -} - -static tree -parse_opt_prefix_clause () -{ - if (check_token (PREFIXED) == 0) - return NULL_TREE; - return build_prefix_clause (parse_opt_name_string (0)); -} - -static void -parse_grant_statement () -{ - require (GRANT); - if (PEEK_TOKEN () == LPRN) - parse_rename_clauses (GRANT); - else - { - tree window = parse_postfix_list (GRANT); - tree new_prefix = parse_opt_prefix_clause (); - tree t; - for (t = window; t; t = TREE_CHAIN (t)) - chill_grant (NULL_TREE, new_prefix, TREE_VALUE (t), TREE_PURPOSE (t)); - } -} - -static void -parse_seize_statement () -{ - require (SEIZE); - if (PEEK_TOKEN () == LPRN) - parse_rename_clauses (SEIZE); - else - { - tree seize_window = parse_postfix_list (SEIZE); - tree old_prefix = parse_opt_prefix_clause (); - tree t; - for (t = seize_window; t; t = TREE_CHAIN (t)) - chill_seize (old_prefix, NULL_TREE, TREE_VALUE (t)); - } -} - -/* In pass 1, this returns a TREE_LIST, one node for each parameter. - In pass 2, we get a list of PARM_DECLs chained together. - In either case, the list is in reverse order. */ - -static tree -parse_param_name_list () -{ - tree list = NULL_TREE; - do - { - tree new_link; - tree name = parse_defining_occurrence (); - if (name == NULL_TREE) - { - error ("syntax error in parameter name list"); - return list; - } - if (pass == 1) - new_link = build_tree_list (NULL_TREE, name); - /* else if (current_module->is_spec_module) ; nothing */ - else /* pass == 2 */ - { - new_link = make_node (PARM_DECL); - DECL_NAME (new_link) = name; - DECL_ASSEMBLER_NAME (new_link) = name; - } - - TREE_CHAIN (new_link) = list; - list = new_link; - } while (check_token (COMMA)); - return list; -} - -static tree -parse_param_attr () -{ - tree attr; - switch (PEEK_TOKEN ()) - { - case PARAMATTR: /* INOUT is returned here */ - attr = PEEK_TREE (); - FORWARD_TOKEN (); - return attr; - case IN: - FORWARD_TOKEN (); - return ridpointers[(int) RID_IN]; - case LOC: - FORWARD_TOKEN (); - return ridpointers[(int) RID_LOC]; -#if 0 - case DYNAMIC: - FORWARD_TOKEN (); - return ridpointers[(int) RID_DYNAMIC]; -#endif - default: - return NULL_TREE; - } -} - -/* We wrap CHILL array parameters in a STRUCT. The original parameter - name is unpacked from the struct at get_identifier time */ - -/* In pass 1, returns list of types; in pass 2: chain of PARM_DECLs. */ - -static tree -parse_formpar () -{ - tree names = parse_param_name_list (); - tree mode = parse_mode (); - tree paramattr = parse_param_attr (); - return chill_munge_params (nreverse (names), mode, paramattr); -} - -/* - * Note: build_process_header depends upon the *exact* - * representation of STRUCT fields and of formal parameter - * lists. If either is changed, build_process_header will - * also need change. Push_extern_process is affected as well. - */ -static tree -parse_formparlist () -{ - tree list = NULL_TREE; - if (PEEK_TOKEN() == RPRN) - return NULL_TREE; - for (;;) - { - list = chainon (list, parse_formpar ()); - if (! check_token (COMMA)) - break; - } - return list; -} - -static tree -parse_opt_result_spec () -{ - tree mode; - int is_nonref, is_loc, is_dynamic; - if (!check_token (RETURNS)) - return void_type_node; - expect (LPRN, "expected '(' after RETURNS"); - mode = parse_mode (); - is_nonref = check_token (NONREF); - is_loc = check_token (LOC); - is_dynamic = check_token (DYNAMIC); - if (is_nonref && !is_loc) - error ("NONREF specific without LOC in result attribute"); - if (is_dynamic && !is_loc) - error ("DYNAMIC specific without LOC in result attribute"); - mode = get_type_of (mode); - if (is_loc && ! ignoring) - mode = build_chill_reference_type (mode); - expect (RPRN, "expected ')' after RETURNS"); - return mode; -} - -static tree -parse_opt_except () -{ - tree list = NULL_TREE; - if (!check_token (EXCEPTIONS)) - return NULL_TREE; - expect (LPRN, "expected '(' after EXCEPTIONS"); - do - { - tree except_name = parse_name_string (); - tree name; - for (name = list; name != NULL_TREE; name = TREE_CHAIN (name)) - if (TREE_VALUE (name) == except_name && pass == 1) - { - error ("exception names must be unique"); - break; - } - if (name == NULL_TREE && !ignoring) - list = tree_cons (NULL_TREE, except_name, list); - } while (check_token (COMMA)); - expect (RPRN, "expected ')' after EXCEPTIONS"); - return list; -} - -static tree -parse_opt_recursive () -{ - if (check_token (RECURSIVE)) - return ridpointers[RID_RECURSIVE]; - else - return NULL_TREE; -} - -static tree -parse_procedureattr () -{ - tree generality; - tree optrecursive; - switch (PEEK_TOKEN ()) - { - case GENERAL: - FORWARD_TOKEN (); - generality = ridpointers[RID_GENERAL]; - break; - case SIMPLE: - FORWARD_TOKEN (); - generality = ridpointers[RID_SIMPLE]; - break; - case INLINE: - FORWARD_TOKEN (); - generality = ridpointers[RID_INLINE]; - break; - default: - generality = NULL_TREE; - } - optrecursive = parse_opt_recursive (); - if (pass != 1) - return NULL_TREE; - if (generality) - generality = build_tree_list (NULL_TREE, generality); - if (optrecursive) - generality = tree_cons (NULL_TREE, optrecursive, generality); - return generality; -} - -/* Parse the body and last part of a procedure or process definition. */ - -static void -parse_proc_body (name, exceptions) - tree name; - tree exceptions; -{ - int save_proc_action_level = proc_action_level; - proc_action_level = action_nesting_level; - if (exceptions != NULL_TREE) - /* set up a handler for reraising exceptions */ - push_handler (); - push_action (); - define__PROCNAME__ (); - parse_body (); - proc_action_level = save_proc_action_level; - expect (END, "'END' was expected here"); - parse_opt_handler (); - if (exceptions != NULL_TREE) - chill_reraise_exceptions (exceptions); - parse_opt_end_label_semi_colon (name); - end_function (); -} - -static void -parse_procedure_definition (in_spec_module) - int in_spec_module; -{ - int save_ignoring = ignoring; - tree name = parse_defining_occurrence (); - tree params, result, exceptlist, attributes; - int save_chill_at_module_level = chill_at_module_level; - chill_at_module_level = 0; - if (!in_spec_module) - ignoring = pass == 2; - require (COLON); require (PROC); - expect (LPRN, "missing '(' after PROC"); - params = parse_formparlist (); - expect (RPRN, "missing ')' in PROC"); - result = parse_opt_result_spec (); - exceptlist = parse_opt_except (); - attributes = parse_procedureattr (); - ignoring = save_ignoring; - if (in_spec_module) - { - expect (END, "missing 'END'"); - parse_opt_end_label_semi_colon (name); - push_extern_function (name, result, params, exceptlist, 0); - return; - } - push_chill_function_context (); - start_chill_function (name, result, params, exceptlist, attributes); - current_module->procedure_seen = 1; - parse_proc_body (name, TYPE_RAISES_EXCEPTIONS (TREE_TYPE (current_function_decl))); - chill_at_module_level = save_chill_at_module_level; -} - -static tree -parse_processpar () -{ - tree names = parse_defining_occurrence_list (); - tree mode = parse_mode (); - tree paramattr = parse_param_attr (); - - if (names && TREE_CODE (names) == IDENTIFIER_NODE) - names = build_tree_list (NULL_TREE, names); - return tree_cons (tree_cons (paramattr, mode, NULL_TREE), names, NULL_TREE); -} - -static tree -parse_processparlist () -{ - tree list = NULL_TREE; - if (PEEK_TOKEN() == RPRN) - return NULL_TREE; - for (;;) - { - list = chainon (list, parse_processpar ()); - if (! check_token (COMMA)) - break; - } - return list; -} - -static void -parse_process_definition (in_spec_module) - int in_spec_module; -{ - int save_ignoring = ignoring; - tree name = parse_defining_occurrence (); - tree params; - tree tmp; - if (!in_spec_module) - ignoring = 0; - require (COLON); require (PROCESS); - expect (LPRN, "missing '(' after PROCESS"); - params = parse_processparlist (); - expect (RPRN, "missing ')' in PROCESS"); - ignoring = save_ignoring; - if (in_spec_module) - { - expect (END, "missing 'END'"); - parse_opt_end_label_semi_colon (name); - push_extern_process (name, params, NULL_TREE, 0); - return; - } - tmp = build_process_header (name, params); - parse_proc_body (name, NULL_TREE); - build_process_wrapper (name, tmp); -} - -static void -parse_signal_definition () -{ - tree signame = parse_defining_occurrence (); - tree modes = NULL_TREE; - tree dest = NULL_TREE; - - if (check_token (EQL)) - { - expect (LPRN, "missing '(' after 'SIGNAL <name> ='"); - for (;;) - { - tree mode = parse_mode (); - modes = tree_cons (NULL_TREE, mode, modes); - if (! check_token (COMMA)) - break; - } - expect (RPRN, "missing ')'"); - modes = nreverse (modes); - } - - if (check_token (TO)) - { - tree decl; - int save_ignoring = ignoring; - ignoring = 0; - decl = parse_name (); - ignoring = save_ignoring; - if (pass > 1) - { - if (decl == NULL_TREE - || TREE_CODE (decl) == ERROR_MARK - || TREE_CODE (decl) != FUNCTION_DECL - || !CH_DECL_PROCESS (decl)) - error ("must specify a PROCESS name"); - else - dest = decl; - } - } - - if (! global_bindings_p ()) - error ("SIGNAL must be in global reach"); - else - { - tree struc = build_signal_struct_type (signame, modes, dest); - tree decl = - generate_tasking_code_variable (signame, - &signal_code, - current_module->is_spec_module); - /* remember the code variable in the struct type */ - DECL_TASKING_CODE_DECL (struc) = (struct lang_decl *)decl; - CH_DECL_SIGNAL (struc) = 1; - add_taskstuff_to_list (decl, "_TT_Signal", - current_module->is_spec_module ? - NULL_TREE : signal_code, struc, NULL_TREE); - } - -} - -static void -parse_signal_definition_statement () -{ - int save_ignoring = ignoring; - ignoring = pass == 2; - require (SIGNAL); - for (;;) - { - parse_signal_definition (); - if (! check_token (COMMA)) - break; - if (PEEK_TOKEN () == SC) - { - error ("syntax error while parsing signal definition statement"); - break; - } - } - parse_semi_colon (); - ignoring = save_ignoring; -} - -static int -parse_definition (in_spec_module) - int in_spec_module; -{ - switch (PEEK_TOKEN ()) - { - case NAME: - if (PEEK_TOKEN1() == COLON) - { - if (PEEK_TOKEN2() == PROC) - { - parse_procedure_definition (in_spec_module); - return 1; - } - else if (PEEK_TOKEN2() == PROCESS) - { - parse_process_definition (in_spec_module); - return 1; - } - } - return 0; - case DCL: - parse_declaration_statement(in_spec_module); - break; - case GRANT: - parse_grant_statement (); - break; - case NEWMODE: - parse_mode_definition_statement(1); - break; - case SC: - label = NULL_TREE; - FORWARD_TOKEN(); - return 1; - case SEIZE: - parse_seize_statement (); - break; - case SIGNAL: - parse_signal_definition_statement (); - break; - case SYN: - parse_synonym_definition_statement(); - break; - case SYNMODE: - parse_mode_definition_statement(0); - break; - default: - return 0; - } - return 1; -} - -static void -parse_then_clause () -{ - expect (THEN, "expected 'THEN' after 'IF'"); - if (! ignoring) - emit_line_note (input_filename, lineno); - parse_opt_actions (); -} - -static void -parse_opt_else_clause () -{ - while (check_token (ELSIF)) - { - tree cond = parse_expression (); - if (! ignoring) - expand_start_elseif (truthvalue_conversion (cond)); - parse_then_clause (); - } - if (check_token (ELSE)) - { - if (! ignoring) - { emit_line_note (input_filename, lineno); - expand_start_else (); - } - parse_opt_actions (); - } -} - -static tree parse_expr_list () -{ - tree expr = parse_expression (); - tree list = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr); - while (check_token (COMMA)) - { - expr = parse_expression (); - if (! ignoring) - list = tree_cons (NULL_TREE, expr, list); - } - return list; -} - -static tree -parse_range_list_clause () -{ - tree name = parse_opt_name_string (0); - if (name == NULL_TREE) - return NULL_TREE; - while (check_token (COMMA)) - { - name = parse_name_string (); - } - if (check_token (SC)) - { - sorry ("case range list"); - return error_mark_node; - } - pushback_token (NAME, name); - return NULL_TREE; -} - -static void -pushback_paren_expr (expr) - tree expr; -{ - if (pass == 1 && !ignoring) - expr = build1 (PAREN_EXPR, NULL_TREE, expr); - pushback_token (EXPR, expr); -} - -/* Matches: <case label> */ - -static tree -parse_case_label () -{ - tree expr; - if (check_token (ELSE)) - return case_else_node; - /* Does this also handle the case of a mode name? FIXME */ - expr = parse_expression (); - if (check_token (COLON)) - { - tree max_expr = parse_expression (); - if (! ignoring) - expr = build (RANGE_EXPR, NULL_TREE, expr, max_expr); - } - return expr; -} - -/* Parses: <case_label_list> - Fails if not followed by COMMA or COLON. - If it fails, it backs up if needed, and returns NULL_TREE. - IN_TUPLE is true if we are parsing a tuple element, - and 0 if we are parsing a case label specification. */ - -static tree -parse_case_label_list (selector, in_tuple) - tree selector; - int in_tuple; -{ - tree expr, list; - if (! check_token (LPRN)) - return NULL_TREE; - if (check_token (MUL)) - { - expect (RPRN, "missing ')' after '*' case label list"); - if (ignoring) - return integer_zero_node; - expr = build (RANGE_EXPR, NULL_TREE, NULL_TREE, NULL_TREE); - expr = build_tree_list (NULL_TREE, expr); - return expr; - } - expr = parse_case_label (); - if (check_token (RPRN)) - { - if ((in_tuple || PEEK_TOKEN () != COMMA) && PEEK_TOKEN () != COLON) - { - /* Ooops! It looks like it was the start of an action or - unlabelled tuple element, and not a case label, so back up. */ - if (expr != NULL_TREE && TREE_CODE (expr) == RANGE_EXPR) - { - error ("misplaced colon in case label"); - expr = error_mark_node; - } - pushback_paren_expr (expr); - return NULL_TREE; - } - list = build_tree_list (NULL_TREE, expr); - if (expr == case_else_node && selector != NULL_TREE) - ELSE_LABEL_SPECIFIED (selector) = 1; - return list; - } - list = build_tree_list (NULL_TREE, expr); - if (expr == case_else_node && selector != NULL_TREE) - ELSE_LABEL_SPECIFIED (selector) = 1; - - while (check_token (COMMA)) - { - expr = parse_case_label (); - list = tree_cons (NULL_TREE, expr, list); - if (expr == case_else_node && selector != NULL_TREE) - ELSE_LABEL_SPECIFIED (selector) = 1; - } - expect (RPRN, "missing ')' at end of case label list"); - return nreverse (list); -} - -/* Parses: <case_label_specification> - Must be followed by a COLON. - If it fails, it backs up if needed, and returns NULL_TREE. */ - -static tree -parse_case_label_specification (selectors) - tree selectors; -{ - tree list_list = NULL_TREE; - tree list; - list = parse_case_label_list (selectors, 0); - if (list == NULL_TREE) - return NULL_TREE; - list_list = build_tree_list (NULL_TREE, list); - while (check_token (COMMA)) - { - if (selectors != NULL_TREE) - selectors = TREE_CHAIN (selectors); - list = parse_case_label_list (selectors, 0); - if (list == NULL_TREE) - { - error ("unrecognized case label list after ','"); - return list_list; - } - list_list = tree_cons (NULL_TREE, list, list_list); - } - return nreverse (list_list); -} - -static void -parse_single_dimension_case_action (selector) - tree selector; -{ - int no_completeness_check = 0; - -/* The case label/action toggle. It is 0 initially, and when an action - was last seen. It is 1 integer_zero_node when a label was last seen. */ - int caseaction_flag = 0; - - if (! ignoring) - { - expand_exit_needed = 0; - selector = check_case_selector (selector); - expand_start_case (1, selector, TREE_TYPE (selector), "CASE statement"); - push_momentary (); - } - - for (;;) - { - tree label_spec = parse_case_label_specification (selector); - if (label_spec != NULL_TREE) - { - expect (COLON, "missing ':' in case alternative"); - if (! ignoring) - { - no_completeness_check |= chill_handle_single_dimension_case_label ( - selector, label_spec, &expand_exit_needed, &caseaction_flag); - } - } - else if (parse_action ()) - { - expand_exit_needed = 1; - caseaction_flag = 0; - } - else - break; - } - - if (! ignoring) - { - if (expand_exit_needed || caseaction_flag == 1) - expand_exit_something (); - } - if (check_token (ELSE)) - { - if (! ignoring) - chill_handle_case_default (); - parse_opt_actions (); - if (! ignoring) - { - emit_line_note (input_filename, lineno); - expand_exit_something (); - } - } - else if (! ignoring && TREE_CODE (selector) != ERROR_MARK && - ! no_completeness_check) - check_missing_cases (TREE_TYPE (selector)); - - expect (ESAC, "missing 'ESAC' after 'CASE'"); - if (! ignoring) - { - expand_end_case (selector); - pop_momentary (); - } -} - -static void -parse_multi_dimension_case_action (selector) - tree selector; -{ - struct rtx_def *begin_test_label = 0, *end_case_label = 0, *new_label; - tree action_labels = NULL_TREE; - tree tests = NULL_TREE; - int save_lineno = lineno; - const char *save_filename = input_filename; - - /* We can't compute the range of an (ELSE) label until all of the CASE - label specifications have been seen, however, the code for the actions - between them is generated on the fly. We can still generate everything in - one pass is we use the following form: - - Compile a CASE of the form - - case S1,...,Sn of - (X11),...,(X1n): A1; - ... - (Xm1),...,(Xmn): Am; - else Ae; - esac; - - into: - - goto L0; - L1: A1; goto L99; - ... - Lm: Am; goto L99; - Le: Ae; goto L99; - L0: - T1 := s1; ...; Tn := Sn; - if (T1 = X11 and ... and Tn = X1n) GOTO L1; - ... - if (T1 = Xm1 and ... and Tn = Xmn) GOTO Lm; - GOTO Le; - L99; - */ - - if (! ignoring) - { - selector = check_case_selector_list (selector); - begin_test_label = gen_label_rtx (); - end_case_label = gen_label_rtx (); - emit_jump (begin_test_label); - } - - for (;;) - { - tree label_spec = parse_case_label_specification (selector); - if (label_spec != NULL_TREE) - { - expect (COLON, "missing ':' in case alternative"); - if (! ignoring) - { - tests = tree_cons (label_spec, NULL_TREE, tests); - - if (action_labels != NULL_TREE) - emit_jump (end_case_label); - - new_label = gen_label_rtx (); - emit_label (new_label); - emit_line_note (input_filename, lineno); - action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels); - TREE_CST_RTL (action_labels) = new_label; - } - } - else if (! parse_action ()) - { - if (action_labels != NULL_TREE) - emit_jump (end_case_label); - break; - } - } - - if (check_token (ELSE)) - { - if (! ignoring) - { - new_label = gen_label_rtx (); - emit_label (new_label); - emit_line_note (input_filename, lineno); - action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels); - TREE_CST_RTL (action_labels) = new_label; - } - parse_opt_actions (); - if (! ignoring) - emit_jump (end_case_label); - } - - expect (ESAC, "missing 'ESAC' after 'CASE'"); - - if (! ignoring) - { - emit_label (begin_test_label); - emit_line_note (save_filename, save_lineno); - if (tests != NULL_TREE) - { - tree cond; - tests = nreverse (tests); - action_labels = nreverse (action_labels); - compute_else_ranges (selector, tests); - - cond = build_multi_case_selector_expression (selector, TREE_PURPOSE (tests)); - expand_start_cond (truthvalue_conversion (cond), label ? 1 : 0); - emit_jump (TREE_CST_RTL (action_labels)); - - for (tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels); - tests != NULL_TREE && action_labels != NULL_TREE; - tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels)) - { - cond = - build_multi_case_selector_expression (selector, TREE_PURPOSE (tests)); - expand_start_elseif (truthvalue_conversion (cond)); - emit_jump (TREE_CST_RTL (action_labels)); - } - if (action_labels != NULL_TREE) - { - expand_start_else (); - emit_jump (TREE_CST_RTL (action_labels)); - } - expand_end_cond (); - } - emit_label (end_case_label); - } -} - -static void -parse_case_action (label) - tree label; -{ - tree selector; - int multi_dimension_case = 0; - - require (CASE); - selector = parse_expr_list (); - selector = nreverse (selector); - expect (OF, "missing 'OF' after 'CASE'"); - parse_range_list_clause (); - - PUSH_ACTION; - if (label) - pushlevel (1); - - if (! ignoring) - { - expand_exit_needed = 0; - if (TREE_CODE (selector) == TREE_LIST) - { - if (TREE_CHAIN (selector) != NULL_TREE) - multi_dimension_case = 1; - else - selector = TREE_VALUE (selector); - } - } - - /* We want to use the regular CASE support for the single dimension case. The - multi dimension case requires different handling. Note that when "ignoring" - is true we parse using the single dimension code. This is OK since it will - still parse correctly. */ - if (multi_dimension_case) - parse_multi_dimension_case_action (selector); - else - parse_single_dimension_case_action (selector); - - if (label) - { - possibly_define_exit_label (label); - poplevel (0, 0, 0); - } -} - -/* Matches: [ <asm_operand> { "," <asm_operand> }* ], - where <asm_operand> = STRING '(' <expression> ')' - These are the operands other than the first string and colon - in asm ("addextend %2,%1": "=dm" (x), "0" (y), "g" (*x)) */ - -static tree -parse_asm_operands () -{ - tree list = NULL_TREE; - if (PEEK_TOKEN () != STRING) - return NULL_TREE; - for (;;) - { - tree string, expr; - if (PEEK_TOKEN () != STRING) - { - error ("bad ASM operand"); - return list; - } - string = PEEK_TREE(); - FORWARD_TOKEN (); - expect (LPRN, "missing '(' in ASM operand"); - expr = parse_expression (); - expect (RPRN, "missing ')' in ASM operand"); - list = tree_cons (string, expr, list); - if (! check_token (COMMA)) - break; - } - return nreverse (list); -} - -/* Matches: STRING { ',' STRING }* */ - -static tree -parse_asm_clobbers () -{ - tree list = NULL_TREE; - for (;;) - { - tree string; - if (PEEK_TOKEN () != STRING) - { - error ("bad ASM operand"); - return list; - } - string = PEEK_TREE(); - FORWARD_TOKEN (); - list = tree_cons (NULL_TREE, string, list); - if (! check_token (COMMA)) - break; - } - return list; -} - -static void -ch_expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line) - tree string, outputs, inputs, clobbers; - int vol; - const char *filename; - int line; -{ - int noutputs = list_length (outputs); - register int i; - /* o[I] is the place that output number I should be written. */ - register tree *o = (tree *) alloca (noutputs * sizeof (tree)); - register tree tail; - - if (TREE_CODE (string) == ADDR_EXPR) - string = TREE_OPERAND (string, 0); - if (TREE_CODE (string) != STRING_CST) - { - error ("asm template is not a string constant"); - return; - } - - /* Record the contents of OUTPUTS before it is modified. */ - for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++) - o[i] = TREE_VALUE (tail); - -#if 0 - /* Perform default conversions on array and function inputs. */ - /* Don't do this for other types-- - it would screw up operands expected to be in memory. */ - for (i = 0, tail = inputs; tail; tail = TREE_CHAIN (tail), i++) - if (TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == FUNCTION_TYPE) - TREE_VALUE (tail) = default_conversion (TREE_VALUE (tail)); -#endif - - /* Generate the ASM_OPERANDS insn; - store into the TREE_VALUEs of OUTPUTS some trees for - where the values were actually stored. */ - expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line); - - /* Copy all the intermediate outputs into the specified outputs. */ - for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++) - { - if (o[i] != TREE_VALUE (tail)) - { - expand_expr (build_chill_modify_expr (o[i], TREE_VALUE (tail)), - 0, VOIDmode, 0); - free_temp_slots (); - } - /* Detect modification of read-only values. - (Otherwise done by build_modify_expr.) */ - else - { - tree type = TREE_TYPE (o[i]); - if (TYPE_READONLY (type) - || ((TREE_CODE (type) == RECORD_TYPE - || TREE_CODE (type) == UNION_TYPE) - && TYPE_FIELDS_READONLY (type))) - warning ("readonly location modified by 'asm'"); - } - } - - /* Those MODIFY_EXPRs could do autoincrements. */ - emit_queue (); -} - -static void -parse_asm_action () -{ - tree insn; - require (ASM_KEYWORD); - expect (LPRN, "missing '('"); - PUSH_ACTION; - if (!ignoring) - emit_line_note (input_filename, lineno); - insn = parse_expression (); - if (check_token (COLON)) - { - tree output_operand, input_operand, clobbered_regs; - output_operand = parse_asm_operands (); - if (check_token (COLON)) - input_operand = parse_asm_operands (); - else - input_operand = NULL_TREE; - if (check_token (COLON)) - clobbered_regs = parse_asm_clobbers (); - else - clobbered_regs = NULL_TREE; - expect (RPRN, "missing ')'"); - if (!ignoring) - ch_expand_asm_operands (insn, output_operand, input_operand, - clobbered_regs, FALSE, - input_filename, lineno); - } - else - { - expect (RPRN, "missing ')'"); - STRIP_NOPS (insn); - if (ignoring) { } - else if ((TREE_CODE (insn) == ADDR_EXPR - && TREE_CODE (TREE_OPERAND (insn, 0)) == STRING_CST) - || TREE_CODE (insn) == STRING_CST) - expand_asm (insn); - else - error ("argument of `asm' is not a constant string"); - } -} - -static void -parse_begin_end_block (label) - tree label; -{ - require (BEGINTOKEN); -#if 0 - /* don't make a linenote at BEGIN */ - INIT_ACTION; -#endif - pushlevel (1); - if (! ignoring) - { - clear_last_expr (); - push_momentary (); - expand_start_bindings (label ? 1 : 0); - } - push_handler (); - parse_body (); - expect (END, "missing 'END'"); - /* Note that the opthandler comes before the poplevel - - hence a handler is in the scope of the block. */ - parse_opt_handler (); - possibly_define_exit_label (label); - if (! ignoring) - { - emit_line_note (input_filename, lineno); - expand_end_bindings (getdecls (), kept_level_p (), 0); - } - poplevel (kept_level_p (), 0, 0); - if (! ignoring) - pop_momentary (); - parse_opt_end_label_semi_colon (label); -} - -static void -parse_if_action (label) - tree label; -{ - tree cond; - require (IF); - PUSH_ACTION; - cond = parse_expression (); - if (label) - pushlevel (1); - if (! ignoring) - { - expand_start_cond (truthvalue_conversion (cond), - label ? 1 : 0); - } - parse_then_clause (); - parse_opt_else_clause (); - expect (FI, "expected 'FI' after 'IF'"); - if (! ignoring) - { - emit_line_note (input_filename, lineno); - expand_end_cond (); - } - if (label) - { - possibly_define_exit_label (label); - poplevel (0, 0, 0); - } -} - -/* Matches: <iteration> (as in a <for control>). */ - -static void -parse_iteration () -{ - tree loop_counter = parse_defining_occurrence (); - if (check_token (ASGN)) - { - tree start_value = parse_expression (); - tree step_value - = check_token (BY) ? parse_expression () : NULL_TREE; - int going_down = check_token (DOWN); - tree end_value; - if (check_token (TO)) - end_value = parse_expression (); - else - { - error ("expected 'TO' in step enumeration"); - end_value = error_mark_node; - } - if (!ignoring) - build_loop_iterator (loop_counter, start_value, step_value, - end_value, going_down, 0, 0); - } - else - { - int going_down = check_token (DOWN); - tree expr; - if (check_token (IN)) - expr = parse_expression (); - else - { - error ("expected 'IN' in FOR control here"); - expr = error_mark_node; - } - if (!ignoring) - { - tree low_bound, high_bound; - if (expr && TREE_CODE (expr) == TYPE_DECL) - { - expr = TREE_TYPE (expr); - /* FIXME: expr must be an array or powerset */ - low_bound = convert (expr, TYPE_MIN_VALUE (expr)); - high_bound = convert (expr, TYPE_MAX_VALUE (expr)); - } - else - { - low_bound = expr; - high_bound = NULL_TREE; - } - build_loop_iterator (loop_counter, low_bound, - NULL_TREE, high_bound, - going_down, 1, 0); - } - } -} - -/* Matches: '(' <event list> ')' ':'. - Or; returns NULL_EXPR. */ - -static tree -parse_delay_case_event_list () -{ - tree event_list = NULL_TREE; - tree event; - if (! check_token (LPRN)) - return NULL_TREE; - event = parse_expression (); - if (PEEK_TOKEN () == ')' && PEEK_TOKEN1 () != ':') - { - /* Oops. */ - require (RPRN); - pushback_paren_expr (event); - return NULL_TREE; - } - for (;;) - { - if (! ignoring) - event_list = tree_cons (NULL_TREE, event, event_list); - if (! check_token (COMMA)) - break; - event = parse_expression (); - } - expect (RPRN, "missing ')'"); - expect (COLON, "missing ':'"); - return ignoring ? error_mark_node : event_list; -} - -static void -parse_delay_case_action (label) - tree label; -{ - tree label_cnt = NULL_TREE, set_location, priority; - tree combined_event_list = NULL_TREE; - require (DELAY); - require (CASE); - PUSH_ACTION; - pushlevel (1); - expand_exit_needed = 0; - if (check_token (SET)) - { - set_location = parse_expression (); - parse_semi_colon (); - } - else - set_location = NULL_TREE; - if (check_token (PRIORITY)) - { - priority = parse_expression (); - parse_semi_colon (); - } - else - priority = NULL_TREE; - if (! ignoring) - label_cnt = build_delay_case_start (set_location, priority); - for (;;) - { - tree event_list = parse_delay_case_event_list (); - if (event_list) - { - if (! ignoring ) - { - int if_or_elseif = combined_event_list == NULL_TREE; - build_delay_case_label (event_list, if_or_elseif); - combined_event_list = chainon (combined_event_list, event_list); - } - } - else if (parse_action ()) - { - if (! ignoring) - { - expand_exit_needed = 1; - if (combined_event_list == NULL_TREE) - error ("missing DELAY CASE alternative"); - } - } - else - break; - } - expect (ESAC, "missing 'ESAC' in DELAY CASE'"); - if (! ignoring) - build_delay_case_end (combined_event_list); - possibly_define_exit_label (label); - poplevel (0, 0, 0); -} - -static void -parse_do_action (label) - tree label; -{ - tree condition; - int token; - require (DO); - if (check_token (WITH)) - { - tree list = NULL_TREE; - for (;;) - { - tree name = parse_primval (); - if (! ignoring && TREE_CODE (name) != ERROR_MARK) - { - if (TREE_CODE (TREE_TYPE (name)) == REFERENCE_TYPE) - name = convert (TREE_TYPE (TREE_TYPE (name)), name); - else - { - int is_loc = chill_location (name); - if (is_loc == 1) /* This is probably not possible */ - warning ("non-referable location in DO WITH"); - - if (is_loc > 1) - name = build_chill_arrow_expr (name, 1); - name = decl_temp1 (get_identifier ("__with_element"), - TREE_TYPE (name), - 0, name, 0, 0); - if (is_loc > 1) - name = build_chill_indirect_ref (name, NULL_TREE, 0); - - } - if (TREE_CODE (TREE_TYPE (name)) != RECORD_TYPE) - error ("WITH element must be of STRUCT mode"); - else - list = tree_cons (NULL_TREE, name, list); - } - if (! check_token (COMMA)) - break; - } - pushlevel (1); - push_action (); - for (list = nreverse (list); list != NULL_TREE; list = TREE_CHAIN (list)) - shadow_record_fields (TREE_VALUE (list)); - - parse_semi_colon (); - parse_opt_actions (); - expect (OD, "missing 'OD' in 'DO WITH'"); - if (! ignoring) - emit_line_note (input_filename, lineno); - possibly_define_exit_label (label); - parse_opt_handler (); - parse_opt_end_label_semi_colon (label); - poplevel (0, 0, 0); - return; - } - token = PEEK_TOKEN(); - if (token != FOR && token != WHILE) - { - push_handler (); - parse_opt_actions (); - expect (OD, "Missing 'OD' after 'DO'"); - parse_opt_handler (); - parse_opt_end_label_semi_colon (label); - return; - } - if (! ignoring) - emit_line_note (input_filename, lineno); - push_loop_block (); - if (check_token (FOR)) - { - if (check_token (EVER)) - { - if (!ignoring) - build_loop_iterator (NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, - 0, 0, 1); - } - else - { - parse_iteration (); - while (check_token (COMMA)) - parse_iteration (); - } - } - else if (!ignoring) - build_loop_iterator (NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, - 0, 0, 1); - - begin_loop_scope (); - if (! ignoring) - build_loop_start (label); - condition = check_token (WHILE) ? parse_expression () : NULL_TREE; - if (! ignoring) - top_loop_end_check (condition); - parse_semi_colon (); - parse_opt_actions (); - if (! ignoring) - build_loop_end (); - expect (OD, "Missing 'OD' after 'DO'"); - /* Note that the handler is inside the reach of the DO. */ - parse_opt_handler (); - end_loop_scope (label); - pop_loop_block (); - parse_opt_end_label_semi_colon (label); -} - -/* Matches: '(' <signal name> [ 'IN' <defining occurrence list> ']' ')' ':' - or: '(' <buffer location> IN (defining occurrence> ')' ':' - or: returns NULL_TREE. */ - -static tree -parse_receive_spec () -{ - tree val; - tree name_list = NULL_TREE; - if (!check_token (LPRN)) - return NULL_TREE; - val = parse_primval (); - if (check_token (IN)) - { -#if 0 - if (flag_local_loop_counter) - name_list = parse_defining_occurrence_list (); - else -#endif - { - for (;;) - { - tree loc = parse_primval (); - if (! ignoring) - name_list = tree_cons (NULL_TREE, loc, name_list); - if (! check_token (COMMA)) - break; - } - } - } - if (! check_token (RPRN)) - { - error ("missing ')' in signal/buffer receive alternative"); - return NULL_TREE; - } - if (check_token (COLON)) - { - if (ignoring || val == NULL_TREE || TREE_CODE (val) == ERROR_MARK) - return error_mark_node; - else - return build_receive_case_label (val, name_list); - } - - /* We saw: '(' <primitive value> ')' not followed by ':'. - Presumably the start of an action. Backup and fail. */ - if (name_list != NULL_TREE) - error ("misplaced 'IN' in signal/buffer receive alternative"); - pushback_paren_expr (val); - return NULL_TREE; -} - -/* To understand the code generation for this, see ch-tasking.c, - and the 2-page comments preceding the - build_chill_receive_case_start () definition. */ - -static void -parse_receive_case_action (label) - tree label; -{ - tree instance_location; - tree have_else_actions; - int spec_seen = 0; - tree alt_list = NULL_TREE; - require (RECEIVE); - require (CASE); - push_action (); - pushlevel (1); - if (! ignoring) - { - expand_exit_needed = 0; - } - - if (check_token (SET)) - { - instance_location = parse_expression (); - parse_semi_colon (); - } - else - instance_location = NULL_TREE; - if (! ignoring) - instance_location = build_receive_case_start (instance_location); - - for (;;) - { - tree receive_spec = parse_receive_spec (); - if (receive_spec) - { - if (! ignoring) - alt_list = tree_cons (NULL_TREE, receive_spec, alt_list); - spec_seen++; - } - else if (parse_action ()) - { - if (! spec_seen && pass == 1) - error ("missing RECEIVE alternative"); - if (! ignoring) - expand_exit_needed = 1; - spec_seen = 1; - } - else - break; - } - if (check_token (ELSE)) - { - if (! ignoring) - { - emit_line_note (input_filename, lineno); - if (build_receive_case_if_generated ()) - expand_start_else (); - } - parse_opt_actions (); - have_else_actions = integer_one_node; - } - else - have_else_actions = integer_zero_node; - expect (ESAC, "missing 'ESAC' matching 'RECEIVE CASE'"); - if (! ignoring) - { - build_receive_case_end (nreverse (alt_list), have_else_actions); - } - possibly_define_exit_label (label); - poplevel (0, 0, 0); -} - -static void -parse_send_action () -{ - tree signal = NULL_TREE; - tree buffer = NULL_TREE; - tree value_list; - tree with_expr, to_expr, priority; - require (SEND); - /* The tricky part is distinguishing between a SEND buffer action, - and a SEND signal action. */ - if (pass != 2 || PEEK_TOKEN () != NAME) - { - /* If this is pass 2, it's a SEND buffer action. - If it's pass 1, we don't care. */ - buffer = parse_primval (); - } - else - { - /* We have to specifically check for signalname followed by - a '(', since we allow a signalname to be used (syntactically) - as a "function". */ - tree name = parse_name (); - if (TREE_CODE (name) == TYPE_DECL && CH_DECL_SIGNAL (name)) - signal = name; /* It's a SEND signal action! */ - else - { - /* It's not a legal SEND signal action. - Back up and try as a SEND buffer action. */ - pushback_token (EXPR, name); - buffer = parse_primval (); - } - } - if (check_token (LPRN)) - { - value_list = NULL_TREE; - for (;;) - { - tree expr = parse_untyped_expr (); - if (! ignoring) - value_list = tree_cons (NULL_TREE, expr, value_list); - if (! check_token (COMMA)) - break; - } - value_list = nreverse (value_list); - expect (RPRN, "missing ')'"); - } - else - value_list = NULL_TREE; - if (check_token (WITH)) - with_expr = parse_expression (); - else - with_expr = NULL_TREE; - if (check_token (TO)) - to_expr = parse_expression (); - else - to_expr = NULL_TREE; - if (check_token (PRIORITY)) - priority = parse_expression (); - else - priority = NULL_TREE; - PUSH_ACTION; - if (ignoring) - return; - - if (signal) - { /* It's a <send signal action>! */ - tree sigdesc = build_signal_descriptor (signal, value_list); - if (sigdesc != NULL_TREE && TREE_CODE (sigdesc) != ERROR_MARK) - { - tree sendto = to_expr ? to_expr : IDENTIFIER_SIGNAL_DEST (signal); - expand_send_signal (sigdesc, with_expr, - sendto, priority, DECL_NAME (signal)); - } - } - else - { - /* all checks are done in expand_send_buffer */ - expand_send_buffer (buffer, value_list, priority, with_expr, to_expr); - } -} - -static void -parse_start_action () -{ - tree name, copy_number, param_list, startset; - require (START); - name = parse_name_string (); - expect (LPRN, "missing '(' in START action"); - PUSH_ACTION; - /* copy number is a required parameter */ - copy_number = parse_expression (); - if (!ignoring - && (copy_number == NULL_TREE - || TREE_CODE (copy_number) == ERROR_MARK - || TREE_CODE (TREE_TYPE (copy_number)) != INTEGER_TYPE)) - { - error ("PROCESS copy number must be integer"); - copy_number = integer_zero_node; - } - if (check_token (COMMA)) - param_list = parse_expr_list (); /* user parameters */ - else - param_list = NULL_TREE; - expect (RPRN, "missing ')'"); - startset = check_token (SET) ? parse_primval () : NULL; - build_start_process (name, copy_number, param_list, startset); -} - -static void -parse_opt_actions () -{ - while (parse_action ()) ; -} - -static int -parse_action () -{ - tree label = NULL_TREE; - tree expr, rhs, loclist; - enum tree_code op; - - if (current_function_decl == global_function_decl - && PEEK_TOKEN () != SC - && PEEK_TOKEN () != END) - seen_action = 1, build_constructor = 1; - - if (PEEK_TOKEN () == NAME && PEEK_TOKEN1 () == COLON) - { - label = parse_defining_occurrence (); - require (COLON); - INIT_ACTION; - define_label (input_filename, lineno, label); - } - - switch (PEEK_TOKEN ()) - { - case AFTER: - { - int delay; - require (AFTER); - expr = parse_primval (); - delay = check_token (DELAY); - expect (IN, "missing 'IN'"); - push_action (); - pushlevel (1); - build_after_start (expr, delay); - parse_opt_actions (); - expect (TIMEOUT, "missing 'TIMEOUT'"); - build_after_timeout_start (); - parse_opt_actions (); - expect (END, "missing 'END'"); - build_after_end (); - possibly_define_exit_label (label); - poplevel (0, 0, 0); - } - goto bracketed_action; - case ASM_KEYWORD: - parse_asm_action (); - goto no_handler_action; - case ASSERT: - require (ASSERT); - PUSH_ACTION; - expr = parse_expression (); - if (! ignoring) - { tree assertfail = ridpointers[(int) RID_ASSERTFAIL]; - expr = build (TRUTH_ORIF_EXPR, void_type_node, expr, - build_cause_exception (assertfail, 0)); - expand_expr_stmt (fold (expr)); - } - goto handler_action; - case AT: - require (AT); - PUSH_ACTION; - expr = parse_primval (); - expect (IN, "missing 'IN'"); - pushlevel (1); - if (! ignoring) - build_at_action (expr); - parse_opt_actions (); - expect (TIMEOUT, "missing 'TIMEOUT'"); - if (! ignoring) - expand_start_else (); - parse_opt_actions (); - expect (END, "missing 'END'"); - if (! ignoring) - expand_end_cond (); - possibly_define_exit_label (label); - poplevel (0, 0, 0); - goto bracketed_action; - case BEGINTOKEN: - parse_begin_end_block (label); - return 1; - case CASE: - parse_case_action (label); - goto bracketed_action; - case CAUSE: - require (CAUSE); - expr = parse_name_string (); - PUSH_ACTION; - if (! ignoring && TREE_CODE (expr) != ERROR_MARK) - expand_cause_exception (expr); - goto no_handler_action; - case CONTINUE: - require (CONTINUE); - expr = parse_expression (); - PUSH_ACTION; - if (! ignoring) - expand_continue_event (expr); - goto handler_action; - case CYCLE: - require (CYCLE); - PUSH_ACTION; - expr = parse_primval (); - expect (IN, "missing 'IN' after 'CYCLE'"); - pushlevel (1); - /* We a tree list where TREE_VALUE is the label - and TREE_PURPOSE is the variable denotes the timeout id. */ - expr = build_cycle_start (expr); - parse_opt_actions (); - expect (END, "missing 'END'"); - if (! ignoring) - build_cycle_end (expr); - possibly_define_exit_label (label); - poplevel (0, 0, 0); - goto bracketed_action; - case DELAY: - if (PEEK_TOKEN1 () == CASE) - { - parse_delay_case_action (label); - goto bracketed_action; - } - require (DELAY); - PUSH_ACTION; - expr = parse_primval (); - rhs = check_token (PRIORITY) ? parse_expression () : NULL_TREE; - if (! ignoring) - build_delay_action (expr, rhs); - goto handler_action; - case DO: - parse_do_action (label); - return 1; - case EXIT: - require (EXIT); - expr = parse_name_string (); - PUSH_ACTION; - lookup_and_handle_exit (expr); - goto no_handler_action; - case GOTO: - require (GOTO); - expr = parse_name_string (); - PUSH_ACTION; - lookup_and_expand_goto (expr); - goto no_handler_action; - case IF: - parse_if_action (label); - goto bracketed_action; - case RECEIVE: - if (PEEK_TOKEN1 () != CASE) - return 0; - parse_receive_case_action (label); - goto bracketed_action; - case RESULT: - require (RESULT); - PUSH_ACTION; - expr = parse_untyped_expr (); - if (! ignoring) - chill_expand_result (expr, 1); - goto handler_action; - case RETURN: - require (RETURN); - PUSH_ACTION; - expr = parse_opt_untyped_expr (); - if (! ignoring) - { - /* Do this as RESULT expr and RETURN to get exceptions */ - chill_expand_result (expr, 0); - expand_goto_except_cleanup (proc_action_level); - chill_expand_return (NULL_TREE, 0); - } - if (expr) - goto handler_action; - else - goto no_handler_action; - case SC: - require (SC); - return 1; - case SEND: - parse_send_action (); - goto handler_action; - case START: - parse_start_action (); - goto handler_action; - case STOP: - require (STOP); - PUSH_ACTION; - if (! ignoring) - { tree func = lookup_name (get_identifier ("__stop_process")); - tree result = build_chill_function_call (func, NULL_TREE); - expand_expr_stmt (result); - } - goto no_handler_action; - case CALL: - require (CALL); - /* Fall through to here ... */ - case EXPR: - case LPRN: - case NAME: - /* This handles calls and assignments. */ - PUSH_ACTION; - expr = parse_primval (); - switch (PEEK_TOKEN ()) - { - case END: - parse_semi_colon (); /* Emits error message. */ - case ON: - case SC: - if (!ignoring && TREE_CODE (expr) != ERROR_MARK) - { - if (TREE_CODE (expr) != CALL_EXPR - && TREE_TYPE (expr) != void_type_node - && ! TREE_SIDE_EFFECTS (expr)) - { - if (TREE_CODE (expr) == FUNCTION_DECL) - error ("missing parenthesis for procedure call"); - else - error ("expression is not an action"); - expr = error_mark_node; - } - else - expand_expr_stmt (expr); - } - goto handler_action; - default: - loclist - = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr); - while (PEEK_TOKEN () == COMMA) - { - FORWARD_TOKEN (); - expr = parse_primval (); - if (!ignoring && TREE_CODE (expr) != ERROR_MARK) - loclist = tree_cons (NULL_TREE, expr, loclist); - } - } - switch (PEEK_TOKEN ()) - { - case OR: op = BIT_IOR_EXPR; break; - case XOR: op = BIT_XOR_EXPR; break; - case ORIF: op = TRUTH_ORIF_EXPR; break; - case AND: op = BIT_AND_EXPR; break; - case ANDIF: op = TRUTH_ANDIF_EXPR; break; - case PLUS: op = PLUS_EXPR; break; - case SUB: op = MINUS_EXPR; break; - case CONCAT: op = CONCAT_EXPR; break; - case MUL: op = MULT_EXPR; break; - case DIV: op = TRUNC_DIV_EXPR; break; - case MOD: op = FLOOR_MOD_EXPR; break; - case REM: op = TRUNC_MOD_EXPR; break; - - default: - error ("syntax error in action"); - case SC: case ON: - case ASGN: op = NOP_EXPR; break; - ; - } - - /* Looks like it was an assignment action. */ - FORWARD_TOKEN (); - if (op != NOP_EXPR) - expect (ASGN, "expected ':=' here"); - rhs = parse_untyped_expr (); - if (!ignoring) - expand_assignment_action (loclist, op, rhs); - goto handler_action; - - default: - return 0; - } - - bracketed_action: - /* We've parsed a bracketed action. */ - parse_opt_handler (); - parse_opt_end_label_semi_colon (label); - return 1; - - no_handler_action: - if (parse_opt_handler () != NULL_TREE && pass == 1) - error ("no handler is permitted on this action."); - parse_semi_colon (); - return 1; - - handler_action: - parse_opt_handler (); - parse_semi_colon (); - return 1; -} - -static void -parse_body () -{ - again: - while (parse_definition (0)) ; - - while (parse_action ()) ; - - if (parse_definition (0)) - { - if (pass == 1) - pedwarn ("definition follows action"); - goto again; - } -} - -static tree -parse_opt_untyped_expr () -{ - switch (PEEK_TOKEN ()) - { - case ON: - case END: - case SC: - case COMMA: - case COLON: - case RPRN: - return NULL_TREE; - default: - return parse_untyped_expr (); - } -} - -static tree -parse_call (function) - tree function; -{ - tree arg1, arg2, arg_list = NULL_TREE; - enum terminal tok; - require (LPRN); - arg1 = parse_opt_untyped_expr (); - if (arg1 != NULL_TREE) - { - tok = PEEK_TOKEN (); - if (tok == UP || tok == COLON) - { - FORWARD_TOKEN (); -#if 0 - /* check that arg1 isn't untyped (or mode);*/ -#endif - arg2 = parse_expression (); - expect (RPRN, "expected ')' to terminate slice"); - if (ignoring) - return integer_zero_node; - else if (tok == UP) - return build_chill_slice_with_length (function, arg1, arg2); - else - return build_chill_slice_with_range (function, arg1, arg2); - } - if (!ignoring) - arg_list = build_tree_list (NULL_TREE, arg1); - while (check_token (COMMA)) - { - arg2 = parse_untyped_expr (); - if (!ignoring) - arg_list = tree_cons (NULL_TREE, arg2, arg_list); - } - } - - expect (RPRN, "expected ')' here"); - return ignoring ? function - : build_generalized_call (function, nreverse (arg_list)); -} - -/* Matches: <field name list> - Returns: A list of IDENTIFIER_NODEs (or NULL_TREE if ignoring), - in reverse order. */ - -static tree -parse_tuple_fieldname_list () -{ - tree list = NULL_TREE; - do - { - tree name; - if (!check_token (DOT)) - { - error ("bad tuple field name list"); - return NULL_TREE; - } - name = parse_simple_name_string (); - list = ignoring ? NULL_TREE : tree_cons (NULL_TREE, name, list); - } while (check_token (COMMA)); - return list; -} - -/* Returns one or nore TREE_LIST nodes, in reverse order. */ - -static tree -parse_tuple_element () -{ - /* The tupleelement chain is built in reverse order, - and put in forward order when the list is used. */ - tree value, label; - if (PEEK_TOKEN () == DOT) - { - /* Parse a labelled structure tuple. */ - tree list = parse_tuple_fieldname_list (), field; - expect (COLON, "missing ':' in tuple"); - value = parse_untyped_expr (); - if (ignoring) - return NULL_TREE; - /* FIXME: Should use save_expr(value), but that - confuses nested calls to digest_init! */ - /* Re-use the list of field names as a list of name-value pairs. */ - for (field = list; field != NULL_TREE; field = TREE_CHAIN (field)) - { tree field_name = TREE_VALUE (field); - TREE_PURPOSE (field) = field_name; - TREE_VALUE (field) = value; - TUPLE_NAMED_FIELD (field) = 1; - } - return list; - } - - label = parse_case_label_list (NULL_TREE, 1); - if (label) - { - expect (COLON, "missing ':' in tuple"); - value = parse_untyped_expr (); - if (ignoring || label == NULL_TREE) - return NULL_TREE; - if (TREE_CODE (label) != TREE_LIST) - { - error ("invalid syntax for label in tuple"); - return NULL_TREE; - } - else - { - /* FIXME: Should use save_expr(value), but that - confuses nested calls to digest_init! */ - tree link = label; - for (; link != NULL_TREE; link = TREE_CHAIN (link)) - { tree index = TREE_VALUE (link); - if (pass == 1 && TREE_CODE (index) != TREE_LIST) - index = build1 (PAREN_EXPR, NULL_TREE, index); - TREE_VALUE (link) = value; - TREE_PURPOSE (link) = index; - } - return nreverse (label); - } - } - - value = parse_untyped_expr (); - if (check_token (COLON)) - { - /* A powerset range [or possibly a labeled Array?] */ - tree value2 = parse_untyped_expr (); - return ignoring ? NULL_TREE : build_tree_list (value, value2); - } - return ignoring ? NULL_TREE : build_tree_list (NULL_TREE, value); -} - -/* Matches: a COMMA-separated list of tuple elements. - Returns a list (of TREE_LIST nodes). */ -static tree -parse_opt_element_list () -{ - tree list = NULL_TREE; - if (PEEK_TOKEN () == RPC) - return NULL_TREE; - for (;;) - { - tree element = parse_tuple_element (); - list = chainon (element, list); /* Built in reverse order */ - if (PEEK_TOKEN () == RPC) - break; - if (!check_token (COMMA)) - { - error ("bad syntax in tuple"); - return NULL_TREE; - } - } - return nreverse (list); -} - -/* Parses: '[' elements ']' - If modename is non-NULL it prefixed the tuple. */ - -static tree -parse_tuple (modename) - tree modename; -{ - tree list; - require (LPC); - list = parse_opt_element_list (); - expect (RPC, "missing ']' after tuple"); - if (ignoring) - return integer_zero_node; - list = build_nt (CONSTRUCTOR, NULL_TREE, list); - if (modename == NULL_TREE) - return list; - else if (pass == 1) - TREE_TYPE (list) = modename; - else if (TREE_CODE (modename) != TYPE_DECL) - { - error ("non-mode name before tuple"); - return error_mark_node; - } - else - list = chill_expand_tuple (TREE_TYPE (modename), list); - return list; -} - -static tree -parse_primval () -{ - tree val; - switch (PEEK_TOKEN ()) - { - case NUMBER: - case FLOATING: - case STRING: - case SINGLECHAR: - case BITSTRING: - case CONST: - case EXPR: - val = PEEK_TREE(); - FORWARD_TOKEN (); - break; - case THIS: - val = build_chill_function_call (PEEK_TREE (), NULL_TREE); - FORWARD_TOKEN (); - break; - case LPRN: - FORWARD_TOKEN (); - val = parse_expression (); - expect (RPRN, "missing right parenthesis"); - if (pass == 1 && ! ignoring) - val = build1 (PAREN_EXPR, NULL_TREE, val); - break; - case LPC: - val = parse_tuple (NULL_TREE); - break; - case NAME: - val = parse_name (); - if (PEEK_TOKEN() == LPC) - val = parse_tuple (val); /* Matched: <mode_name> <tuple> */ - break; - default: - if (!ignoring) - error ("invalid expression/location syntax"); - val = error_mark_node; - } - for (;;) - { - tree name, args; - switch (PEEK_TOKEN ()) - { - case DOT: - FORWARD_TOKEN (); - name = parse_simple_name_string (); - val = ignoring ? val : build_chill_component_ref (val, name); - continue; - case ARROW: - FORWARD_TOKEN (); - name = parse_opt_name_string (0); - val = ignoring ? val : build_chill_indirect_ref (val, name, 1); - continue; - case LPRN: - /* The SEND buffer action syntax is ambiguous, at least when - parsed left-to-right. In the example 'SEND foo(v) ...' the - phrase 'foo(v)' could be a buffer location procedure call - (which then must be followed by the value to send). - On the other hand, if 'foo' is a buffer, stop parsing - after 'foo', and let parse_send_action pick up '(v) as - the value ot send. - - We handle the ambiguity for SEND signal action differently, - since we allow (as an extension) a signal to be used as - a "function" (see build_generalized_call). */ - if (TREE_TYPE (val) != NULL_TREE - && CH_IS_BUFFER_MODE (TREE_TYPE (val))) - return val; - val = parse_call (val); - continue; - case STRING: - case BITSTRING: - case SINGLECHAR: - case NAME: - /* Handle string repetition. (See comment in parse_operand5.) */ - args = parse_primval (); - val = ignoring ? val : build_generalized_call (val, args); - continue; - default: - break; - } - break; - } - return val; -} - -static tree -parse_operand6 () -{ - if (check_token (RECEIVE)) - { - tree location ATTRIBUTE_UNUSED = parse_primval (); - sorry ("RECEIVE expression"); - return integer_one_node; - } - else if (check_token (ARROW)) - { - tree location = parse_primval (); - return ignoring ? location : build_chill_arrow_expr (location, 0); - } - else - return parse_primval(); -} - -static tree -parse_operand5() -{ - enum tree_code op; - /* We are supposed to be looking for a <string repetition operator>, - but in general we can't distinguish that from a parenthesized - expression. This is especially difficult if we allow the - string operand to be a constant expression (as requested by - some users), and not just a string literal. - Consider: LPRN expr RPRN LPRN expr RPRN - Is that a function call or string repetition? - Instead, we handle string repetition in parse_primval, - and build_generalized_call. */ - tree rarg; - switch (PEEK_TOKEN()) - { - case NOT: op = BIT_NOT_EXPR; break; - case SUB: op = NEGATE_EXPR; break; - default: - op = NOP_EXPR; - } - if (op != NOP_EXPR) - FORWARD_TOKEN(); - rarg = parse_operand6(); - return (op == NOP_EXPR || ignoring) ? rarg - : build_chill_unary_op (op, rarg); -} - -static tree -parse_operand4 () -{ - tree larg = parse_operand5(), rarg; - enum tree_code op; - for (;;) - { - switch (PEEK_TOKEN()) - { - case MUL: op = MULT_EXPR; break; - case DIV: op = TRUNC_DIV_EXPR; break; - case MOD: op = FLOOR_MOD_EXPR; break; - case REM: op = TRUNC_MOD_EXPR; break; - default: - return larg; - } - FORWARD_TOKEN(); - rarg = parse_operand5(); - if (!ignoring) - larg = build_chill_binary_op (op, larg, rarg); - } -} - -static tree -parse_operand3 () -{ - tree larg = parse_operand4 (), rarg; - enum tree_code op; - for (;;) - { - switch (PEEK_TOKEN()) - { - case PLUS: op = PLUS_EXPR; break; - case SUB: op = MINUS_EXPR; break; - case CONCAT: op = CONCAT_EXPR; break; - default: - return larg; - } - FORWARD_TOKEN(); - rarg = parse_operand4(); - if (!ignoring) - larg = build_chill_binary_op (op, larg, rarg); - } -} - -static tree -parse_operand2 () -{ - tree larg = parse_operand3 (), rarg; - enum tree_code op; - for (;;) - { - if (check_token (IN)) - { - rarg = parse_operand3(); - if (! ignoring) - larg = build_chill_binary_op (SET_IN_EXPR, larg, rarg); - } - else - { - switch (PEEK_TOKEN()) - { - case GT: op = GT_EXPR; break; - case GTE: op = GE_EXPR; break; - case LT: op = LT_EXPR; break; - case LTE: op = LE_EXPR; break; - case EQL: op = EQ_EXPR; break; - case NE: op = NE_EXPR; break; - default: - return larg; - } - FORWARD_TOKEN(); - rarg = parse_operand3(); - if (!ignoring) - larg = build_compare_expr (op, larg, rarg); - } - } -} - -static tree -parse_operand1 () -{ - tree larg = parse_operand2 (), rarg; - enum tree_code op; - for (;;) - { - switch (PEEK_TOKEN()) - { - case AND: op = BIT_AND_EXPR; break; - case ANDIF: op = TRUTH_ANDIF_EXPR; break; - default: - return larg; - } - FORWARD_TOKEN(); - rarg = parse_operand2(); - if (!ignoring) - larg = build_chill_binary_op (op, larg, rarg); - } -} - -static tree -parse_operand0 () -{ - tree larg = parse_operand1(), rarg; - enum tree_code op; - for (;;) - { - switch (PEEK_TOKEN()) - { - case OR: op = BIT_IOR_EXPR; break; - case XOR: op = BIT_XOR_EXPR; break; - case ORIF: op = TRUTH_ORIF_EXPR; break; - default: - return larg; - } - FORWARD_TOKEN(); - rarg = parse_operand1(); - if (!ignoring) - larg = build_chill_binary_op (op, larg, rarg); - } -} - -static tree -parse_expression () -{ - return parse_operand0 (); -} - -static tree -parse_case_expression () -{ - tree selector_list; - tree else_expr; - tree case_expr; - tree case_alt_list = NULL_TREE; - - require (CASE); - selector_list = parse_expr_list (); - selector_list = nreverse (selector_list); - - expect (OF, "missing 'OF'"); - while (PEEK_TOKEN () == LPRN) - { - tree label_spec = parse_case_label_specification (selector_list); - tree sub_expr; - expect (COLON, "missing ':' in value case alternative"); - sub_expr = parse_expression (); - expect (SC, "missing ';'"); - if (! ignoring) - case_alt_list = tree_cons (label_spec, sub_expr, case_alt_list); - } - if (check_token (ELSE)) - { - else_expr = parse_expression (); - if (check_token (SC) && pass == 1) - warning("there should not be a ';' here"); - } - else - else_expr = NULL_TREE; - expect (ESAC, "missing 'ESAC' in 'CASE' expression"); - - if (ignoring) - return integer_zero_node; - - /* If this is a multi dimension case, then transform it into an COND_EXPR - here. This must be done before store_expr is called since it has some - special handling for COND_EXPR expressions. */ - if (TREE_CHAIN (selector_list) != NULL_TREE) - { - case_alt_list = nreverse (case_alt_list); - compute_else_ranges (selector_list, case_alt_list); - case_expr = - build_chill_multi_dimension_case_expr (selector_list, case_alt_list, else_expr); - } - else - case_expr = build_chill_case_expr (selector_list, case_alt_list, else_expr); - - return case_expr; -} - -static tree -parse_then_alternative () -{ - expect (THEN, "missing 'THEN' in 'IF' expression"); - return parse_expression (); -} - -static tree -parse_else_alternative () -{ - if (check_token (ELSIF)) - return parse_if_expression_body (); - else if (check_token (ELSE)) - return parse_expression (); - error ("missing ELSE/ELSIF in IF expression"); - return error_mark_node; -} - -/* Matches: <boolean expression> <then alternative> <else alternative> */ - -static tree -parse_if_expression_body () -{ - tree bool_expr, then_expr, else_expr; - bool_expr = parse_expression (); - then_expr = parse_then_alternative (); - else_expr = parse_else_alternative (); - if (ignoring) - return integer_zero_node; - else - return build_nt (COND_EXPR, bool_expr, then_expr, else_expr); -} - -static tree -parse_if_expression () -{ - tree expr; - require (IF); - expr = parse_if_expression_body (); - expect (FI, "missing 'FI' at end of conditional expression"); - return expr; -} - -/* An <untyped_expr> is a superset of <expr>. It also includes - <conditional expressions> and untyped <tuples>, whose types - are not given by their constituents. Hence, these are only - allowed in certain contexts that expect a certain type. - You should call convert() to fix up the <untyped_expr>. */ - -static tree -parse_untyped_expr () -{ - tree val; - switch (PEEK_TOKEN()) - { - case IF: - return parse_if_expression (); - case CASE: - return parse_case_expression (); - case LPRN: - switch (PEEK_TOKEN1()) - { - case IF: - case CASE: - if (pass == 1) - pedwarn ("conditional expression not allowed inside parentheses"); - goto skip_lprn; - case LPC: - if (pass == 1) - pedwarn ("mode-less tuple not allowed inside parentheses"); - skip_lprn: - FORWARD_TOKEN (); - val = parse_untyped_expr (); - expect (RPRN, "missing ')'"); - return val; - default: ; - /* fall through */ - } - default: - return parse_operand0 (); - } -} - -/* Matches: <index mode> */ - -static tree -parse_index_mode () -{ - /* This is another one that is nasty to parse! - Let's feel our way ahead ... */ - tree lower, upper; - if (PEEK_TOKEN () == NAME) - { - tree name = parse_name (); - switch (PEEK_TOKEN ()) - { - case COMMA: - case RPRN: - case SC: /* An error */ - /* This can only (legally) be a discrete mode name. */ - return name; - case LPRN: - /* This could be named discrete range, - a cast, or some other expression (maybe). */ - require (LPRN); - lower = parse_expression (); - if (check_token (COLON)) - { - upper = parse_expression (); - expect (RPRN, "missing ')'"); - /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */ - if (ignoring) - return NULL_TREE; - else - return build_chill_range_type (name, lower, upper); - } - /* Looks like a cast or procedure call or something. - Backup, and try again. */ - pushback_token (EXPR, lower); - pushback_token (LPRN, NULL_TREE); - lower = parse_call (name); - goto parse_literal_range_colon; - default: - /* This has to be the start of an expression. */ - pushback_token (EXPR, name); - goto parse_literal_range; - } - } - /* It's not a name. But it could still be a discrete mode. */ - lower = parse_opt_mode (); - if (lower) - return lower; - parse_literal_range: - /* Nope, it's a discrete literal range. */ - lower = parse_expression (); - parse_literal_range_colon: - expect (COLON, "expected ':' here"); - - upper = parse_expression (); - return ignoring ? NULL_TREE - : build_chill_range_type (NULL_TREE, lower, upper); -} - -static tree -parse_set_mode () -{ - int set_name_cnt = 0; /* count of named set elements */ - int set_is_numbered = 0; /* TRUE if set elements have explicit values */ - int set_is_not_numbered = 0; - tree list = NULL_TREE; - tree mode = ignoring ? void_type_node : start_enum (NULL_TREE); - require (SET); - expect (LPRN, "missing left parenthesis after SET"); - for (;;) - { - tree name, value = NULL_TREE; - if (check_token (MUL)) - name = NULL_TREE; - else - { - name = parse_defining_occurrence (); - if (check_token (EQL)) - { - value = parse_expression (); - set_is_numbered = 1; - } - else - set_is_not_numbered = 1; - set_name_cnt++; - } - name = build_enumerator (name, value); - if (pass == 1) - list = chainon (name, list); - if (! check_token (COMMA)) - break; - } - expect (RPRN, "missing right parenthesis after SET"); - if (!ignoring) - { - if (set_is_numbered && set_is_not_numbered) - /* Z.200 doesn't allow mixed numbered and unnumbered set elements, - but we can do it. Print a warning */ - pedwarn ("mixed numbered and unnumbered set elements is not standard"); - mode = finish_enum (mode, list); - if (set_name_cnt == 0) - error ("SET mode must define at least one named value"); - CH_ENUM_IS_NUMBERED(mode) = set_is_numbered ? 1 : 0; - } - return mode; -} - -/* parse layout POS: - returns a tree with following layout - - treelist - pupose=treelist value=NULL_TREE (to indicate POS) - pupose=word value=treelist | NULL_TREE - pupose=startbit value=treelist | NULL_TREE - purpose= value= - integer_zero | integer_one length | endbit -*/ -static tree -parse_pos () -{ - tree word; - tree startbit = NULL_TREE, endbit = NULL_TREE; - tree what = NULL_TREE; - - require (LPRN); - word = parse_untyped_expr (); - if (check_token (COMMA)) - { - startbit = parse_untyped_expr (); - if (check_token (COMMA)) - { - what = integer_zero_node; - endbit = parse_untyped_expr (); - } - else if (check_token (COLON)) - { - what = integer_one_node; - endbit = parse_untyped_expr (); - } - } - require (RPRN); - - /* build the tree as described above */ - if (what != NULL_TREE) - what = tree_cons (what, endbit, NULL_TREE); - if (startbit != NULL_TREE) - startbit = tree_cons (startbit, what, NULL_TREE); - endbit = tree_cons (word, startbit, NULL_TREE); - return tree_cons (endbit, NULL_TREE, NULL_TREE); -} - -/* parse layout STEP - returns a tree with the following layout - - treelist - pupose=NULL_TREE value=treelist (to indicate STEP) - pupose=POS(see baove) value=stepsize | NULL_TREE -*/ -static tree -parse_step () -{ - tree pos; - tree stepsize = NULL_TREE; - - require (LPRN); - require (POS); - pos = parse_pos (); - if (check_token (COMMA)) - stepsize = parse_untyped_expr (); - require (RPRN); - TREE_VALUE (pos) = stepsize; - return tree_cons (NULL_TREE, pos, NULL_TREE); -} - -/* returns layout for fields or array elements. - NULL_TREE no layout specified - integer_one_node PACK specified - integer_zero_node NOPACK specified - tree_list PURPOSE POS - tree_list VALUE STEP -*/ -static tree -parse_opt_layout (in) - int in; /* 0 ... parse structure, 1 ... parse array */ -{ - tree val = NULL_TREE; - - if (check_token (PACK)) - { - return integer_one_node; - } - else if (check_token (NOPACK)) - { - return integer_zero_node; - } - else if (check_token (POS)) - { - val = parse_pos (); - if (in == 1 && pass == 1) - { - error ("POS not allowed for ARRAY"); - val = NULL_TREE; - } - return val; - } - else if (check_token (STEP)) - { - val = parse_step (); - if (in == 0 && pass == 1) - { - error ("STEP not allowed in field definition"); - val = NULL_TREE; - } - return val; - } - else - return NULL_TREE; -} - -static tree -parse_field_name_list () -{ - tree chain = NULL_TREE; - tree name = parse_defining_occurrence (); - if (name == NULL_TREE) - { - error("missing field name"); - return NULL_TREE; - } - chain = build_tree_list (NULL_TREE, name); - while (check_token (COMMA)) - { - name = parse_defining_occurrence (); - if (name == NULL) - { - error ("bad field name following ','"); - break; - } - if (! ignoring) - chain = tree_cons (NULL_TREE, name, chain); - } - return chain; -} - -/* Matches: <fixed field> or <variant field>, i.e.: - <field name defining occurrence list> <mode> [ <field layout> ]. - Returns: A chain of FIELD_DECLs. - NULL_TREE is returned if ignoring is true or an error is seen. */ - -static tree -parse_fixed_field () -{ - tree field_names = parse_field_name_list (); - tree mode = parse_mode (); - tree layout = parse_opt_layout (0); - return ignoring ? NULL_TREE - : grok_chill_fixedfields (field_names, mode, layout); -} - - -/* Matches: [ <variant field> { "," <variant field> }* ] - Returns: A chain of FIELD_DECLs. - NULL_TREE is returned if ignoring is true or an error is seen. */ - -static tree -parse_variant_field_list () -{ - tree fields = NULL_TREE; - if (PEEK_TOKEN () != NAME) - return NULL_TREE; - for (;;) - { - fields = chainon (fields, parse_fixed_field ()); - if (PEEK_TOKEN () != COMMA || PEEK_TOKEN1 () != NAME) - break; - require (COMMA); - } - return fields; -} - -/* Matches: <variant alternative> - Returns a TREE_LIST node, whose TREE_PURPOSE (if non-NULL) is the label, - and whose TREE_VALUE is the list of FIELD_DECLs. */ - -static tree -parse_variant_alternative () -{ - tree labels; - - if (PEEK_TOKEN () == LPRN) - labels = parse_case_label_specification (NULL_TREE); - else - labels = NULL_TREE; - if (! check_token (COLON)) - { - error ("expected ':' in structure variant alternative"); - return NULL_TREE; - } - - /* We now read a list a variant fields, until we come to the end - of the variant alternative. But since both variant fields - *and* variant alternatives are separated by COMMAs, - we will have to look ahead to distinguish the start of a variant - field from the start of a new variant alternative. - We use the fact that a variant alternative must start with - either a LPRN or a COLON, while a variant field must start with a NAME. - This look-ahead is handled by parse_simple_fields. */ - return build_tree_list (labels, parse_variant_field_list ()); -} - -/* Parse <field> (which is <fixed field> or <alternative field>). - Returns: A chain of FIELD_DECLs (or NULL_TREE on error or if ignoring). */ - -static tree -parse_field () -{ - if (check_token (CASE)) - { - tree tag_list = NULL_TREE, variants, opt_variant_else; - if (PEEK_TOKEN () == NAME) - { - tag_list = nreverse (parse_field_name_list ()); - if (pass == 1) - tag_list = lookup_tag_fields (tag_list, current_fieldlist); - } - expect (OF, "missing 'OF' in alternative structure field"); - - variants = parse_variant_alternative (); - while (check_token (COMMA)) - variants = chainon (parse_variant_alternative (), variants); - variants = nreverse (variants); - - if (check_token (ELSE)) - opt_variant_else = parse_variant_field_list (); - else - opt_variant_else = NULL_TREE; - expect (ESAC, "missing 'ESAC' following alternative structure field"); - if (ignoring) - return NULL_TREE; - return grok_chill_variantdefs (tag_list, variants, opt_variant_else); - } - else if (PEEK_TOKEN () == NAME) - return parse_fixed_field (); - else - { - if (pass == 1) - error ("missing field"); - return NULL_TREE; - } -} - -static tree -parse_structure_mode () -{ - tree save_fieldlist = current_fieldlist; - tree fields; - require (STRUCT); - expect (LPRN, "expected '(' after STRUCT"); - current_fieldlist = fields = parse_field (); - while (check_token (COMMA)) - fields = chainon (fields, parse_field ()); - expect (RPRN, "expected ')' after STRUCT"); - current_fieldlist = save_fieldlist; - return ignoring ? void_type_node : build_chill_struct_type (fields); -} - -static tree -parse_opt_queue_size () -{ - if (check_token (LPRN)) - { - tree size = parse_expression (); - expect (RPRN, "missing ')'"); - return size; - } - else - return NULL_TREE; -} - -static tree -parse_procedure_mode () -{ - tree param_types = NULL_TREE, result_spec, except_list, recursive; - require (PROC); - expect (LPRN, "missing '(' after PROC"); - if (! check_token (RPRN)) - { - for (;;) - { - tree pmode = parse_mode (); - tree paramattr = parse_param_attr (); - if (! ignoring) - { - pmode = get_type_of (pmode); - param_types = tree_cons (paramattr, pmode, param_types); - } - if (! check_token (COMMA)) - break; - } - expect (RPRN, "missing ')' after PROC"); - } - result_spec = parse_opt_result_spec (); - except_list = parse_opt_except (); - recursive = parse_opt_recursive (); - if (ignoring) - return void_type_node; - return build_chill_pointer_type (build_chill_function_type - (result_spec, nreverse (param_types), - except_list, recursive)); -} - -/* Matches: <mode> - A NAME will be assumed to be a <mode name>, and thus a <mode>. - Returns NULL_TREE if no mode is seen. - (If ignoring is true, the return value may be an arbitrary tree node, - but will be non-NULL if something that could be a mode is seen.) */ - -static tree -parse_opt_mode () -{ - switch (PEEK_TOKEN ()) - { - case ACCESS: - { - tree index_mode, record_mode; - int dynamic = 0; - require (ACCESS); - if (check_token (LPRN)) - { - index_mode = parse_index_mode (); - expect (RPRN, "mssing ')'"); - } - else - index_mode = NULL_TREE; - record_mode = parse_opt_mode (); - if (record_mode) - dynamic = check_token (DYNAMIC); - return ignoring ? void_type_node - : build_access_mode (index_mode, record_mode, dynamic); - } - case ARRAY: - { - tree index_list = NULL_TREE, base_mode; - int varying; - int num_index_modes = 0; - int i; - tree layouts = NULL_TREE; - FORWARD_TOKEN (); - expect (LPRN, "missing '(' after ARRAY"); - for (;;) - { - tree index = parse_index_mode (); - num_index_modes++; - if (!ignoring) - index_list = tree_cons (NULL_TREE, index, index_list); - if (! check_token (COMMA)) - break; - } - expect (RPRN, "missing ')' after ARRAY"); - varying = check_token (VARYING); - base_mode = parse_mode (); - /* Allow a layout specification for each index mode */ - for (i = 0; i < num_index_modes; ++i) - { - tree new_layout = parse_opt_layout (1); - if (new_layout == NULL_TREE) - break; - if (!ignoring) - layouts = tree_cons (NULL_TREE, new_layout, layouts); - } - if (ignoring) - return base_mode; - return build_chill_array_type (get_type_of (base_mode), - index_list, varying, layouts); - } - case ASSOCIATION: - require (ASSOCIATION); - return association_type_node; - case BIN: - { tree length; - FORWARD_TOKEN(); - expect (LPRN, "missing left parenthesis after BIN"); - length = parse_expression (); - expect (RPRN, "missing right parenthesis after BIN"); - return ignoring ? void_type_node : build_chill_bin_type (length); - } - case BOOLS: - { - tree length; - FORWARD_TOKEN (); - expect (LPRN, "missing '(' after BOOLS"); - length = parse_expression (); - expect (RPRN, "missing ')' after BOOLS"); - if (check_token (VARYING)) - error ("VARYING bit-strings not implemented"); - return ignoring ? void_type_node : build_bitstring_type (length); - } - case BUFFER: - { - tree qsize, element_mode; - require (BUFFER); - qsize = parse_opt_queue_size (); - element_mode = parse_mode (); - return ignoring ? element_mode - : build_buffer_type (element_mode, qsize); - } - case CHARS: - { - tree length; - int varying; - tree type; - FORWARD_TOKEN (); - expect (LPRN, "missing '(' after CHARS"); - length = parse_expression (); - expect (RPRN, "missing ')' after CHARS"); - varying = check_token (VARYING); - if (ignoring) - return void_type_node; - type = build_string_type (char_type_node, length); - if (varying) - type = build_varying_struct (type); - return type; - } - case EVENT: - { - tree qsize; - require (EVENT); - qsize = parse_opt_queue_size (); - return ignoring ? void_type_node : build_event_type (qsize); - } - case NAME: - { - tree mode = get_type_of (parse_name ()); - if (check_token (LPRN)) - { - tree min_value = parse_expression (); - if (check_token (COLON)) - { - tree max_value = parse_expression (); - expect (RPRN, "syntax error - expected ')'"); - /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */ - if (ignoring) - return mode; - else - return build_chill_range_type (mode, min_value, max_value); - } - if (check_token (RPRN)) - { - int varying = check_token (VARYING); - if (! ignoring) - { - if (mode == char_type_node || varying) - { - if (mode != char_type_node - && mode != ridpointers[(int) RID_CHAR]) - error ("strings must be composed of chars"); - mode = build_string_type (char_type_node, min_value); - if (varying) - mode = build_varying_struct (mode); - } - else - { - /* Parameterized mode, - or old-fashioned CHAR(N) string declaration.. */ - tree pmode = make_node (LANG_TYPE); - TREE_TYPE (pmode) = mode; - TYPE_DOMAIN (pmode) = min_value; - mode = pmode; - } - } - } - } - return mode; - } - case POWERSET: - { tree mode; - FORWARD_TOKEN (); - mode = parse_mode (); - if (ignoring || TREE_CODE (mode) == ERROR_MARK) - return mode; - return build_powerset_type (get_type_of (mode)); - } - case PROC: - return parse_procedure_mode (); - case RANGE: - { tree low, high; - FORWARD_TOKEN(); - expect (LPRN, "missing left parenthesis after RANGE"); - low = parse_expression (); - expect (COLON, "missing colon"); - high = parse_expression (); - expect (RPRN, "missing right parenthesis after RANGE"); - return ignoring ? void_type_node - : build_chill_range_type (NULL_TREE, low, high); - } - case READ: - FORWARD_TOKEN (); - { - tree mode2 = get_type_of (parse_mode ()); - if (ignoring || TREE_CODE (mode2) == ERROR_MARK) - return mode2; - if (mode2 - && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd' - && CH_IS_BUFFER_MODE (mode2)) - { - error ("BUFFER modes may not be readonly"); - return mode2; - } - if (mode2 - && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd' - && CH_IS_EVENT_MODE (mode2)) - { - error ("EVENT modes may not be readonly"); - return mode2; - } - return build_readonly_type (mode2); - - } - case REF: - { tree mode; - FORWARD_TOKEN (); - mode = parse_mode (); - if (ignoring) - return mode; - mode = get_type_of (mode); - return (TREE_CODE (mode) == ERROR_MARK) ? mode - : build_chill_pointer_type (mode); - } - case SET: - return parse_set_mode (); - case SIGNAL: - if (pedantic) - error ("SIGNAL is not a valid mode"); - return generic_signal_type_node; - case STRUCT: - return parse_structure_mode (); - case TEXT: - { - tree length, index_mode; - int dynamic; - require (TEXT); - expect (LPRN, "missing '('"); - length = parse_expression (); - expect (RPRN, "missing ')'"); - /* FIXME: This should actually look for an optional index_mode, - but that is tricky to do. */ - index_mode = parse_opt_mode (); - dynamic = check_token (DYNAMIC); - return ignoring ? void_type_node - : build_text_mode (length, index_mode, dynamic); - } - case USAGE: - require (USAGE); - return usage_type_node; - case WHERE: - require (WHERE); - return where_type_node; - default: - return NULL_TREE; - } -} - -static tree -parse_mode () -{ - tree mode = parse_opt_mode (); - if (mode == NULL_TREE) - { - if (pass == 1) - error ("syntax error - missing mode"); - mode = error_mark_node; - } - return mode; -} - -static void -parse_program() -{ - /* Initialize global variables for current pass. */ - int i; - expand_exit_needed = 0; - label = NULL_TREE; /* for statement labels */ - current_module = NULL; - current_function_decl = NULL_TREE; - in_pseudo_module = 0; - - for (i = 0; i <= MAX_LOOK_AHEAD; i++) - terminal_buffer[i] = TOKEN_NOT_READ; - -#if 0 - /* skip some junk */ - while (PEEK_TOKEN() == HEADEREL) - FORWARD_TOKEN(); -#endif - - start_outer_function (); - - for (;;) - { - tree label = parse_optlabel (); - if (PEEK_TOKEN() == MODULE || PEEK_TOKEN() == REGION) - parse_modulion (label); - else if (PEEK_TOKEN() == SPEC) - parse_spec_module (label); - else break; - } - - finish_outer_function (); -} - -static void -parse_pass_1_2() -{ - parse_program(); - if (PEEK_TOKEN() != END_PASS_1) - { - error ("syntax error - expected a module or end of file"); - serious_errors++; - } - chill_finish_compile (); - if (serious_errors) - exit (FATAL_EXIT_CODE); - switch_to_pass_2 (); - ch_parse_init (); - except_init_pass_2 (); - ignoring = 0; - parse_program(); - chill_finish_compile (); -} - -int yyparse () -{ - parse_pass_1_2 (); - return 0; -} - -/* - * We've had an error. Move the compiler's state back to - * the global binding level. This prevents the loop in - * compile_file in toplev.c from looping forever, since the - * CHILL poplevel() has *no* effect on the value returned by - * global_bindings_p(). - */ -void -to_global_binding_level () -{ - while (! global_bindings_p ()) - current_function_decl = DECL_CONTEXT (current_function_decl); - serious_errors++; -} - -#if 1 -int yydebug; -/* Sets the value of the 'yydebug' variable to VALUE. - This is a function so we don't have to have YYDEBUG defined - in order to build the compiler. */ -void -set_yydebug (value) - int value; -{ -#if YYDEBUG != 0 - yydebug = value; -#else - warning ("YYDEBUG not defined."); -#endif -} -#endif diff --git a/gcc/ch/parse.h b/gcc/ch/parse.h deleted file mode 100644 index 142b33b3be6..00000000000 --- a/gcc/ch/parse.h +++ /dev/null @@ -1,70 +0,0 @@ -typedef union { - long itype; - tree ttype; - enum tree_code code; - char *filename; - int lineno; -} YYSTYPE; -extern YYSTYPE yylval; - -/* DELAY is defined in the standard headers on some platforms like - SunOS 4.1.4. */ -#ifdef DELAY -#undef DELAY -#endif - -enum terminal -{ - /*EOF = 0,*/ - last_char_nonterminal = 256, - /* Please keep these in alphabetic order, for easier reference and updating. - */ - ABSOLUTE, ACCESS, AFTER, ALL, ALLOCATE, AND, ANDIF, ARRAY, - ARROW, ASGN, ASM_KEYWORD, ASSERT, ASSOCIATION, AT, - BASED, BEGINTOKEN, BIN, BIT, BITSTRING, BODY, BOOLS, BUFFER, - BUFFERNAME, BUFFER_CODE, BY, - CALL, CASE, CAUSE, CDDEL, CHAR, CHARS, COLON, COMMA, CONCAT, CONST, - CONTINUE, CYCLE, - DCL, DELAY, DIV, DO, DOT, DOWN, DYNAMIC, - ELSE, ELSIF, END, ENTRY, EQL, ESAC, EVENT, EVENT_CODE, EVER, - EXCEPTIONS, EXIT, - EXPR, /* an expression that has been pushed back */ - FI, FLOATING, FOR, FORBID, - GENERAL, GOTO, GRANT, GT, GTE, - HEADEREL, - IF, IGNORED_DIRECTIVE, IN, INIT, INOUT, INLINE, - LC, LOC, LPC, LPRN, LT, LTE, - MOD, MODULE, MUL, - NAME, NE, NEW, NEWMODE, NONREF, NOPACK, NOT, NUMBER, - OD, OF, ON, OR, ORIF, - PACK, PARAMATTR, PERVASIVE, PLUS, POS, POWERSET, - PREFIXED, PRIORITY, PROC, PROCESS, - RANGE, RC, READ, READTEXT, RECEIVE, RECURSIVE, REF, REGION, REM, - RESULT, RETURN, RETURNS, ROUND, ROW, RPC, RPRN, RPRN_COLON, - SAME, SC, SEIZE, SEND, SET, SHARED, SIGNAL, SIGNALNAME, SIMPLE, - SINGLECHAR, SPEC, START, STATIC, STEP, STOP, STREAM, STRING, - STRUCT, SUB, SYN, SYNMODE, - TERMINATE, TEXT, THEN, THIS, TIMEOUT, TO, TRUNC, TYPENAME, - UP, USAGE, - VARYING, - WHERE, WHILE, WITH, - XOR, - -/* These tokens only used within ch-lex.l to process compiler directives */ - ALL_STATIC_OFF, ALL_STATIC_ON, EMPTY_OFF, EMPTY_ON, - GRANT_FILE_SIZE, PROCESS_TYPE_TOKEN, RANGE_OFF, RANGE_ON, - SEND_BUFFER_DEFAULT_PRIORITY, SEND_SIGNAL_DEFAULT_PRIORITY, - SIGNAL_CODE, SIGNAL_MAX_LENGTH, USE_SEIZE_FILE, USE_SEIZE_FILE_RESTRICTED, - USE_GRANT_FILE, - - /* These tokens are recognized, and reported as errors, by the lexer. */ - CONTEXT, REMOTE, - -/* This token is passed back to the parser when an the main - input file (not a seize file) has reached end-of-file. */ - END_PASS_1, - - EMPTY, UMINUS, - - dummy_last_terminal -}; diff --git a/gcc/ch/satisfy.c b/gcc/ch/satisfy.c deleted file mode 100644 index a15d9e20a31..00000000000 --- a/gcc/ch/satisfy.c +++ /dev/null @@ -1,629 +0,0 @@ -/* Name-satisfaction for GNU Chill compiler. - Copyright (C) 1993, 1998, 1999, 2000 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "flags.h" -#include "ch-tree.h" -#include "lex.h" -#include "toplev.h" - -#define SATISFY(ARG) ((ARG) = satisfy(ARG, chain)) - -struct decl_chain -{ - struct decl_chain *prev; - /* DECL can be a decl, or a POINTER_TYPE or a REFERENCE_TYPE. */ - tree decl; -}; - -/* forward declarations */ -static tree satisfy PARAMS ((tree, struct decl_chain *)); -static void cycle_error_print PARAMS ((struct decl_chain *, tree)); -static tree safe_satisfy_decl PARAMS ((tree, struct decl_chain *)); -static void satisfy_list PARAMS ((tree, struct decl_chain *)); -static void satisfy_list_values PARAMS ((tree, struct decl_chain *)); - -static struct decl_chain dummy_chain; -#define LOOKUP_ONLY (chain==&dummy_chain) - -/* Recursive helper routine to logically reverse the chain. */ -static void -cycle_error_print (chain, decl) - struct decl_chain *chain; - tree decl; -{ - if (chain->decl != decl) - { - cycle_error_print (chain->prev, decl); - if (TREE_CODE_CLASS (TREE_CODE (chain->decl)) == 'd') - error_with_decl (chain->decl, " `%s', which depends on ..."); - } -} - -static tree -safe_satisfy_decl (decl, prev_chain) - tree decl; - struct decl_chain *prev_chain; -{ - struct decl_chain new_link; - struct decl_chain *link; - struct decl_chain *chain = prev_chain; - const char *save_filename = input_filename; - int save_lineno = lineno; - tree result = decl; - - if (decl == NULL_TREE) - return decl; - - if (!LOOKUP_ONLY) - { - int pointer_type_breaks_cycle = 0; - /* Look for a cycle. - We could do this test more efficiently by setting a flag. FIXME */ - for (link = prev_chain; link != NULL; link = link->prev) - { - if (TREE_CODE_CLASS (TREE_CODE (link->decl)) != 'd') - pointer_type_breaks_cycle = 1; - if (link->decl == decl) - { - if (!pointer_type_breaks_cycle) - { - error_with_decl (decl, "Cycle: `%s' depends on ..."); - cycle_error_print (prev_chain, decl); - error_with_decl (decl, " `%s'"); - return error_mark_node; - } - /* There is a cycle, but it includes a pointer type, - so we're OK. However, we still have to continue - the satisfy (for example in case this is a TYPE_DECL - that points to a LANG_DECL). The cycle-check for - POINTER_TYPE/REFERENCE_TYPE should stop the recursion. */ - break; - } - } - - new_link.decl = decl; - new_link.prev = prev_chain; - chain = &new_link; - } - - input_filename = DECL_SOURCE_FILE (decl); - lineno = DECL_SOURCE_LINE (decl); - - switch ((enum chill_tree_code)TREE_CODE (decl)) - { - case ALIAS_DECL: - if (!LOOKUP_ONLY && !DECL_POSTFIX_ALL(decl)) - result = safe_satisfy_decl (DECL_ABSTRACT_ORIGIN (decl), chain); - break; - case BASED_DECL: - SATISFY (TREE_TYPE (decl)); - SATISFY (DECL_ABSTRACT_ORIGIN (decl)); - break; - case CONST_DECL: - SATISFY (TREE_TYPE (decl)); - SATISFY (DECL_INITIAL (decl)); - if (!LOOKUP_ONLY) - { - if (DECL_SIZE (decl) == 0) - { - tree init_expr = DECL_INITIAL (decl); - tree init_type; - tree specified_mode = TREE_TYPE (decl); - - if (init_expr == NULL_TREE - || TREE_CODE (init_expr) == ERROR_MARK) - goto bad_const; - init_type = TREE_TYPE (init_expr); - if (specified_mode == NULL_TREE) - { - if (init_type == NULL_TREE) - { - check_have_mode (init_expr, "SYN without mode"); - goto bad_const; - } - TREE_TYPE (decl) = init_type; - CH_DERIVED_FLAG (decl) = CH_DERIVED_FLAG (init_expr); - } - else if (CH_IS_ASSOCIATION_MODE (specified_mode) || - CH_IS_ACCESS_MODE (specified_mode) || CH_IS_TEXT_MODE (specified_mode) || - CH_IS_BUFFER_MODE (specified_mode) || CH_IS_EVENT_MODE (specified_mode)) - { - error ("SYN of this mode not allowed"); - goto bad_const; - } - else if (!CH_COMPATIBLE (init_expr, specified_mode)) - { - error ("mode of SYN incompatible with value"); - goto bad_const; - } - else if (discrete_type_p (specified_mode) - && TREE_CODE (init_expr) == INTEGER_CST - && (compare_int_csts (LT_EXPR, init_expr, - TYPE_MIN_VALUE (specified_mode)) - || compare_int_csts (GT_EXPR, init_expr, - TYPE_MAX_VALUE(specified_mode)) - )) - { - error ("SYN value outside range of its mode"); - /* set an always-valid initial value to prevent - other errors. */ - DECL_INITIAL (decl) = TYPE_MIN_VALUE (specified_mode); - } - else if (CH_STRING_TYPE_P (specified_mode) - && (init_type && CH_STRING_TYPE_P (init_type)) - && integer_zerop (string_assignment_condition (specified_mode, init_expr))) - { - error ("INIT string too large for mode"); - DECL_INITIAL (decl) = error_mark_node; - } - else - { - struct ch_class class; - class.mode = TREE_TYPE (decl); - class.kind = CH_VALUE_CLASS; - DECL_INITIAL (decl) - = convert_to_class (class, DECL_INITIAL (decl)); - } - /* DECL_SIZE is set to prevent re-doing this stuff. */ - DECL_SIZE (decl) = TYPE_SIZE (TREE_TYPE (decl)); - DECL_SIZE_UNIT (decl) = TYPE_SIZE_UNIT (TREE_TYPE (decl)); - - if (! TREE_CONSTANT (DECL_INITIAL (decl)) - && TREE_CODE (DECL_INITIAL (decl)) != ERROR_MARK) - { - error_with_decl (decl, - "value of %s is not a valid constant"); - DECL_INITIAL (decl) = error_mark_node; - } - } - result = DECL_INITIAL (decl); - } - break; - bad_const: - DECL_INITIAL (decl) = error_mark_node; - TREE_TYPE (decl) = error_mark_node; - return error_mark_node; - case FUNCTION_DECL: - SATISFY (TREE_TYPE (decl)); - if (CH_DECL_PROCESS (decl)) - safe_satisfy_decl ((tree) DECL_TASKING_CODE_DECL (decl), prev_chain); - break; - case PARM_DECL: - SATISFY (TREE_TYPE (decl)); - break; - /* RESULT_DECL doesn't need to be satisfied; - it's only built internally in pass 2 */ - case TYPE_DECL: - SATISFY (TREE_TYPE (decl)); - if (CH_DECL_SIGNAL (decl)) - safe_satisfy_decl ((tree) DECL_TASKING_CODE_DECL (decl), prev_chain); - if (!LOOKUP_ONLY) - { - if (TYPE_NAME (TREE_TYPE (decl)) == NULL_TREE) - TYPE_NAME (TREE_TYPE (decl)) = decl; - layout_decl (decl, 0); - if (CH_DECL_SIGNAL (decl) && CH_TYPE_NONVALUE_P (TREE_TYPE (decl))) - error ("mode with non-value property in signal definition"); - result = TREE_TYPE (decl); - } - break; - case VAR_DECL: - SATISFY (TREE_TYPE (decl)); - if (!LOOKUP_ONLY) - { - layout_decl (decl, 0); - if (TREE_READONLY (TREE_TYPE (decl))) - TREE_READONLY (decl) = 1; - } - break; - default: - ; - } - - /* Now set the DECL_RTL, if needed. */ - if (!LOOKUP_ONLY && DECL_RTL (decl) == 0 - && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL - || TREE_CODE (decl) == CONST_DECL)) - { - if (TREE_CODE (decl) == FUNCTION_DECL && decl_function_context (decl)) - make_function_rtl (decl); - else if (!TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) - expand_decl (decl); - else - { char * asm_name; - if (current_module == 0 || TREE_PUBLIC (decl) - || current_function_decl) - asm_name = NULL; - else - { - asm_name = (char*) - alloca (IDENTIFIER_LENGTH (current_module->prefix_name) - + IDENTIFIER_LENGTH (DECL_NAME (decl)) + 3); - sprintf (asm_name, "%s__%s", - IDENTIFIER_POINTER (current_module->prefix_name), - IDENTIFIER_POINTER (DECL_NAME (decl))); - } - make_decl_rtl (decl, asm_name, TREE_PUBLIC (decl)); - } - } - - input_filename = save_filename; - lineno = save_lineno; - - return result; -} - -tree -satisfy_decl (decl, lookup_only) - tree decl; - int lookup_only; -{ - return safe_satisfy_decl (decl, lookup_only ? &dummy_chain : NULL); -} - -static void -satisfy_list (exp, chain) - register tree exp; - struct decl_chain *chain; -{ - for (; exp != NULL_TREE; exp = TREE_CHAIN (exp)) - { - SATISFY (TREE_VALUE (exp)); - SATISFY (TREE_PURPOSE (exp)); - } -} - -static void -satisfy_list_values (exp, chain) - register tree exp; - struct decl_chain *chain; -{ - for (; exp != NULL_TREE; exp = TREE_CHAIN (exp)) - { - SATISFY (TREE_VALUE (exp)); - } -} - -static tree -satisfy (exp, chain) - tree exp; - struct decl_chain *chain; -{ - int arg_length; - int i; - tree decl; - - if (exp == NULL_TREE) - return NULL_TREE; - -#if 0 - if (!UNSATISFIED (exp)) - return exp; -#endif - - switch (TREE_CODE_CLASS (TREE_CODE (exp))) - { - case 'd': - if (!LOOKUP_ONLY) - return safe_satisfy_decl (exp, chain); - break; - case 'r': - case 's': - case '<': - case 'e': - switch ((enum chill_tree_code)TREE_CODE (exp)) - { - case REPLICATE_EXPR: - goto binary_op; - case TRUTH_NOT_EXPR: - goto unary_op; - case COMPONENT_REF: - SATISFY (TREE_OPERAND (exp, 0)); - if (!LOOKUP_ONLY && TREE_TYPE (exp) == NULL_TREE) - return resolve_component_ref (exp); - return exp; - case CALL_EXPR: - SATISFY (TREE_OPERAND (exp, 0)); - SATISFY (TREE_OPERAND (exp, 1)); - if (!LOOKUP_ONLY && TREE_TYPE (exp) == NULL_TREE) - return build_generalized_call (TREE_OPERAND (exp, 0), - TREE_OPERAND (exp, 1)); - return exp; - case CONSTRUCTOR: - { tree link = TREE_OPERAND (exp, 1); - int expand_needed = TREE_TYPE (exp) - && TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (exp))) != 't'; - for (; link != NULL_TREE; link = TREE_CHAIN (link)) - { - SATISFY (TREE_VALUE (link)); - if (!TUPLE_NAMED_FIELD (link)) - SATISFY (TREE_PURPOSE (link)); - } - SATISFY (TREE_TYPE (exp)); - if (expand_needed && !LOOKUP_ONLY) - { - tree type = TREE_TYPE (exp); - TREE_TYPE (exp) = NULL_TREE; /* To force expansion. */ - return chill_expand_tuple (type, exp); - } - return exp; - } - default: - ; - } - - arg_length = TREE_CODE_LENGTH (TREE_CODE (exp)); - for (i = 0; i < arg_length; i++) - SATISFY (TREE_OPERAND (exp, i)); - return exp; - case '1': - unary_op: - SATISFY (TREE_OPERAND (exp, 0)); - if ((enum chill_tree_code)TREE_CODE (exp) == PAREN_EXPR) - return TREE_OPERAND (exp, 0); - if (!LOOKUP_ONLY) - return finish_chill_unary_op (exp); - break; - case '2': - binary_op: - SATISFY (TREE_OPERAND (exp, 0)); - SATISFY (TREE_OPERAND (exp, 1)); - if (!LOOKUP_ONLY && TREE_CODE (exp) != RANGE_EXPR) - return finish_chill_binary_op (exp); - break; - case 'x': - switch ((enum chill_tree_code)TREE_CODE (exp)) - { - case IDENTIFIER_NODE: - decl = lookup_name (exp); - if (decl == NULL) - { - if (LOOKUP_ONLY) - return exp; - error ("undeclared identifier `%s'", IDENTIFIER_POINTER (exp)); - return error_mark_node; - } - if (LOOKUP_ONLY) - return decl; - return safe_satisfy_decl (decl, chain); - case TREE_LIST: - satisfy_list (exp, chain); - break; - default: - ; - } - break; - case 't': - /* If TYPE_SIZE is non-NULL, exp and its subfields has already been - satified and laid out. The exception is pointer and reference types, - which we layout before we lay out their TREE_TYPE. */ - if (TYPE_SIZE (exp) && TREE_CODE (exp) != POINTER_TYPE - && TREE_CODE (exp) != REFERENCE_TYPE) - return exp; - if (TYPE_MAIN_VARIANT (exp) != exp) - SATISFY (TYPE_MAIN_VARIANT (exp)); - switch ((enum chill_tree_code)TREE_CODE (exp)) - { - case LANG_TYPE: - { - tree d = TYPE_DOMAIN (exp); - tree t = satisfy (TREE_TYPE (exp), chain); - SATISFY (d); - /* It is possible that one of the above satisfy calls recursively - caused exp to be satisfied, in which case we're done. */ - if (TREE_CODE (exp) != LANG_TYPE) - return exp; - TREE_TYPE (exp) = t; - TYPE_DOMAIN (exp) = d; - if (!LOOKUP_ONLY) - exp = smash_dummy_type (exp); - } - break; - case ARRAY_TYPE: - SATISFY (TREE_TYPE (exp)); - SATISFY (TYPE_DOMAIN (exp)); - SATISFY (TYPE_ATTRIBUTES (exp)); - if (!LOOKUP_ONLY) - CH_TYPE_NONVALUE_P (exp) = CH_TYPE_NONVALUE_P (TREE_TYPE (exp)); - if (!TYPE_SIZE (exp) && !LOOKUP_ONLY) - exp = layout_chill_array_type (exp); - break; - case FUNCTION_TYPE: - SATISFY (TREE_TYPE (exp)); - if (TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (exp))) != 't' - && !LOOKUP_ONLY && TREE_CODE (TREE_TYPE (exp)) != ERROR_MARK) - { - error ("RETURNS spec with invalid mode"); - TREE_TYPE (exp) = error_mark_node; - } - satisfy_list_values (TYPE_ARG_TYPES (exp), chain); - if (!TYPE_SIZE (exp) && !LOOKUP_ONLY) - layout_type (exp); - break; - case ENUMERAL_TYPE: - if (TYPE_SIZE (exp) == NULL_TREE && !LOOKUP_ONLY) - { tree pair; - /* FIXME: Should this use satisfy_decl? */ - for (pair = TYPE_VALUES (exp); pair; pair = TREE_CHAIN (pair)) - SATISFY (DECL_INITIAL (TREE_VALUE (pair))); - layout_enum (exp); - } - break; - case INTEGER_TYPE: - SATISFY (TYPE_MIN_VALUE (exp)); - SATISFY (TYPE_MAX_VALUE (exp)); - if (TREE_TYPE (exp) != NULL_TREE) - { /* A range type */ - if (TREE_TYPE (exp) != ridpointers[(int) RID_RANGE] - && TREE_TYPE (exp) != ridpointers[(int) RID_BIN] - && TREE_TYPE (exp) != string_index_type_dummy) - SATISFY (TREE_TYPE (exp)); - if (!TYPE_SIZE (exp) && !LOOKUP_ONLY) - exp = layout_chill_range_type (exp, 1); - } - break; - case POINTER_TYPE: - case REFERENCE_TYPE: - if (LOOKUP_ONLY) - SATISFY (TREE_TYPE (exp)); - else - { - struct decl_chain *link; - int already_seen = 0; - for (link = chain; ; link = link->prev) - { - if (link == NULL) - { - struct decl_chain new_link; - new_link.decl = exp; - new_link.prev = chain; - TREE_TYPE (exp) = satisfy (TREE_TYPE (exp), &new_link); - break; - } - else if (link->decl == exp) - { - already_seen = 1; - break; - } - } - if (!TYPE_SIZE (exp)) - { - layout_type (exp); - if (TREE_CODE (exp) == REFERENCE_TYPE) - CH_NOVELTY (exp) = CH_NOVELTY (TREE_TYPE (exp)); - if (! already_seen) - { - tree valtype = TREE_TYPE (exp); - if (TREE_CODE_CLASS (TREE_CODE (valtype)) != 't') - { - if (TREE_CODE (valtype) != ERROR_MARK) - error ("operand to REF is not a mode"); - TREE_TYPE (exp) = error_mark_node; - return error_mark_node; - } - else if (TREE_CODE (exp) == POINTER_TYPE - && TYPE_POINTER_TO (valtype) == NULL) - TYPE_POINTER_TO (valtype) = exp; - } - } - } - break; - case RECORD_TYPE: - { - /* FIXME: detected errors in here will be printed as - often as this sequence runs. Find another way or - place to print the errors. */ - /* if we have an ACCESS or TEXT mode we have to set - maximum_field_alignment to 0 to fit with runtime - system, even when we compile with -fpack. */ - unsigned int save_maximum_field_alignment = maximum_field_alignment; - - if (CH_IS_ACCESS_MODE (exp) || CH_IS_TEXT_MODE (exp)) - maximum_field_alignment = 0; - - for (decl = TYPE_FIELDS (exp); decl; decl = TREE_CHAIN (decl)) - { - SATISFY (TREE_TYPE (decl)); - if (!LOOKUP_ONLY) - { - /* if we have a UNION_TYPE here (variant structure), check for - non-value mode in it. This is not allowed (Z.200/pg. 33) */ - if (TREE_CODE (TREE_TYPE (decl)) == UNION_TYPE && - CH_TYPE_NONVALUE_P (TREE_TYPE (decl))) - { - error ("field with non-value mode in variant structure not allowed"); - TREE_TYPE (decl) = error_mark_node; - } - /* RECORD_TYPE gets the non-value property if one of the - fields has the non-value property */ - CH_TYPE_NONVALUE_P (exp) |= CH_TYPE_NONVALUE_P (TREE_TYPE (decl)); - } - if (TREE_CODE (decl) == CONST_DECL) - { - SATISFY (DECL_INITIAL (decl)); - if (!LOOKUP_ONLY) - { - if (CH_IS_BUFFER_MODE (exp) || CH_IS_EVENT_MODE (exp)) - DECL_INITIAL (decl) - = check_queue_size (DECL_INITIAL (decl)); - else if (CH_IS_TEXT_MODE (exp) && - DECL_NAME (decl) == get_identifier ("__textlength")) - DECL_INITIAL (decl) - = check_text_length (DECL_INITIAL (decl)); - } - } - else if (TREE_CODE (decl) == FIELD_DECL) - { - SATISFY (DECL_INITIAL (decl)); - } - } - satisfy_list (TYPE_TAG_VALUES (exp), chain); - if (!TYPE_SIZE (exp) && !LOOKUP_ONLY) - exp = layout_chill_struct_type (exp); - maximum_field_alignment = save_maximum_field_alignment; - - /* perform some checks on nonvalue modes, they are record_mode's */ - if (!LOOKUP_ONLY) - { - if (CH_IS_BUFFER_MODE (exp)) - { - tree elemmode = buffer_element_mode (exp); - if (elemmode != NULL_TREE && CH_TYPE_NONVALUE_P (elemmode)) - { - error ("buffer element mode must not have non-value property"); - invalidate_buffer_element_mode (exp); - } - } - else if (CH_IS_ACCESS_MODE (exp)) - { - tree recordmode = access_recordmode (exp); - if (recordmode != NULL_TREE && CH_TYPE_NONVALUE_P (recordmode)) - { - error ("recordmode must not have the non-value property"); - invalidate_access_recordmode (exp); - } - } - } - } - break; - case SET_TYPE: - SATISFY (TYPE_DOMAIN (exp)); - if (!TYPE_SIZE (exp) && !LOOKUP_ONLY) - exp = layout_powerset_type (exp); - break; - case UNION_TYPE: - for (decl = TYPE_FIELDS (exp); decl; decl = TREE_CHAIN (decl)) - { - SATISFY (TREE_TYPE (decl)); - if (!LOOKUP_ONLY) - CH_TYPE_NONVALUE_P (exp) |= CH_TYPE_NONVALUE_P (TREE_TYPE (decl)); - } - if (!TYPE_SIZE (exp) && !LOOKUP_ONLY) - exp = layout_chill_variants (exp); - break; - default: - ; - } - } - return exp; -} diff --git a/gcc/ch/tasking.c b/gcc/ch/tasking.c deleted file mode 100644 index 310ccb5c211..00000000000 --- a/gcc/ch/tasking.c +++ /dev/null @@ -1,3432 +0,0 @@ -/* Implement tasking-related actions for CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "rtl.h" -#include "ch-tree.h" -#include "flags.h" -#include "input.h" -#include "obstack.h" -#include "assert.h" -#include "tasking.h" -#include "lex.h" -#include "toplev.h" - -/* from ch-lex.l, from compiler directives */ -extern tree process_type; -extern tree send_signal_prio; -extern tree send_buffer_prio; - -tree tasking_message_type; -tree instance_type_node; -tree generic_signal_type_node; - -/* the type a tasking code variable has */ -tree chill_taskingcode_type_node; - -/* forward declarations */ -#if 0 -static void validate_process_parameters PARAMS ((tree)); -static tree get_struct_variable_name PARAMS ((tree)); -static tree decl_tasking_code_variable PARAMS ((tree, tree *, int)); -#endif -static tree get_struct_debug_type_name PARAMS ((tree)); -static tree get_process_wrapper_name PARAMS ((tree)); -static tree build_tasking_enum PARAMS ((void)); -static void build_tasking_message_type PARAMS ((void)); -static tree build_receive_signal_case_label PARAMS ((tree, tree)); -static tree build_receive_buffer_case_label PARAMS ((tree, tree)); -static void build_receive_buffer_case_end PARAMS ((tree, tree)); -static void build_receive_signal_case_end PARAMS ((tree, tree)); - -/* list of this module's process, buffer, etc. decls. - This is a list of TREE_VECs, chain by their TREE_CHAINs. */ -tree tasking_list = NULL_TREE; -/* The parts of a tasking_list element. */ -#define TASK_INFO_PDECL(NODE) TREE_VEC_ELT(NODE,0) -#define TASK_INFO_ENTRY(NODE) TREE_VEC_ELT(NODE,1) -#define TASK_INFO_CODE_DECL(NODE) TREE_VEC_ELT(NODE,2) -#define TASK_INFO_STUFF_NUM(NODE) TREE_VEC_ELT(NODE,3) -#define TASK_INFO_STUFF_TYPE(NODE) TREE_VEC_ELT(NODE,4) - -/* name template for process argument type */ -#define STRUCT_NAME "__tmp_%s_arg_type" - -/* name template for process arguments for debugging type */ -#define STRUCT_DEBUG_NAME "__tmp_%s_debug_type" - -/* name template for process argument variable */ -#define DATA_NAME "__tmp_%s_arg_variable" - -/* name template for process wrapper */ -#define WRAPPER_NAME "__tmp_%s_wrapper" - -/* name template for process code */ -#define SKELNAME "__tmp_%s_code" - -extern int ignoring; -static tree void_ftype_void; -static tree pointer_to_instance; -static tree infinite_buffer_event_length_node; - -tree -get_struct_type_name (name) - tree name; -{ - const char *idp = IDENTIFIER_POINTER (name); /* process name */ - char *tmpname = xmalloc (strlen (idp) + sizeof (STRUCT_NAME)); - - sprintf (tmpname, STRUCT_NAME, idp); - return get_identifier (tmpname); -} - -static tree -get_struct_debug_type_name (name) - tree name; -{ - const char *idp = IDENTIFIER_POINTER (name); /* process name */ - char *tmpname = xmalloc (strlen (idp) + sizeof (STRUCT_DEBUG_NAME)); - - sprintf (tmpname, STRUCT_DEBUG_NAME, idp); - return get_identifier (tmpname); -} - - -tree -get_tasking_code_name (name) - tree name; -{ - const char *name_str = IDENTIFIER_POINTER (name); - char *tmpname = (char *) alloca (IDENTIFIER_LENGTH (name) + - sizeof (SKELNAME)); - - sprintf (tmpname, SKELNAME, name_str); - return get_identifier (tmpname); -} - -#if 0 -static tree -get_struct_variable_name (name) - tree name; -{ - const char *idp = IDENTIFIER_POINTER (name); /* process name */ - char *tmpname = xmalloc (strlen (idp) + sizeof (DATA_NAME)); - - sprintf (tmpname, DATA_NAME, idp); - return get_identifier (tmpname); -} -#endif - -static tree -get_process_wrapper_name (name) - tree name; -{ - const char *idp = IDENTIFIER_POINTER (name); - char *tmpname = xmalloc (strlen (idp) + sizeof (WRAPPER_NAME)); - - sprintf (tmpname, WRAPPER_NAME, idp); - return get_identifier (tmpname); -} - -/* - * If this is a quasi declaration - parsed within a SPEC MODULE, - * QUASI_FLAG is TRUE, to indicate that the variable should not - * be initialized. The other module will do that. - */ -tree -generate_tasking_code_variable (name, tasking_code_ptr, quasi_flag) - tree name, *tasking_code_ptr; - int quasi_flag; -{ - - tree decl; - tree tasking_code_name = get_tasking_code_name (name); - - if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE) - { - /* check for value should be assigned is out of range */ - if (TREE_INT_CST_LOW (*tasking_code_ptr) > - TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_taskingcode_type_node))) - error ("Tasking code %ld out of range for `%s'.", - (long) TREE_INT_CST_LOW (*tasking_code_ptr), - IDENTIFIER_POINTER (name)); - } - - decl = do_decl (tasking_code_name, - chill_taskingcode_type_node, 1, 1, - quasi_flag ? NULL_TREE : *tasking_code_ptr, - 0); - - /* prevent granting of this type */ - DECL_SOURCE_LINE (decl) = 0; - - if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE) - *tasking_code_ptr = fold (build (PLUS_EXPR, chill_taskingcode_type_node, - integer_one_node, - *tasking_code_ptr)); - return decl; -} - - -/* - * If this is a quasi declaration - parsed within a SPEC MODULE, - * QUASI_FLAG is TRUE, to indicate that the variable should not - * be initialized. The other module will do that. This is just - * for BUFFERs and EVENTs. - */ -#if 0 -static tree -decl_tasking_code_variable (name, tasking_code_ptr, quasi_flag) - tree name, *tasking_code_ptr; - int quasi_flag; -{ - extern struct obstack permanent_obstack; - tree tasking_code_name = get_tasking_code_name (name); - tree decl; - - /* guarantee that RTL for the code_variable resides in - the permanent obstack. The BUFFER or EVENT may be - declared in a PROC, not at global scope... */ - push_obstacks (&permanent_obstack, &permanent_obstack); - push_obstacks_nochange (); - - if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE) - { - /* check for value should be assigned is out of range */ - if (TREE_INT_CST_LOW (*tasking_code_ptr) > - TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_taskingcode_type_node))) - error ("Tasking code %ld out of range for `%s'.", - (long) TREE_INT_CST_LOW (*tasking_code_ptr), - IDENTIFIER_POINTER (name)); - } - - decl = decl_temp1 (tasking_code_name, - chill_taskingcode_type_node, 1, - quasi_flag ? NULL_TREE : *tasking_code_ptr, - 0, 0); - /* prevent granting of this type */ - DECL_SOURCE_LINE (decl) = 0; - - /* Return to the ambient context. */ - pop_obstacks (); - - if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE) - *tasking_code_ptr = fold (build (PLUS_EXPR, chill_taskingcode_type_node, - integer_one_node, - *tasking_code_ptr)); - return decl; -} -#endif - -/* - * Transmute a process parameter list into an argument structure - * TYPE_DECL for the start_process call to reference. Create a - * proc_type variable for later. Returns the new struct type. - */ -tree -make_process_struct (name, processparlist) - tree name, processparlist; -{ - tree temp; - tree a_parm; - tree field_decls = NULL_TREE; - - if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK) - return error_mark_node; - - if (processparlist == NULL_TREE) - return tree_cons (NULL_TREE, NULL_TREE, void_list_node); - - if (TREE_CODE (processparlist) == ERROR_MARK) - return error_mark_node; - - /* build list of field decls for build_chill_struct_type */ - for (a_parm = processparlist; a_parm != NULL_TREE; - a_parm = TREE_CHAIN (a_parm)) - { - tree parnamelist = TREE_VALUE (a_parm); - tree purpose = TREE_PURPOSE (a_parm); - tree mode = TREE_VALUE (purpose); - tree parm_attr = TREE_PURPOSE (purpose); - tree field; - - /* build a FIELD_DECL node */ - if (parm_attr != NULL_TREE) - { - if (parm_attr == ridpointers[(int)RID_LOC]) - mode = build_chill_reference_type (mode); - else if (parm_attr == ridpointers[(int)RID_IN]) - ; - else if (pass == 1) - { - for (field = parnamelist; field != NULL_TREE; - field = TREE_CHAIN (field)) - error ("invalid attribute for argument `%s' (only IN or LOC allowed).", - IDENTIFIER_POINTER (TREE_VALUE (field))); - } - } - - field = grok_chill_fixedfields (parnamelist, mode, NULL_TREE); - - /* chain the fields in reverse */ - if (field_decls == NULL_TREE) - field_decls = field; - else - chainon (field_decls, field); - } - - temp = build_chill_struct_type (field_decls); - return temp; -} - -/* Build a function for a PROCESS and define some - types for the process arguments. - After the PROCESS a wrapper function will be - generated which gets the PROCESS arguments via a pointer - to a structure having the same layout as the arguments. - This wrapper function then will call the PROCESS. - The advantage in doing it this way is, that PROCESS - arguments may be displayed by gdb without any change - to gdb. -*/ -tree -build_process_header (plabel, paramlist) - tree plabel, paramlist; -{ - tree struct_ptr_type = NULL_TREE; - tree new_param_list = NULL_TREE; - tree struct_decl = NULL_TREE; - tree process_struct = NULL_TREE; - tree struct_debug_type = NULL_TREE; - tree code_decl; - - if (! global_bindings_p ()) - { - error ("PROCESS may only be declared at module level"); - return error_mark_node; - } - - if (paramlist) - { - /* must make the structure OUTSIDE the parameter scope */ - if (pass == 1) - { - process_struct = make_process_struct (plabel, paramlist); - struct_ptr_type = build_chill_pointer_type (process_struct); - } - else - { - process_struct = NULL_TREE; - struct_ptr_type = NULL_TREE; - } - - struct_decl = push_modedef (get_struct_type_name (plabel), - struct_ptr_type, -1); - DECL_SOURCE_LINE (struct_decl) = 0; - struct_debug_type = push_modedef (get_struct_debug_type_name (plabel), - process_struct, -1); - DECL_SOURCE_LINE (struct_debug_type) = 0; - - if (pass == 2) - { - /* build a list of PARM_DECL's */ - tree wrk = paramlist; - tree tmp, list = NULL_TREE; - - while (wrk != NULL_TREE) - { - tree wrk1 = TREE_VALUE (wrk); - - while (wrk1 != NULL_TREE) - { - tmp = make_node (PARM_DECL); - DECL_ASSEMBLER_NAME (tmp) = DECL_NAME (tmp) = TREE_VALUE (wrk1); - if (list == NULL_TREE) - new_param_list = list = tmp; - else - { - TREE_CHAIN (list) = tmp; - list = tmp; - } - wrk1 = TREE_CHAIN (wrk1); - } - wrk = TREE_CHAIN (wrk); - } - } - else - { - /* build a list of modes */ - tree wrk = paramlist; - - while (wrk != NULL_TREE) - { - tree wrk1 = TREE_VALUE (wrk); - - while (wrk1 != NULL_TREE) - { - new_param_list = tree_cons (TREE_PURPOSE (TREE_PURPOSE (wrk)), - TREE_VALUE (TREE_PURPOSE (wrk)), - new_param_list); - wrk1 = TREE_CHAIN (wrk1); - } - wrk = TREE_CHAIN (wrk); - } - new_param_list = nreverse (new_param_list); - } - } - - /* declare the code variable outside the process */ - code_decl = generate_tasking_code_variable (plabel, - &process_type, 0); - - /* start the parameter scope */ - push_chill_function_context (); - - if (! start_chill_function (plabel, void_type_node, - new_param_list, NULL_TREE, NULL_TREE)) - return error_mark_node; - - current_module->procedure_seen = 1; - CH_DECL_PROCESS (current_function_decl) = 1; - /* remember the code variable in the function decl */ - DECL_TASKING_CODE_DECL (current_function_decl) = - (struct lang_decl *)code_decl; - if (paramlist == NULL_TREE) - /* do it here, cause we don't have a wrapper */ - add_taskstuff_to_list (code_decl, "_TT_Process", process_type, - current_function_decl, NULL_TREE); - - return perm_tree_cons (code_decl, struct_decl, NULL_TREE); -} - -/* Generate a function which gets a pointer - to an argument block and call the corresponding - PROCESS -*/ -void -build_process_wrapper (plabel, processdata) - tree plabel; - tree processdata; -{ - tree args = NULL_TREE; - tree wrapper = NULL_TREE; - tree parammode = TREE_VALUE (processdata); - tree code_decl = TREE_PURPOSE (processdata); - tree func = lookup_name (plabel); - - /* check the mode. If it is an ERROR_MARK there was an error - in build_process_header, if it is a NULL_TREE the process - don't have parameters, so we must not generate a wrapper */ - if (parammode == NULL_TREE || - TREE_CODE (parammode) == ERROR_MARK) - return; - - /* get the function name */ - wrapper = get_process_wrapper_name (plabel); - - /* build the argument */ - if (pass == 2) - { - /* build a PARM_DECL */ - args = make_node (PARM_DECL); - DECL_ASSEMBLER_NAME (args) = DECL_NAME (args) = get_identifier ("x"); - } - else - { - /* build a tree list with the mode */ - args = tree_cons (NULL_TREE, - TREE_TYPE (parammode), - NULL_TREE); - } - - /* start the function */ - push_chill_function_context (); - - if (! start_chill_function (wrapper, void_type_node, - args, NULL_TREE, NULL_TREE)) - return; - - /* to avoid granting */ - DECL_SOURCE_LINE (current_function_decl) = 0; - - if (! ignoring) - { - /* make the call to the PROCESS */ - tree wrk; - tree x = lookup_name (get_identifier ("x")); - /* no need to check this pointer to be NULL */ - tree indref = build_chill_indirect_ref (x, NULL_TREE, 0); - - args = NULL_TREE; - wrk = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (x))); - while (wrk != NULL_TREE) - { - args = tree_cons (NULL_TREE, - build_component_ref (indref, DECL_NAME (wrk)), - args); - wrk = TREE_CHAIN (wrk); - } - CH_DECL_PROCESS (func) = 0; - expand_expr_stmt ( - build_chill_function_call (func, nreverse (args))); - CH_DECL_PROCESS (func) = 1; - } - - add_taskstuff_to_list (code_decl, "_TT_Process", process_type, - func, current_function_decl); - - /* finish the function */ - finish_chill_function (); - pop_chill_function_context (); -} - -/* Generate errors for INOUT, OUT parameters. - - "Only if LOC is specified may the mode have the non-value - property" - */ - -#if 0 -static void -validate_process_parameters (parms) - tree parms ATTRIBUTE_UNUSED; -{ -} -#endif - -/* - * build the tree for a start process action. Loop through the - * actual parameters, making a constructor list, which we use to - * initialize the argument structure. NAME is the process' name. - * COPYNUM is its copy number, whatever that is. EXPRLIST is the - * list of actual parameters passed by the start call. They must - * match. EXPRLIST must still be in reverse order; we'll reverse it here. - * - * Note: the OPTSET name is not now used - it's here for - * possible future support for the optional 'SET instance-var' - * clause. - */ -void -build_start_process (process_name, copynum, - exprlist, optset) - tree process_name, copynum, exprlist, optset; -{ - tree process_decl = NULL_TREE, struct_type_node = NULL_TREE; - tree result; - tree valtail, typetail; - tree tuple = NULL_TREE, actuallist = NULL_TREE; - tree typelist; - int parmno = 2; - tree args; - tree filename, linenumber; - - if (exprlist != NULL_TREE && TREE_CODE (exprlist) == ERROR_MARK) - process_decl = NULL_TREE; - else if (! ignoring) - { - process_decl = lookup_name (process_name); - if (process_decl == NULL_TREE) - error ("process name %s never declared", - IDENTIFIER_POINTER (process_name)); - else if (TREE_CODE (process_decl) != FUNCTION_DECL - || ! CH_DECL_PROCESS (process_decl)) - { - error ("You may only START a process, not a proc"); - process_decl = NULL_TREE; - } - else if (DECL_EXTERNAL (process_decl)) - { - args = TYPE_ARG_TYPES (TREE_TYPE (process_decl)); - if (TREE_VALUE (args) != void_type_node) - struct_type_node = TREE_TYPE (TREE_VALUE (args)); - else - struct_type_node = NULL_TREE; - } - else - { - tree debug_type = lookup_name ( - get_struct_debug_type_name (DECL_NAME (process_decl))); - - if (debug_type == NULL_TREE) - /* no debug type, no arguments */ - struct_type_node = NULL_TREE; - else - struct_type_node = TREE_TYPE (debug_type); - } - } - - /* begin a new name scope */ - pushlevel (1); - clear_last_expr (); - push_momentary (); - if (pass == 2) - expand_start_bindings (0); - - if (! ignoring && process_decl != NULL_TREE) - { - if (optset == NULL_TREE) ; - else if (!CH_REFERABLE (optset)) - { - error ("SET expression not a location."); - optset = NULL_TREE; - } - else if (!CH_IS_INSTANCE_MODE (TREE_TYPE (optset))) - { - error ("SET location must be INSTANCE mode"); - optset = NULL_TREE; - } - if (optset) - optset = force_addr_of (optset); - else - optset = convert (ptr_type_node, integer_zero_node); - - if (struct_type_node != NULL_TREE) - { - typelist = TYPE_FIELDS (struct_type_node); - - for (valtail = nreverse (exprlist), typetail = typelist; - valtail != NULL_TREE && typetail != NULL_TREE; parmno++, - valtail = TREE_CHAIN (valtail), typetail = TREE_CHAIN (typetail)) - { - register tree actual = valtail ? TREE_VALUE (valtail) : 0; - register tree type = typetail ? TREE_TYPE (typetail) : 0; - char place[30]; - sprintf (place, "signal field %d", parmno); - actual = chill_convert_for_assignment (type, actual, place); - actuallist = tree_cons (NULL_TREE, actual, - actuallist); - } - - tuple = build_nt (CONSTRUCTOR, NULL_TREE, - nreverse (actuallist)); - } - else - { - valtail = NULL_TREE; - typetail = NULL_TREE; - } - - if (valtail != 0 && TREE_VALUE (valtail) != void_type_node) - { - if (process_name) - error ("too many arguments to process `%s'", - IDENTIFIER_POINTER (process_name)); - else - error ("too many arguments to process"); - } - else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node) - { - if (process_name) - error ("too few arguments to process `%s'", - IDENTIFIER_POINTER (process_name)); - else - error ("too few arguments to process"); - } - else - { - tree process_decl = lookup_name (process_name); - tree process_type = (tree)DECL_TASKING_CODE_DECL (process_decl); - tree struct_size, struct_pointer; - - if (struct_type_node != NULL_TREE) - { - result = - decl_temp1 (get_unique_identifier ("START_ARG"), - struct_type_node, 0, tuple, 0, 0); - /* prevent granting of this type */ - DECL_SOURCE_LINE (result) = 0; - - mark_addressable (result); - struct_pointer - = build1 (ADDR_EXPR, - build_chill_pointer_type (struct_type_node), - result); - struct_size = size_in_bytes (struct_type_node); - } - else - { - struct_size = integer_zero_node; - struct_pointer = null_pointer_node; - } - - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - expand_expr_stmt ( - build_chill_function_call (lookup_name (get_identifier ("__start_process")), - tree_cons (NULL_TREE, process_type, - tree_cons (NULL_TREE, convert (integer_type_node, copynum), - tree_cons (NULL_TREE, struct_size, - tree_cons (NULL_TREE, struct_pointer, - tree_cons (NULL_TREE, optset, - tree_cons (NULL_TREE, filename, - build_tree_list (NULL_TREE, linenumber))))))))); - } - } - /* end of scope */ - - if (pass == 2) - expand_end_bindings (getdecls (), kept_level_p (), 0); - poplevel (kept_level_p (), 0, 0); - pop_momentary (); -} - -/* - * A CHILL SET which represents all of the possible tasking - * elements. - */ -static tree -build_tasking_enum () -{ - tree result, decl1; - tree enum1; - tree list = NULL_TREE; - tree value = integer_zero_node; - - enum1 = start_enum (NULL_TREE); - result = build_enumerator (get_identifier ("_TT_UNUSED"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = build_enumerator (get_identifier ("_TT_Process"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = build_enumerator (get_identifier ("_TT_Signal"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = build_enumerator (get_identifier ("_TT_Buffer"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = build_enumerator (get_identifier ("_TT_Event"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = build_enumerator (get_identifier ("_TT_Synonym"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = build_enumerator (get_identifier ("_TT_Exception"), - value); - list = chainon (result, list); - value = fold (build (PLUS_EXPR, integer_type_node, - value, integer_one_node)); - - result = finish_enum (enum1, list); - - decl1 = build_decl (TYPE_DECL, - get_identifier ("__tmp_TaskingEnum"), - result); - pushdecl (decl1); - satisfy_decl (decl1, 0); - return decl1; -} - -tree -build_tasking_struct () -{ - tree listbase, decl1, decl2, result; - tree enum_type = TREE_TYPE (build_tasking_enum ()); - /* We temporarily reset the maximum_field_alignment to zero so the - compiler's init data structures can be compatible with the - run-time system, even when we're compiling with -fpack. */ - unsigned int save_maximum_field_alignment = maximum_field_alignment; - maximum_field_alignment = 0; - - decl1 = build_decl (FIELD_DECL, get_identifier ("TaskName"), - build_chill_pointer_type (char_type_node)); - DECL_INITIAL (decl1) = NULL_TREE; - listbase = decl1; - - decl2 = build_decl (FIELD_DECL, get_identifier ("TaskValue"), - build_chill_pointer_type (chill_taskingcode_type_node)); - TREE_CHAIN (decl1) = decl2; - DECL_INITIAL (decl2) = NULL_TREE; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("TaskValueDefined"), - integer_type_node); - TREE_CHAIN (decl1) = decl2; - DECL_INITIAL (decl2) = NULL_TREE; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("TaskEntry"), - build_chill_pointer_type (void_ftype_void)); - TREE_CHAIN (decl1) = decl2; - DECL_INITIAL (decl2) = NULL_TREE; - decl1 = decl2; - - decl2 = build_decl (FIELD_DECL, get_identifier ("TaskType"), - enum_type); - TREE_CHAIN (decl1) = decl2; - DECL_INITIAL (decl2) = NULL_TREE; - decl1 = decl2; - - TREE_CHAIN (decl2) = NULL_TREE; - result = build_chill_struct_type (listbase); - satisfy_decl (result, 0); - maximum_field_alignment = save_maximum_field_alignment; - return result; -} - -/* - * build data structures describing each task/signal, etc. - * in current module. - */ -void -tasking_setup () -{ - tree tasknode; - tree struct_type; - - if (pass == 1) - return; - - struct_type = TREE_TYPE (lookup_name ( - get_identifier ("__tmp_TaskingStruct"))); - - for (tasknode = tasking_list; tasknode != NULL_TREE; - tasknode = TREE_CHAIN (tasknode)) - { - /* This is the tasking_code_variable's decl */ - tree stuffnumber = TASK_INFO_STUFF_NUM (tasknode); - tree code_decl = TASK_INFO_CODE_DECL (tasknode); - tree proc_decl = TASK_INFO_PDECL (tasknode); - tree entry = TASK_INFO_ENTRY (tasknode); - tree name = DECL_NAME (proc_decl); - char *init_struct = (char *) alloca (IDENTIFIER_LENGTH(name) + 20); - /* take care of zero termination */ - tree task_name; - /* these are the fields of the struct, in declaration order */ - tree init_flag = (stuffnumber == NULL_TREE) ? - integer_zero_node : integer_one_node; - tree type = DECL_INITIAL (TASK_INFO_STUFF_TYPE (tasknode)); - tree int_addr; - tree entry_point; - tree name_ptr; - tree decl; - tree struct_id; - tree initializer; - - if (TREE_CODE (proc_decl) == FUNCTION_DECL - && CH_DECL_PROCESS (proc_decl) - && ! DECL_EXTERNAL (proc_decl)) - { - if (entry == NULL_TREE) - entry = proc_decl; - mark_addressable (entry); - entry_point = build1 (ADDR_EXPR, - build_chill_pointer_type (void_ftype_void), - entry); - } - else - entry_point = build1 (NOP_EXPR, - build_chill_pointer_type (void_ftype_void), - null_pointer_node); - - /* take care of zero termination */ - task_name = - build_chill_string (IDENTIFIER_LENGTH (name) + 1, - IDENTIFIER_POINTER (name)); - - mark_addressable (code_decl); - int_addr = build1 (ADDR_EXPR, - build_chill_pointer_type (chill_integer_type_node), - code_decl); - - mark_addressable (task_name); - name_ptr = build1 (ADDR_EXPR, - build_chill_pointer_type (char_type_node), - task_name); - - sprintf (init_struct, "__tmp_%s_struct", - IDENTIFIER_POINTER (name)); - - struct_id = get_identifier (init_struct); - initializer = build (CONSTRUCTOR, struct_type, NULL_TREE, - tree_cons (NULL_TREE, name_ptr, - tree_cons (NULL_TREE, int_addr, - tree_cons (NULL_TREE, init_flag, - tree_cons (NULL_TREE, entry_point, - tree_cons (NULL_TREE, type, NULL_TREE)))))); - TREE_CONSTANT (initializer) = 1; - decl = decl_temp1 (struct_id, struct_type, 1, initializer, 0, 0); - /* prevent granting of this type */ - DECL_SOURCE_LINE (decl) = 0; - - /* pass the decl to tasking_registry() in the symbol table */ - IDENTIFIER_LOCAL_VALUE (struct_id) = decl; - } -} - - -/* - * Generate code to register the tasking-related stuff - * with the runtime. Only in pass 2. - */ -void -tasking_registry () -{ - tree tasknode, fn_decl; - - if (pass == 1) - return; - - fn_decl = lookup_name (get_identifier ("__register_tasking")); - - for (tasknode = tasking_list; tasknode != NULL_TREE; - tasknode = TREE_CHAIN (tasknode)) - { - tree proc_decl = TASK_INFO_PDECL (tasknode); - tree name = DECL_NAME (proc_decl); - tree arg_decl; - char *init_struct = (char *) alloca (IDENTIFIER_LENGTH (name) + 20); - - sprintf (init_struct, "__tmp_%s_struct", - IDENTIFIER_POINTER (name)); - arg_decl = lookup_name (get_identifier (init_struct)); - - expand_expr_stmt ( - build_chill_function_call (fn_decl, - build_tree_list (NULL_TREE, force_addr_of (arg_decl)))); - } -} - -/* - * Put a tasking entity (a PROCESS, or SIGNAL) onto - * the list for tasking_setup (). CODE_DECL is the integer code - * variable's DECL, which describes the shadow integer which - * accompanies each tasking entity. STUFFTYPE is a string - * representing the sort of tasking entity we have here (i.e. - * process, signal, etc.). STUFFNUMBER is an enumeration - * value saying the same thing. PROC_DECL is the declaration of - * the entity. It's a FUNCTION_DECL if the entity is a PROCESS, it's - * a TYPE_DECL if the entity is a SIGNAL. - */ -void -add_taskstuff_to_list (code_decl, stufftype, stuffnumber, - proc_decl, entry) - tree code_decl; - const char *stufftype; - tree stuffnumber, proc_decl, entry; -{ - if (pass == 1) - /* tell chill_finish_compile that there's - task-level code to be processed. */ - tasking_list = integer_one_node; - - /* do only in pass 2 so we know in chill_finish_compile whether - to generate a constructor function, and to avoid double the - correct number of entries. */ - else /* pass == 2 */ - { - tree task_node = make_tree_vec (5); - TASK_INFO_PDECL (task_node) = proc_decl; - TASK_INFO_ENTRY (task_node) = entry; - TASK_INFO_CODE_DECL (task_node) = code_decl; - TASK_INFO_STUFF_NUM (task_node) = stuffnumber; - TASK_INFO_STUFF_TYPE (task_node) - = lookup_name (get_identifier (stufftype)); - TREE_CHAIN (task_node) = tasking_list; - tasking_list = task_node; - } -} - -/* - * These next routines are called out of build_generalized_call - */ -tree -build_copy_number (instance_expr) - tree instance_expr; -{ - tree result; - - if (instance_expr == NULL_TREE - || TREE_CODE (instance_expr) == ERROR_MARK) - return error_mark_node; - if (! CH_IS_INSTANCE_MODE (TREE_TYPE (instance_expr))) - { - error ("COPY_NUMBER argument must be INSTANCE expression"); - return error_mark_node; - } - result = build_component_ref (instance_expr, - get_identifier (INS_COPY)); - CH_DERIVED_FLAG (result) = 1; - return result; -} - - -tree -build_gen_code (decl) - tree decl; -{ - tree result; - - if (decl == NULL_TREE || TREE_CODE (decl) == ERROR_MARK) - return error_mark_node; - - if ((TREE_CODE (decl) == FUNCTION_DECL && CH_DECL_PROCESS (decl)) - || (TREE_CODE (decl) == TYPE_DECL && CH_DECL_SIGNAL (decl))) - result = (tree)(DECL_TASKING_CODE_DECL (decl)); - else - { - error ("GEN_CODE argument must be a process or signal name."); - return error_mark_node; - } - CH_DERIVED_FLAG (result) = 1; - return (result); -} - - -tree -build_gen_inst (process, copyn) - tree process, copyn; -{ - tree ptype; - tree result; - - if (copyn == NULL_TREE || TREE_CODE (copyn) == ERROR_MARK) - return error_mark_node; - if (process == NULL_TREE || TREE_CODE (process) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (TREE_TYPE (copyn)) != INTEGER_TYPE) - { - error ("GEN_INST parameter 2 must be an integer mode"); - copyn = integer_zero_node; - } - - copyn = check_range (copyn, copyn, - TYPE_MIN_VALUE (chill_taskingcode_type_node), - TYPE_MAX_VALUE (chill_taskingcode_type_node)); - - if (TREE_CODE (process) == FUNCTION_DECL - && CH_DECL_PROCESS (process)) - ptype = (tree)DECL_TASKING_CODE_DECL (process); - else if (TREE_TYPE (process) != NULL_TREE - && TREE_CODE (TREE_TYPE (process)) == INTEGER_TYPE) - { - process = check_range (process, process, - TYPE_MIN_VALUE (chill_taskingcode_type_node), - TYPE_MAX_VALUE (chill_taskingcode_type_node)); - ptype = convert (chill_taskingcode_type_node, process); - } - else - { - error ("GEN_INST parameter 1 must be a PROCESS or an integer expression"); - return (error_mark_node); - } - - result = convert (instance_type_node, - build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, ptype, - tree_cons (NULL_TREE, - convert (chill_taskingcode_type_node, copyn), NULL_TREE)))); - CH_DERIVED_FLAG (result) = 1; - return result; -} - - -tree -build_gen_ptype (process_decl) - tree process_decl; -{ - tree result; - - if (process_decl == NULL_TREE || TREE_CODE (process_decl) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (process_decl) != FUNCTION_DECL - || ! CH_DECL_PROCESS (process_decl)) - { - error_with_decl (process_decl, "%s is not a declared process"); - return error_mark_node; - } - - result = (tree)DECL_TASKING_CODE_DECL (process_decl); - CH_DERIVED_FLAG (result) = 1; - return result; -} - - -tree -build_proc_type (instance_expr) - tree instance_expr; -{ - tree result; - - if (instance_expr == NULL_TREE || TREE_CODE (instance_expr) == ERROR_MARK) - return error_mark_node; - - if (! CH_IS_INSTANCE_MODE (TREE_TYPE (instance_expr))) - { - error ("PROC_TYPE argument must be INSTANCE expression"); - return error_mark_node; - } - result = build_component_ref (instance_expr, - get_identifier (INS_PTYPE)); - CH_DERIVED_FLAG (result) = 1; - return result; -} - -tree -build_queue_length (buf_ev) - tree buf_ev; -{ - if (buf_ev == NULL_TREE || TREE_CODE (buf_ev) == ERROR_MARK) - return error_mark_node; - if (TREE_TYPE (buf_ev) == NULL_TREE || - TREE_CODE (TREE_TYPE (buf_ev)) == ERROR_MARK) - return error_mark_node; - - if (CH_IS_BUFFER_MODE (TREE_TYPE (buf_ev)) || - CH_IS_EVENT_MODE (TREE_TYPE (buf_ev))) - { - const char *field_name; - tree arg1, arg2; - - if (CH_IS_EVENT_MODE (TREE_TYPE (buf_ev))) - { - field_name = "__event_data"; - arg2 = integer_one_node; - } - else - { - field_name = "__buffer_data"; - arg2 = integer_zero_node; - } - arg1 = build_component_ref (buf_ev, get_identifier (field_name)); - return build_chill_function_call ( - lookup_name (get_identifier ("__queue_length")), - tree_cons (NULL_TREE, arg1, - tree_cons (NULL_TREE, arg2, NULL_TREE))); - } - - error ("QUEUE_LENGTH argument must be a BUFFER/EVENT location."); - return error_mark_node; -} - -tree -build_signal_struct_type (signame, sigmodelist, optsigdest) - tree signame, sigmodelist, optsigdest; -{ - tree decl, temp; - - if (pass == 1) - { - int fldcnt = 0; - tree mode, field_decls = NULL_TREE; - - for (mode = sigmodelist; mode != NULL_TREE; mode = TREE_CHAIN (mode)) - { - tree field; - char fldname[20]; - - if (TREE_VALUE (mode) == NULL_TREE) - continue; - sprintf (fldname, "fld%03d", fldcnt++); - field = build_decl (FIELD_DECL, - get_identifier (fldname), - TREE_VALUE (mode)); - if (field_decls == NULL_TREE) - field_decls = field; - else - chainon (field_decls, field); - } - if (field_decls == NULL_TREE) - field_decls = build_decl (FIELD_DECL, - get_identifier ("__tmp_empty"), - boolean_type_node); - temp = build_chill_struct_type (field_decls); - - /* save the destination process name of the signal */ - IDENTIFIER_SIGNAL_DEST (signame) = optsigdest; - IDENTIFIER_SIGNAL_DATA (signame) = fldcnt; - } - else - { - /* optsigset is only valid in pass 2, so we have to save it now */ - IDENTIFIER_SIGNAL_DEST (signame) = optsigdest; - temp = NULL_TREE; /* Actually, don't care. */ - } - - decl = push_modedef (signame, temp, -1); - if (decl != NULL_TREE) - CH_DECL_SIGNAL (decl) = 1; - return decl; -} - -/* - * An instance type is a unique process identifier in the CHILL - * tasking arena. It consists of a process type and a copy number. - */ -void -build_instance_type () -{ - tree decl1, decl2, tdecl; - - decl1 = build_decl (FIELD_DECL, get_identifier (INS_PTYPE), - chill_taskingcode_type_node); - - TREE_CHAIN (decl1) = decl2 = - build_decl (FIELD_DECL, get_identifier (INS_COPY), - chill_taskingcode_type_node); - TREE_CHAIN (decl2) = NULL_TREE; - - instance_type_node = build_chill_struct_type (decl1); - tdecl = build_decl (TYPE_DECL, ridpointers[(int) RID_INSTANCE], - instance_type_node); - TYPE_NAME (instance_type_node) = tdecl; - CH_NOVELTY (instance_type_node) = tdecl; - DECL_SOURCE_LINE (tdecl) = 0; - pushdecl (tdecl); - - pointer_to_instance = build_chill_pointer_type (instance_type_node); -} - -#if 0 - * - * The tasking message descriptor looks like this C structure: - * - * typedef struct - * { - * short *sc; /* ptr to code integer */ - * int data_len; /* length of signal/buffer data msg */ - * void *data; /* ptr to signal/buffer data */ - * } SignalDescr; - * - * -#endif - -static void -build_tasking_message_type () -{ - tree type_name; - tree temp; - /* We temporarily reset maximum_field_alignment to deal with - the runtime system. */ - unsigned int save_maximum_field_alignment = maximum_field_alignment; - tree field1, field2, field3; - - maximum_field_alignment = 0; - field1 = build_decl (FIELD_DECL, - get_identifier ("_SD_code_ptr"), - build_pointer_type (chill_integer_type_node)); - field2 = build_decl (FIELD_DECL, - get_identifier ("_SD_data_len"), - integer_type_node); - field3 = build_decl (FIELD_DECL, - get_identifier ("_SD_data_ptr"), - ptr_type_node); - TREE_CHAIN (field1) = field2; - TREE_CHAIN (field2) = field3; - temp = build_chill_struct_type (field1); - - type_name = get_identifier ("__tmp_SD_struct"); - tasking_message_type = build_decl (TYPE_DECL, type_name, temp); - - /* This won't get seen in pass 2, so lay it out now. */ - layout_chill_struct_type (temp); - pushdecl (tasking_message_type); - maximum_field_alignment = save_maximum_field_alignment; -} - -tree -build_signal_descriptor (sigdef, exprlist) - tree sigdef, exprlist; -{ - tree fieldlist, typetail, valtail; - tree actuallist = NULL_TREE; - tree signame = DECL_NAME (sigdef); - tree dataptr, datalen; - int parmno = 1; - - if (sigdef == NULL_TREE - || TREE_CODE (sigdef) == ERROR_MARK) - return error_mark_node; - - if (exprlist != NULL_TREE - && TREE_CODE (exprlist) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (sigdef) != TYPE_DECL - || ! CH_DECL_SIGNAL (sigdef)) - { - error ("SEND requires a SIGNAL; %s is not a SIGNAL name", - IDENTIFIER_POINTER (signame)); - return error_mark_node; - } - if (CH_TYPE_NONVALUE_P (TREE_TYPE (sigdef))) - return error_mark_node; - - fieldlist = TYPE_FIELDS (TREE_TYPE (sigdef)); - if (IDENTIFIER_SIGNAL_DATA (signame) == 0) - fieldlist = TREE_CHAIN (fieldlist); - - for (valtail = exprlist, typetail = fieldlist; - valtail != NULL_TREE && typetail != NULL_TREE; - parmno++, valtail = TREE_CHAIN (valtail), - typetail = TREE_CHAIN (typetail)) - { - register tree actual = valtail ? TREE_VALUE (valtail) : 0; - register tree type = typetail ? TREE_TYPE (typetail) : 0; - char place[30]; - sprintf (place, "signal field %d", parmno); - actual = chill_convert_for_assignment (type, actual, place); - actuallist = tree_cons (NULL_TREE, actual, actuallist); - } - if (valtail != 0 && TREE_VALUE (valtail) != void_type_node) - { - error ("too many values for SIGNAL `%s'", - IDENTIFIER_POINTER (signame)); - return error_mark_node; - } - else if (typetail != 0 && TREE_VALUE (typetail) != void_type_node) - { - error ("too few values for SIGNAL `%s'", - IDENTIFIER_POINTER (signame)); - return error_mark_node; - } - - { - /* build signal data structure */ - tree sigdataname = get_unique_identifier ( - IDENTIFIER_POINTER (signame)); - if (exprlist == NULL_TREE) - { - dataptr = null_pointer_node; - datalen = integer_zero_node; - } - else - { - tree tuple = build_nt (CONSTRUCTOR, - NULL_TREE, nreverse (actuallist)); - tree decl = decl_temp1 (sigdataname, TREE_TYPE (sigdef), - 0, tuple, 0, 0); - /* prevent granting of this type */ - DECL_SOURCE_LINE (decl) = 0; - - dataptr = force_addr_of (decl); - datalen = size_in_bytes (TREE_TYPE (decl)); - } - - /* build descriptor pointing to signal data */ - { - tree decl, tuple; - tree tasking_message_var = get_unique_identifier ( - IDENTIFIER_POINTER (signame)); - - tree tasking_code = - (tree)DECL_TASKING_CODE_DECL (lookup_name (signame)); - - mark_addressable (tasking_code); - tuple = build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, - build1 (ADDR_EXPR, - build_chill_pointer_type (chill_integer_type_node), - tasking_code), - tree_cons (NULL_TREE, datalen, - tree_cons (NULL_TREE, dataptr, NULL_TREE)))); - - decl = decl_temp1 (tasking_message_var, - TREE_TYPE (tasking_message_type), 0, - tuple, 0, 0); - /* prevent granting of this type */ - DECL_SOURCE_LINE (decl) = 0; - - tuple = force_addr_of (decl); - return tuple; - } - } -} - -void -expand_send_signal (sigmsgbuffer, optroutinginfo, optsendto, - optpriority, signame) - tree sigmsgbuffer; - tree optroutinginfo; - tree optsendto; - tree optpriority; - tree signame; -{ - tree routing_size, routing_addr; - tree filename, linenumber; - tree sigdest = IDENTIFIER_SIGNAL_DEST (signame); - - /* check the presence of priority */ - if (optpriority == NULL_TREE) - { - if (send_signal_prio == NULL_TREE) - { - /* issue a warning in case of -Wall */ - if (extra_warnings) - { - warning ("Signal sent without priority"); - warning (" and no default priority was set."); - warning (" PRIORITY defaulted to 0"); - } - optpriority = integer_zero_node; - } - else - optpriority = send_signal_prio; - } - - /* check the presence of a destination. - optdest either may be an instance location - or a process declaration */ - if (optsendto == NULL_TREE) - { - if (sigdest == NULL_TREE) - { - error ("SEND without a destination instance"); - error (" and no destination process specified"); - error (" for the signal"); - optsendto = convert (instance_type_node, - null_pointer_node); - } - else - { - /* build an instance [sigdest; -1] */ - tree process_name = DECL_NAME (sigdest); - tree copy_number = fold (build (MINUS_EXPR, integer_type_node, - integer_zero_node, - integer_one_node)); - tree tasking_code = (tree)DECL_TASKING_CODE_DECL ( - lookup_name (process_name)); - - optsendto = build (CONSTRUCTOR, instance_type_node, NULL_TREE, - tree_cons (NULL_TREE, tasking_code, - tree_cons (NULL_TREE, copy_number, NULL_TREE))); - /* as our system doesn't allow that and Z.200 specifies it, - we issue a warning */ - warning ("SEND to ANY copy of process `%s'.", IDENTIFIER_POINTER (process_name)); - } - } - else if (! CH_IS_INSTANCE_MODE (TREE_TYPE (optsendto))) - { - error ("SEND TO must be an INSTANCE mode"); - optsendto = convert (instance_type_node, null_pointer_node); - } - else - optsendto = check_non_null (convert (instance_type_node, optsendto)); - - /* check the routing stuff */ - if (optroutinginfo != NULL_TREE) - { - tree routing_name; - tree decl; - - if (TREE_TYPE (optroutinginfo) == NULL_TREE) - { - error ("SEND WITH must have a mode"); - optroutinginfo = integer_zero_node; - } - routing_name = get_unique_identifier ("RI"); - decl = decl_temp1 (routing_name, - TREE_TYPE (optroutinginfo), 0, - optroutinginfo, 0, 0); - /* prevent granting of this type */ - DECL_SOURCE_LINE (decl) = 0; - - routing_addr = force_addr_of (decl); - routing_size = size_in_bytes (TREE_TYPE (decl)); - } - else - { - routing_size = integer_zero_node; - routing_addr = null_pointer_node; - } - /* get filename and linenumber */ - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - /* Now (at last!) we can call the runtime */ - expand_expr_stmt ( - build_chill_function_call (lookup_name (get_identifier ("__send_signal")), - tree_cons (NULL_TREE, sigmsgbuffer, - tree_cons (NULL_TREE, optsendto, - tree_cons (NULL_TREE, optpriority, - tree_cons (NULL_TREE, routing_size, - tree_cons (NULL_TREE, routing_addr, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE))))))))); -} - -#if 0 - * The following code builds a RECEIVE CASE action, which actually - * has 2 different functionalities: - * - * 1) RECEIVE signal CASE action - * which looks like this: - * - * SIGNAL advance; - * SIGNAL terminate = (CHAR); - * SIGNAL sig1 = (CHAR); - * - * DCL user, system INSTANCE; - * DCL count INT, char_code CHAR; - * DCL instance_loc INSTANCE; - * - * workloop: - * RECEIVE CASE SET instance_loc; - * (advance): - * count + := 1; - * (terminate IN char_code): - * SEND sig1(char_code) TO system; - * EXIT workloop; - * ELSE - * STOP; - * ESAC; - * - * Because we don''t know until we get to the ESAC how - * many signals need processing, we generate the following - * C-equivalent code: - * - * /* define the codes for the signals */ - * static short __tmp_advance_code; - * static short __tmp_terminate_code; - * static short __tmp_sig1_code; - * - * /* define the types of the signals */ - * typedef struct - * { - * char fld0; - * } __tmp_terminate_struct; - * - * typedef struct - * { - * char fld0; - * } __tmp_sig1_struct; - * - * static INSTANCE user, system, instance_loc; - * static short count; - * static char char_code; - * - * { /* start a new symbol context */ - * int number_of_sigs; - * short *sig_code []; - * void *sigdatabuf; - * int sigdatalen; - * short sigcode; - * - * goto __rcsetup; - * - * __rcdoit: ; - * int timedout = __wait_signal (&sigcode - * number_of_sigs, - * sig_code, - * sigdatabuf, - * sigdatalen, - * &instance_loc); - * if (sigcode == __tmp_advance_code) - * { - * /* code for advance alternative's action_statement_list */ - * count++; - * } - * else if (sigcode == __tmp_terminate_code) - * { - * /* copy signal's data to where they belong, - * with range-check, if enabled */ - * char_code = ((__tmp_terminate_struct *)sigdatabuf)->fld0; - * - * /* code for terminate alternative's action_statement_list */ - * __send_signal (sig1 ..... ); - * goto __workloop_end; - * } - * else - * { - * /* code here for the ELSE action_statement_list */ - * __stop_process (); - * } - * goto __rc_done; - * - * __rcsetup: - * union { __tmp_terminate_struct terminate; - * __tmp_sig1_struct } databuf; - * short *sig_code_ptr [2] = { &__tmp_advance_code, - * &__tmp_terminate_code }; - * sigdatabuf = &databuf; - * sigdatalen = sizeof (databuf); - * sig_code = &sig_code_ptr[0]; - * number_of_sigs = 2; - * goto __rcdoit; - * - * __rc_done: ; - * } /* end the new symbol context */ - * __workloop_end: ; - * - * - * 2) RECEIVE buffer CASE action: - * which looks like this: - * - * NEWMODE m_s = STRUCT (mini INT, maxi INT); - * DCL b1 BUFFER INT; - * DCL b2 BUFFER (30) s; - * - * DCL i INT, s m_s, ins INSTANCE; - * DCL count INT; - * - * workloop: - * RECEIVE CASE SET ins; - * (b1 IN i): - * count +:= i; - * (b2 in s): - * IF count < s.mini OR count > s.maxi THEN - * EXIT workloop; - * FI; - * ELSE - * STOP; - * ESAC; - * - * Because we don''t know until we get to the ESAC how - * many buffers need processing, we generate the following - * C-equivalent code: - * - * typedef struct - * { - * short mini; - * short maxi; - * } m_s; - * - * static void *b1; - * static void *b2; - * static short i; - * static m_s s; - * static INSTANCE ins; - * static short count; - * - * workloop: - * { /* start a new symbol context */ - * int number_of_sigs; - * void *sig_code []; - * void *sigdatabuf; - * int sigdatalen; - * void *buflocation; - * int timedout; - * - * goto __rcsetup; - * - * __rcdoit: - * timedout = __wait_buffer (&buflocation, - * number_of_sigs, - * sig_code, - * sigdatabuf, - * sigdatalen, - * &ins, ...); - * if (buflocation == &b1) - * { - * i = ((short *)sigdatabuf)->fld0; - * count += i; - * } - * else if (buflocation == &b2) - * { - * s = ((m_s)*sigdatabuf)->fld1; - * if (count < s.mini || count > s.maxi) - * goto __workloop_end; - * } - * else - * __stop_process (); - * goto __rc_done; - * - * __rcsetup: - * typedef struct - * { - * void *p; - * unsigned maxqueuesize; - * } Buffer_Descr; - * union { short b1, - * m_s b2 } databuf; - * Buffer_Descr bufptr [2] = - * { - * { &b1, -1 }, - * { &b2, 30 }, - * }; - * void * bufarray[2] = { &bufptr[0], - * &bufptr[1] }; - * sigdatabuf = &databuf; - * sigdatalen = sizeof (databuf); - * sig_code = &bufarray[0]; - * number_of_sigs = 2; - * goto __rcdoit; - * - * __rc_done; - * } /* end of symbol context */ - * __workloop_end: - * -#endif - -struct rc_state_type -{ - struct rc_state_type *enclosing; - rtx rcdoit; - rtx rcsetup; - tree n_sigs; - tree sig_code; - tree databufp; - tree datalen; - tree else_clause; - tree received_signal; - tree received_buffer; - tree to_loc; - int sigseen; - int bufseen; - tree actuallist; - int call_generated; - int if_generated; - int bufcnt; -}; - -struct rc_state_type *current_rc_state = NULL; - -/* - * this function tells if there is an if to terminate - * or not - */ -int -build_receive_case_if_generated() -{ - if (!current_rc_state) - { - error ("internal error: RECEIVE CASE stack invalid."); - abort (); - } - return current_rc_state->if_generated; -} - -/* build_receive_case_start returns an INTEGER_CST node - containing the case-label number to be used by - build_receive_case_end to generate correct labels */ -tree -build_receive_case_start (optset) - tree optset; -{ - /* counter to generate unique receive_case labels */ - static int rc_lbl_count = 0; - tree current_label_value = - build_int_2 ((HOST_WIDE_INT)rc_lbl_count, 0); - tree sigcodename, filename, linenumber; - - struct rc_state_type *rc_state - = (struct rc_state_type*) xmalloc (sizeof (struct rc_state_type)); - rc_state->rcdoit = gen_label_rtx (); - rc_state->rcsetup = gen_label_rtx (); - rc_state->enclosing = current_rc_state; - current_rc_state = rc_state; - rc_state->sigseen = 0; - rc_state->bufseen = 0; - rc_state->call_generated = 0; - rc_state->if_generated = 0; - rc_state->bufcnt = 0; - - rc_lbl_count++; - if (optset == NULL_TREE || TREE_CODE (optset) == ERROR_MARK) - optset = null_pointer_node; - else - { - if (CH_IS_INSTANCE_MODE (TREE_TYPE (optset)) && CH_LOCATION_P (optset)) - optset = force_addr_of (optset); - else - { - error ("SET requires INSTANCE location"); - optset = null_pointer_node; - } - } - - rc_state->to_loc = build_timeout_preface (); - - rc_state->n_sigs = - decl_temp1 (get_identifier ("number_of_sigs"), - integer_type_node, 0, integer_zero_node, 0, 0); - - rc_state->sig_code = - decl_temp1 (get_identifier ("sig_codep"), - ptr_type_node, 0, null_pointer_node, 0, 0); - - rc_state->databufp = - decl_temp1 (get_identifier ("databufp"), - ptr_type_node, 0, null_pointer_node, 0, 0); - - rc_state->datalen = - decl_temp1 (get_identifier ("datalen"), - integer_type_node, 0, integer_zero_node, 0, 0); - - rc_state->else_clause = - decl_temp1 (get_identifier ("else_clause"), - integer_type_node, 0, integer_zero_node, 0, 0); - - /* wait_signal will store the signal number in here */ - sigcodename = get_identifier ("received_signal"); - rc_state->received_signal = - decl_temp1 (sigcodename, chill_integer_type_node, 0, - NULL_TREE, 0, 0); - - /* wait_buffer will store the buffer address in here */ - sigcodename = get_unique_identifier ("received_buffer"); - rc_state->received_buffer = - decl_temp1 (sigcodename, ptr_type_node, 0, - NULL_TREE, 0, 0); - - /* now jump to the end of RECEIVE CASE actions, to - set up variables for them. */ - emit_jump (rc_state->rcsetup); - - /* define the __rcdoit label. We come here after - initialization of all variables, to execute the - actions. */ - emit_label (rc_state->rcdoit); - - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - /* Argument list for calling the runtime routine. We'll call it - the first time we call build_receive_case_label, when we know - whether to call wait_signal or wait_buffer. NOTE: at this time - the first argument will be set. */ - rc_state->actuallist = - tree_cons (NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, rc_state->n_sigs, - tree_cons (NULL_TREE, rc_state->sig_code, - tree_cons (NULL_TREE, rc_state->databufp, - tree_cons (NULL_TREE, rc_state->datalen, - tree_cons (NULL_TREE, optset, - tree_cons (NULL_TREE, rc_state->else_clause, - tree_cons (NULL_TREE, rc_state->to_loc, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))))); - return current_label_value; -} - -static tree -build_receive_signal_case_label (sigdecl, loclist) - tree sigdecl, loclist; -{ - struct rc_state_type *rc_state = current_rc_state; - tree signame = DECL_NAME (sigdecl); - tree expr; - - if (rc_state->bufseen != 0) - { - error ("SIGNAL in RECEIVE CASE alternative follows"); - error (" a BUFFER name on line %d", rc_state->bufseen); - return error_mark_node; - } - rc_state->sigseen = lineno; - rc_state->bufseen = 0; - - if (!IDENTIFIER_SIGNAL_DATA (signame) && loclist != NULL_TREE) - { - error ("SIGNAL `%s' has no data fields", IDENTIFIER_POINTER (signame)); - return error_mark_node; - } - if (IDENTIFIER_SIGNAL_DATA (signame) && loclist == NULL_TREE) - { - error ("SIGNAL `%s' requires data fields", IDENTIFIER_POINTER (signame)); - return error_mark_node; - } - - if (!rc_state->call_generated) - { - tree wait_call; - - TREE_VALUE (rc_state->actuallist) = force_addr_of (rc_state->received_signal); - wait_call = build_chill_function_call (lookup_name - (get_identifier ("__wait_signal_timed")), - rc_state->actuallist); -#if 0 - chill_expand_assignment (rc_state->received_signal, - NOP_EXPR, wait_call); -#endif - build_timesupervised_call (wait_call, rc_state->to_loc); - - rc_state->call_generated = 1; - } - - /* build the conditional expression */ - expr = build (EQ_EXPR, boolean_type_node, - rc_state->received_signal, - (tree)DECL_TASKING_CODE_DECL (sigdecl)); - - if (!rc_state->if_generated) - { - expand_start_cond (expr, 0); - rc_state->if_generated = 1; - } - else - expand_start_elseif (expr); - - if (IDENTIFIER_SIGNAL_DATA (signame)) - { - /* copy data from signal buffer to user's variables */ - tree typelist = TYPE_FIELDS (TREE_TYPE (sigdecl)); - tree valtail, typetail; - int parmno = 1; - tree pointer_type = build_chill_pointer_type (TREE_TYPE (sigdecl)); - tree pointer = convert (pointer_type, rc_state->databufp); - - for (valtail = nreverse (loclist), typetail = typelist; - valtail != NULL_TREE && typetail != NULL_TREE; - parmno++, valtail = TREE_CHAIN (valtail), - typetail = TREE_CHAIN (typetail)) - { - register tree actual = valtail ? TREE_VALUE (valtail) : 0; - register tree type = typetail ? TREE_TYPE (typetail) : 0; - register tree assgn; - char place[30]; - sprintf (place, "signal field %d", parmno); - - assgn = build_component_ref (build1 (INDIRECT_REF, - TREE_TYPE (sigdecl), - pointer), - DECL_NAME (typetail)); - if (!CH_TYPE_NONVALUE_P (type)) - /* don't assign to non-value type. Error printed at signal definition */ - chill_expand_assignment (actual, NOP_EXPR, assgn); - } - - if (valtail == NULL_TREE && typetail != NULL_TREE) - error ("too few data fields provided for `%s'", - IDENTIFIER_POINTER (signame)); - if (valtail != NULL_TREE && typetail == NULL_TREE) - error ("too many data fields provided for `%s'", - IDENTIFIER_POINTER (signame)); - } - - /* last action here */ - emit_line_note (input_filename, lineno); - - return build_tree_list (loclist, signame); -} - -static tree -build_receive_buffer_case_label (buffer, loclist) - tree buffer, loclist; -{ - struct rc_state_type *rc_state = current_rc_state; - tree buftype = buffer_element_mode (TREE_TYPE (buffer)); - tree expr, var; - tree pointer_type, pointer, assgn; - int had_errors = 0; - tree x, y, z, bufaddr; - - if (rc_state->sigseen != 0) - { - error ("BUFFER in RECEIVE CASE alternative follows"); - error (" a SIGNAL name on line %d", rc_state->sigseen); - return error_mark_node; - } - rc_state->bufseen = lineno; - rc_state->sigseen = 0; - - if (! CH_REFERABLE (buffer)) - { - error ("BUFFER in RECEIVE CASE alternative must be a location."); - return error_mark_node; - } - - if (TREE_CHAIN (loclist) != NULL_TREE) - { - error ("buffer receive alternative requires only 1 defining occurence."); - return error_mark_node; - } - - if (!rc_state->call_generated) - { - tree wait_call; - - /* here we change the mode of rc_state->sig_code to - REF ARRAY (0:65535) REF __tmp_DESCR_type. - This is neccesary, cause we cannot evaluate the buffer twice - (once here where we compare against the address of the buffer - and second in build_receive_buffer_case_end, where we use the - address build the descriptor, which gets passed to __wait_buffer). - So we change the comparison from - if (rc_state->received_buffer == &buffer) - to - if (rc_state->received_buffer == - rc_state->sig_codep->[rc_state->bufcnt]->datap). - - This will evaluate the buffer location only once - (in build_receive_buffer_case_end) and therefore doesn't confuse - our machinery. */ - - tree reftmpdescr = build_chill_pointer_type ( - TREE_TYPE (lookup_name ( - get_identifier ("__tmp_DESCR_type")))); - tree idxtype = build_chill_range_type (NULL_TREE, - integer_zero_node, - build_int_2 (65535, 0)); /* should be enough, probably use ULONG */ - tree arrtype = build_chill_array_type (reftmpdescr, - tree_cons (NULL_TREE, idxtype, NULL_TREE), - 0, NULL_TREE); - tree refarrtype = build_chill_pointer_type (arrtype); - - TREE_VALUE (rc_state->actuallist) = force_addr_of (rc_state->received_buffer); - wait_call = build_chill_function_call ( - lookup_name (get_identifier ("__wait_buffer")), - rc_state->actuallist); -#if 0 - chill_expand_assignment (rc_state->received_buffer, - NOP_EXPR, wait_call); -#endif - build_timesupervised_call (wait_call, rc_state->to_loc); - - /* do this after the call, otherwise there will be a mode mismatch */ - TREE_TYPE (rc_state->sig_code) = refarrtype; - - /* now we are ready to generate the call */ - rc_state->call_generated = 1; - } - - x = build_chill_indirect_ref (rc_state->sig_code, NULL_TREE, 0); - y = build_chill_array_ref (x, - tree_cons (NULL_TREE, build_int_2 (rc_state->bufcnt, 0), NULL_TREE)); - z = build_chill_indirect_ref (y, NULL_TREE, 0); - bufaddr = build_chill_component_ref (z, get_identifier ("datap")); - - /* build the conditional expression */ - expr = build (EQ_EXPR, boolean_type_node, - rc_state->received_buffer, - bufaddr); - - /* next buffer in list */ - rc_state->bufcnt++; - - if (!rc_state->if_generated) - { - expand_start_cond (expr, 0); - rc_state->if_generated = 1; - } - else - expand_start_elseif (expr); - - /* copy buffer's data to destination */ - var = TREE_VALUE (loclist); - - if (buftype != NULL_TREE && TREE_CODE (buftype) == ERROR_MARK) - had_errors = 1; - else if (! CH_COMPATIBLE (var, buftype)) - { - error ("incompatible modes in receive buffer alternative."); - had_errors = 1; - } - - if (! CH_LOCATION_P (var)) - { - error ("defining occurence in receive buffer alternative must be a location."); - had_errors = 1; - } - - if (! had_errors) - { - pointer_type = build_chill_pointer_type (TREE_TYPE (var)); - pointer = convert (pointer_type, - rc_state->databufp); - /* no need to check this pointer being NULL */ - assgn = build_chill_indirect_ref (pointer, NULL_TREE, 0); - - chill_expand_assignment (var, NOP_EXPR, assgn); - } - - /* last action here */ - emit_line_note (input_filename, lineno); - - return build_tree_list (loclist, buffer); -} -/* - * SIGNAME is the signal name or buffer location, - * LOCLIST is a list of possible locations to store data in - */ -tree -build_receive_case_label (signame, loclist) - tree signame, loclist; -{ - /* now see what we have got and do some checks */ - if (TREE_CODE (signame) == TYPE_DECL && CH_DECL_SIGNAL (signame)) - return build_receive_signal_case_label (signame, loclist); - - if (TREE_TYPE (signame) != NULL_TREE - && CH_IS_BUFFER_MODE (TREE_TYPE (signame))) - { - if (loclist == NULL_TREE) - { - error ("buffer receive alternative without `IN location'."); - return error_mark_node; - } - return build_receive_buffer_case_label (signame, loclist); - } - - error ("RECEIVE CASE alternative must specify a SIGNAL name or BUFFER location."); - return error_mark_node; -} - -/* - * LABEL_CNT is the case-label counter passed from build_receive_case_start. - * ELSE_CLAUSE defines if the RECEIVE CASE action had an ELSE(1) or not(0). - * BUF_LIST is a tree-list of tree-lists, where TREE_VALUE defines the - * BUFFER location and TREE_PURPOSE defines the defining occurence. - */ -static void -build_receive_buffer_case_end (buf_list, else_clause) - tree buf_list, else_clause; -{ - struct rc_state_type *rc_state = current_rc_state; - tree alist; - tree field_decls = NULL_TREE; /* list of all buffer types, for the union */ - int buffer_cnt = 0; - tree descr_type = lookup_name (get_identifier ("__tmp_DESCR_type")); - tree tuple = NULL_TREE; /* constructors for array of ptrs */ - tree union_type_node = NULL_TREE; - - /* walk thru all the buffers */ - for (alist = buf_list; alist != NULL_TREE; - buffer_cnt++, alist = TREE_CHAIN (alist)) - { - tree value = TREE_VALUE (alist); - tree buffer = TREE_VALUE (value); /* this is the buffer */ - tree data = TREE_VALUE (TREE_PURPOSE (value)); /* the location to receive in */ - tree buffer_descr; - tree buffer_descr_init; - tree buffer_length; - tree field; - char fldname[20]; - - /* build descriptor for buffer */ - buffer_length = max_queue_size (TREE_TYPE (buffer)); - if (buffer_length == NULL_TREE) - buffer_length = infinite_buffer_event_length_node; - buffer_descr_init = build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, force_addr_of (buffer), - tree_cons (NULL_TREE, buffer_length, NULL_TREE))); - buffer_descr = decl_temp1 (get_unique_identifier ("RCbuffer"), - TREE_TYPE (descr_type), 0, - buffer_descr_init, 0, 0); - tuple = tree_cons (NULL_TREE, - force_addr_of (buffer_descr), - tuple); - - /* make a field for the union */ - sprintf (fldname, "fld%03d", buffer_cnt); - field = grok_chill_fixedfields ( - tree_cons (NULL_TREE, get_identifier (fldname), NULL_TREE), - TREE_TYPE (data), NULL_TREE); - if (field_decls == NULL_TREE) - field_decls = field; - else - chainon (field_decls, field); - } - - /* generate the union */ - if (field_decls != NULL_TREE) - { - tree data_id = get_identifier ("databuffer"); - tree data_decl; - - union_type_node = finish_struct ( - start_struct (UNION_TYPE, NULL_TREE), - field_decls); - data_decl = decl_temp1 (data_id, union_type_node, 0, NULL_TREE, 0, 0); - - chill_expand_assignment (rc_state->databufp, NOP_EXPR, - force_addr_of (data_decl)); - - chill_expand_assignment (rc_state->datalen, NOP_EXPR, - size_in_bytes (TREE_TYPE (data_decl))); - } - - /* tell runtime system if we had an else or not */ - chill_expand_assignment (rc_state->else_clause, NOP_EXPR, else_clause); - - /* generate the array of pointers to all buffers */ - { - tree array_id = get_identifier ("buf_ptr_array"); - tree array_type_node = - build_chill_array_type (ptr_type_node, - tree_cons (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_one_node, - build_int_2 (buffer_cnt, 0)), - NULL_TREE), - 0, NULL_TREE); - tree constr = build_nt (CONSTRUCTOR, NULL_TREE, nreverse (tuple)); - tree array_decl = decl_temp1 (array_id, array_type_node, 0, - constr, 0, 0); - - chill_expand_assignment (build_chill_cast (ptr_type_node, rc_state->sig_code), - NOP_EXPR, - force_addr_of (array_decl)); - chill_expand_assignment (rc_state->n_sigs, NOP_EXPR, - build_int_2 (buffer_cnt, 0)); - } -} - -/* - * SIG_LIST is a tree list. The TREE_VALUEs are VAR_DECLs of - * __tmp_%s_code variables, and the TREE_PURPOSEs are the - * TYPE_DECLs of the __tmp_%s_struct types. LABEL_CNT is the - * case-label counter passed from build_receive_case_start. - */ -static void -build_receive_signal_case_end (sig_list, else_clause) - tree sig_list, else_clause; -{ - struct rc_state_type *rc_state = current_rc_state; - tree alist, temp1; - tree union_type_node = NULL_TREE; - tree field_decls = NULL_TREE; /* list of signal - structure, for the union */ - tree tuple = NULL_TREE; /* constructor for array of ptrs */ - int signal_cnt = 0; - int fldcnt = 0; - - /* for each list of locations, validate it against the - corresponding signal's list of fields. */ - { - for (alist = sig_list; alist != NULL_TREE; - signal_cnt++, alist = TREE_CHAIN (alist)) - { - tree value = TREE_VALUE (alist); - tree signame = TREE_VALUE (value); /* signal's ID node */ - tree sigdecl = lookup_name (signame); - tree sigtype = TREE_TYPE (sigdecl); - tree field; - char fldname[20]; - - if (IDENTIFIER_SIGNAL_DATA (signame)) - { - sprintf (fldname, "fld%03d", fldcnt++); - field = grok_chill_fixedfields ( - tree_cons (NULL_TREE, - get_identifier (fldname), - NULL_TREE), - sigtype, NULL_TREE); - if (field_decls == NULL_TREE) - field_decls = field; - else - chainon (field_decls, field); - - } - - temp1 = (tree)DECL_TASKING_CODE_DECL (sigdecl); - mark_addressable (temp1); - tuple = tree_cons (NULL_TREE, - build1 (ADDR_EXPR, - build_chill_pointer_type (chill_integer_type_node), - temp1), - tuple); - } - } - - /* generate the union of all of the signal data types */ - if (field_decls != NULL_TREE) - { - tree data_id = get_identifier ("databuffer"); - tree data_decl; - union_type_node = finish_struct (start_struct (UNION_TYPE, - NULL_TREE), - field_decls); - data_decl = - decl_temp1 (data_id, union_type_node, 0, NULL_TREE, 0, 0); - - chill_expand_assignment (rc_state->databufp, NOP_EXPR, - force_addr_of (data_decl)); - - chill_expand_assignment (rc_state->datalen, NOP_EXPR, - size_in_bytes (TREE_TYPE (data_decl))); - } - - /* tell runtime system if we had an else or not */ - chill_expand_assignment (rc_state->else_clause, NOP_EXPR, else_clause); - - /* generate the array of all signal codes */ - { - tree array_id = get_identifier ("sig_code_array"); - tree array_type_node - = build_chill_array_type ( - build_chill_pointer_type (chill_integer_type_node), - tree_cons (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_one_node, - build_int_2 (signal_cnt, 0)), - NULL_TREE), - 0, NULL_TREE); - tree constr = build_nt (CONSTRUCTOR, NULL_TREE, - nreverse (tuple)); - tree array_decl = - decl_temp1 (array_id, array_type_node, 0, constr, 0, 0); - - chill_expand_assignment (rc_state->sig_code, NOP_EXPR, - force_addr_of (array_decl)); - - /* give number of signals to runtime system */ - chill_expand_assignment (rc_state->n_sigs, NOP_EXPR, - build_int_2 (signal_cnt, 0)); - } -} - -/* General function for the end of a RECEIVE CASE action */ - -void -build_receive_case_end (alist, else_clause) - tree alist, else_clause; -{ - rtx rcdone = gen_label_rtx (); - struct rc_state_type *rc_state = current_rc_state; - tree tmp; - int had_errors = 0; - - /* finish the if's, if generated */ - if (rc_state->if_generated) - expand_end_cond (); - - /* check alist for errors */ - for (tmp = alist; tmp != NULL_TREE; tmp = TREE_CHAIN (tmp)) - { - if (TREE_CODE (TREE_VALUE (tmp)) == ERROR_MARK) - had_errors++; - } - - /* jump to the end of RECEIVE CASE processing */ - emit_jump (rcdone); - - /* define the __rcsetup label. We come here to initialize - all variables */ - emit_label (rc_state->rcsetup); - - if (alist == NULL_TREE && !had_errors) - { - error ("RECEIVE CASE without alternatives"); - goto gen_rcdoit; - } - - if (TREE_CODE (alist) == ERROR_MARK || had_errors) - goto gen_rcdoit; - - /* now call the actual end function */ - if (rc_state->bufseen) - build_receive_buffer_case_end (alist, else_clause); - else - build_receive_signal_case_end (alist, else_clause); - - /* now jump to the beginning of RECEIVE CASE processing */ -gen_rcdoit: ; - emit_jump (rc_state->rcdoit); - - /* define the __rcdone label. We come here when the whole - receive case is done. */ - emit_label (rcdone); - - current_rc_state = rc_state->enclosing; - free(rc_state); -} - -/* build a CONTINUE action */ - -void expand_continue_event (evloc) - tree evloc; -{ - tree filename, linenumber, evaddr; - - /* do some checks */ - if (evloc == NULL_TREE || TREE_CODE (evloc) == ERROR_MARK) - return; - - if (! CH_REFERABLE (evloc) || ! CH_IS_EVENT_MODE (TREE_TYPE (evloc))) - { - error ("CONTINUE requires an event location."); - return; - } - - evaddr = force_addr_of (evloc); - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - expand_expr_stmt ( - build_chill_function_call (lookup_name (get_identifier ("__continue")), - tree_cons (NULL_TREE, evaddr, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE))))); -} - -#if 0 - * The following code builds a DELAY CASE statement, - * which looks like this in CHILL: - * - * DCL ev1, ev2 EVENT, ins INSTANCE; - * DCL ev3 EVENT (10); - * DCL count1 INT := 0, count2 INT := 0; - * - * DELAY CASE SET ins; - * (ev1): count1 +:= 1; - * (ev2, ev3): count2 +:= 1; - * ESAC; - * - * Because we don''t know until we get to the ESAC how - * many events need processing, we generate the following - * C-equivalent code: - * - * - * { /* start a new symbol context */ - * typedef struct - * { - * void *p; - * unsigned long len; - * } Descr; - * int number_of_events; - * Descr *event_codes; - * - * goto __dlsetup; - * - * __dldoit: - * void *whatevent = __delay_event (number_of_events, - * event_codes, - * priority, - * &instance_loc, - * filename, - * linenumber); - * if (whatevent == &ev1) - * { - * /* code for ev1 alternative's action_statement_list */ - * count1 += 1; - * } - * else if (whatevent == &ev2 || whatevent == &ev3) - * { - * /* code for ev2 and ev3 alternative's action_statement_list */ - * count2 += 1; - * } - * goto __dl_done; - * - * __dlsetup: - * Descr event_code_ptr [3] = { - * { &ev1, -1 }, - * { &ev2, -1 }, - * { &ev3, 10 } }; - * event_codes = &event_code_ptr[0]; - * number_of_events = 3; - * goto __dldoit; - * - * __dl_done: - * ; - * } /* end the new symbol context */ - * -#endif - -struct dl_state_type -{ - struct dl_state_type *enclosing; - rtx dldoit; - rtx dlsetup; - tree n_events; - tree event_codes; - tree received_event; -}; - -struct dl_state_type *current_dl_state = NULL; - -/* build_receive_case_start returns an INTEGER_CST node - containing the case-label number to be used by - build_receive_case_end to generate correct labels */ -tree -build_delay_case_start (optset, optpriority) - tree optset, optpriority; -{ - /* counter to generate unique delay case labels */ - static int dl_lbl_count = 0; - tree current_label_value = - build_int_2 ((HOST_WIDE_INT)dl_lbl_count, 0); - tree wait_call; - tree actuallist = NULL_TREE; - tree filename, linenumber; - tree to_loc; - - struct dl_state_type *dl_state - = (struct dl_state_type*) xmalloc (sizeof (struct dl_state_type)); - dl_state->enclosing = current_dl_state; - current_dl_state = dl_state; - dl_state->dldoit = gen_label_rtx (); - dl_state->dlsetup = gen_label_rtx (); - - dl_lbl_count++; - - /* check the optional SET location */ - if (optset == NULL_TREE - || TREE_CODE (optset) == ERROR_MARK) - optset = null_pointer_node; - else if (CH_IS_INSTANCE_MODE (TREE_TYPE (optset)) && CH_LOCATION_P (optset)) - optset = force_addr_of (optset); - else - { - error ("SET requires INSTANCE location"); - optset = null_pointer_node; - } - - /* check the presence of the PRIORITY expression */ - if (optpriority == NULL_TREE) - optpriority = integer_zero_node; - else if (TREE_CODE (optpriority) == ERROR_MARK) - optpriority = integer_zero_node; - else if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE) - { - error ("PRIORITY must be of integer type."); - optpriority = integer_zero_node; - } - - /* check for time supervised */ - to_loc = build_timeout_preface (); - - dl_state->n_events = - decl_temp1 (get_identifier ("number_of_events"), - integer_type_node, 0, integer_zero_node, 0, 0); - - dl_state->event_codes = - decl_temp1 (get_identifier ("event_codes"), - ptr_type_node, 0, null_pointer_node, 0, 0); - - /* wait_event will store the signal number in here */ - dl_state->received_event = - decl_temp1 (get_identifier ("received_event"), - ptr_type_node, 0, NULL_TREE, 0, 0); - - /* now jump to the end of RECEIVE CASE actions, to - set up variables for them. */ - emit_jump (dl_state->dlsetup); - - /* define the __rcdoit label. We come here after - initialization of all variables, to execute the - actions. */ - emit_label (dl_state->dldoit); - - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - /* here we go, call the runtime routine */ - actuallist = tree_cons (NULL_TREE, force_addr_of (dl_state->received_event), - tree_cons (NULL_TREE, dl_state->n_events, - tree_cons (NULL_TREE, dl_state->event_codes, - tree_cons (NULL_TREE, optpriority, - tree_cons (NULL_TREE, to_loc, - tree_cons (NULL_TREE, optset, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))); - - wait_call = build_chill_function_call ( - lookup_name (get_identifier ("__delay_event")), - actuallist); - -#if 0 - chill_expand_assignment (dl_state->received_event, NOP_EXPR, wait_call); -#endif - build_timesupervised_call (wait_call, to_loc); - return current_label_value; -} - -/* - EVENTLIST is the list of this alternative's events - and IF_OR_ELSEIF indicates what action (1 for if and - 0 for else if) should be generated. -*/ -void -build_delay_case_label (eventlist, if_or_elseif) - tree eventlist; - int if_or_elseif; -{ - tree eventp, expr = NULL_TREE; - - if (eventlist == NULL_TREE || TREE_CODE (eventlist) == ERROR_MARK) - return; - - for (eventp = eventlist; eventp != NULL_TREE; - eventp = TREE_CHAIN (eventp)) - { - tree event = TREE_VALUE (eventp); - tree temp1; - - if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK) - temp1 = null_pointer_node; - else if (! CH_IS_EVENT_MODE (TREE_TYPE (event)) || ! CH_REFERABLE (event)) - { - error ("delay alternative must be an EVENT location."); - temp1 = null_pointer_node; - } - else - temp1 = force_addr_of (event); - - /* build the conditional expression */ - if (expr == NULL_TREE) - expr = build (EQ_EXPR, boolean_type_node, - current_dl_state->received_event, temp1); - else - expr = - build (TRUTH_ORIF_EXPR, boolean_type_node, expr, - build (EQ_EXPR, boolean_type_node, - current_dl_state->received_event, temp1)); - } - if (if_or_elseif) - expand_start_cond (expr, 0); - else - expand_start_elseif (expr); - - /* last action here */ - emit_line_note (input_filename, lineno); -} - -/* - * EVENT_LIST is a tree list. The TREE_VALUEs are VAR_DECLs of - * EVENT variables. LABEL_CNT is the case-label counter - * passed from build_delay_case_start. - */ -void -build_delay_case_end (event_list) - tree event_list; -{ - struct dl_state_type *dl_state = current_dl_state; - rtx dldone = gen_label_rtx (); - tree tuple = NULL_TREE; /* constructor for array of descrs */ - tree acode; - int event_cnt = 0; - - /* if we have an empty event_list, there was no alternatives and we - havn't started an if therefor don't run expand_end_cond */ - if (event_list != NULL_TREE) - /* finish the if's */ - expand_end_cond (); - - /* jump to the end of RECEIVE CASE processing */ - emit_jump (dldone); - - /* define the __dlsetup label. We come here to initialize - all variables */ - emit_label (dl_state->dlsetup); - - if (event_list == NULL_TREE) - { - error ("DELAY CASE without alternatives"); - goto gen_dldoit; - } - - if (event_list == NULL_TREE - || TREE_CODE (event_list) == ERROR_MARK) - goto gen_dldoit; - - /* make a list of pointers (in reverse order) - to the event code variables */ - for (acode = event_list; acode != NULL_TREE; - acode = TREE_CHAIN (acode)) - { - tree event = TREE_VALUE (acode); - tree event_length; - tree descr_init; - - if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK) - { - descr_init = - tree_cons (NULL_TREE, null_pointer_node, - tree_cons (NULL_TREE, integer_zero_node, NULL_TREE)); - } - else - { - event_length = max_queue_size (TREE_TYPE (event)); - if (event_length == NULL_TREE) - event_length = infinite_buffer_event_length_node; - descr_init = - tree_cons (NULL_TREE, force_addr_of (event), - tree_cons (NULL_TREE, event_length, NULL_TREE)); - } - tuple = tree_cons (NULL_TREE, - build_nt (CONSTRUCTOR, NULL_TREE, descr_init), - tuple); - event_cnt++; - } - - /* generate the array of all event code pointers */ - { - tree descr_type = TREE_TYPE (lookup_name (get_identifier ("__tmp_DESCR_type"))); - tree array_id = get_identifier ("event_code_array"); - tree array_type_node - = build_chill_array_type (descr_type, - tree_cons (NULL_TREE, - build_chill_range_type (NULL_TREE, - integer_one_node, - build_int_2 (event_cnt, 0)), - NULL_TREE), - 0, NULL_TREE); - tree constr = build_nt (CONSTRUCTOR, NULL_TREE, - nreverse (tuple)); - tree array_decl = - decl_temp1 (array_id, array_type_node, 0, constr, 0, 0); - - chill_expand_assignment (dl_state->event_codes, NOP_EXPR, - force_addr_of (array_decl)); - - /* give number of signals to runtime system */ - chill_expand_assignment (dl_state->n_events, NOP_EXPR, - build_int_2 (event_cnt, 0)); - } - - /* now jump to the beginning of DELAY CASE processing */ -gen_dldoit: - emit_jump (dl_state->dldoit); - - /* define the __dldone label. We come here when the whole - DELAY CASE is done. */ - emit_label (dldone); - - current_dl_state = dl_state->enclosing; - free(dl_state); -} - -#if 0 - * The following code builds a simple delay statement, - * which looks like this in CHILL: - * - * DCL ev1 EVENT(5), ins INSTANCE; - * - * DELAY ev1 PRIORITY 7; - * - * This statement unconditionally delays the current - * PROCESS, until some other process CONTINUEs it. - * - * Here is the generated C code: - * - * typedef struct - * { - * void *p; - * unsigned long len; - * } Descr; - * - * static short __tmp_ev1_code; - * - * { /* start a new symbol context */ - * - * Descr __delay_array[1] = { { ev1, 5 } }; - * - * __delay_event (1, &__delay_array, 7, NULL, - * filename, linenumber); - * - * } /* end of symbol scope */ - */ -#endif -void -build_delay_action (event, optpriority) - tree event, optpriority; -{ - int had_errors = 0; - tree to_loc = NULL_TREE; - /* we discard the return value of __delay_event, cause in - a normal DELAY action no selections have to be made */ - tree ev_got = null_pointer_node; - - /* check the event */ - if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK) - had_errors = 1; - else if (! CH_IS_EVENT_MODE (TREE_TYPE (event)) || ! CH_REFERABLE (event)) - { - error ("DELAY action requires an event location."); - had_errors = 1; - } - - /* check the presence of priority */ - if (optpriority != NULL_TREE) - { - if (TREE_CODE (optpriority) == ERROR_MARK) - return; - if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE) - { - error ("PRIORITY in DELAY action must be of integer type."); - return; - } - } - else - { - /* issue a warning in case of -Wall */ - if (extra_warnings) - { - warning ("DELAY action without priority."); - warning (" PRIORITY defaulted to 0."); - } - optpriority = integer_zero_node; - } - if (had_errors) - return; - - { - tree descr_type; - tree array_type_node; - tree array_decl; - tree descr_init; - tree array_init; - tree event_length = max_queue_size (TREE_TYPE (event)); - tree event_codes; - tree filename = force_addr_of (get_chill_filename ()); - tree linenumber = get_chill_linenumber (); - tree actuallist; - - to_loc = build_timeout_preface (); - - descr_type = TREE_TYPE (lookup_name (get_identifier ("__tmp_DESCR_type"))); - - array_type_node = - build_chill_array_type (descr_type, - tree_cons (NULL_TREE, - build_chill_range_type (NULL_TREE, integer_one_node, - integer_one_node), - NULL_TREE), - 0, NULL_TREE); - if (event_length == NULL_TREE) - event_length = infinite_buffer_event_length_node; - - descr_init = - tree_cons (NULL_TREE, force_addr_of (event), - tree_cons (NULL_TREE, event_length, NULL_TREE)); - array_init = - tree_cons (NULL_TREE, - build_nt (CONSTRUCTOR, NULL_TREE, descr_init), - NULL_TREE); - array_decl = - decl_temp1 (get_unique_identifier ("event_codes_array"), - array_type_node, 0, - build_nt (CONSTRUCTOR, NULL_TREE, array_init), - 0, 0); - - event_codes = - decl_temp1 (get_unique_identifier ("event_ptr"), - ptr_type_node, 0, - force_addr_of (array_decl), - 0, 0); - - actuallist = - tree_cons (NULL_TREE, ev_got, - tree_cons (NULL_TREE, integer_one_node, - tree_cons (NULL_TREE, event_codes, - tree_cons (NULL_TREE, optpriority, - tree_cons (NULL_TREE, to_loc, - tree_cons (NULL_TREE, null_pointer_node, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))); - - - build_timesupervised_call ( - build_chill_function_call ( - lookup_name (get_identifier ("__delay_event")), - actuallist), to_loc); - } -} - -void -expand_send_buffer (buffer, value, optpriority, optwith, optto) - tree buffer, value, optpriority, optwith, optto; -{ - tree filename, linenumber; - tree buffer_mode_decl = NULL_TREE; - tree buffer_ptr, value_ptr; - int had_errors = 0; - tree timeout_value, fcall; - - /* check buffer location */ - if (buffer == NULL_TREE || TREE_CODE (buffer) == ERROR_MARK) - { - buffer = NULL_TREE; - had_errors = 1; - } - if (buffer != NULL_TREE) - { - if (! CH_IS_BUFFER_MODE (TREE_TYPE (buffer)) || ! CH_REFERABLE (buffer)) - { - error ("send buffer action requires a BUFFER location."); - had_errors = 1; - } - else - buffer_mode_decl = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (buffer))); - } - - /* check value and type */ - if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK) - { - had_errors = 1; - value = NULL_TREE; - } - if (value != NULL_TREE) - { - if (TREE_CHAIN (value) != NULL_TREE) - { - error ("there must be only 1 value for send buffer action."); - had_errors = 1; - } - else - { - value = TREE_VALUE (value); - if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK) - { - had_errors = 1; - value = NULL_TREE; - } - if (value != NULL_TREE && buffer_mode_decl != NULL_TREE) - { - if (TREE_TYPE (buffer_mode_decl) != NULL_TREE && - TREE_CODE (TREE_TYPE (buffer_mode_decl)) == ERROR_MARK) - had_errors = 1; - else if (CH_COMPATIBLE (value, TREE_TYPE (buffer_mode_decl))) - { - value = convert (TREE_TYPE (buffer_mode_decl), value); - if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK) - { - error ("convert failed for send buffer action."); - had_errors = 1; - } - } - else - { - error ("incompatible modes in send buffer action."); - had_errors = 1; - } - } - } - } - - /* check the presence of priority */ - if (optpriority == NULL_TREE) - { - if (send_buffer_prio == NULL_TREE) - { - /* issue a warning in case of -Wall */ - if (extra_warnings) - { - warning ("Buffer sent without priority"); - warning (" and no default priority was set."); - warning (" PRIORITY defaulted to 0."); - } - optpriority = integer_zero_node; - } - else - optpriority = send_buffer_prio; - } - else if (TREE_CODE (optpriority) == ERROR_MARK) - had_errors = 1; - else if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE) - { - error ("PRIORITY must be of integer type."); - had_errors = 1; - } - - if (optwith != NULL_TREE) - { - error ("WITH not allowed for send buffer action."); - had_errors = 1; - } - if (optto != NULL_TREE) - { - error ("TO not allowed for send buffer action."); - had_errors = 1; - } - if (had_errors) - return; - - { - tree descr_type; - tree buffer_descr, buffer_init, buffer_length; - tree val; - - /* process timeout */ - timeout_value = build_timeout_preface (); - - descr_type = lookup_name (get_identifier ("__tmp_DESCR_type")); - - /* build descr for buffer */ - buffer_length = max_queue_size (TREE_TYPE (buffer)); - if (buffer_length == NULL_TREE) - buffer_length = infinite_buffer_event_length_node; - buffer_init = build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, force_addr_of (buffer), - tree_cons (NULL_TREE, buffer_length, NULL_TREE))); - buffer_descr = decl_temp1 (get_unique_identifier ("buffer_descr"), - TREE_TYPE (descr_type), 0, buffer_init, - 0, 0); - buffer_ptr = decl_temp1 (get_unique_identifier ("buffer_ptr"), - ptr_type_node, 0, - force_addr_of (buffer_descr), - 0, 0); - - /* build descr for value */ - if (! CH_REFERABLE (value)) - val = decl_temp1 (get_identifier ("buffer_value"), - TREE_TYPE (value), 0, - value, 0, 0); - else - val = value; - - value_ptr = build_chill_descr (val); - - } - - /* get filename and linenumber */ - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - - /* Now, we can call the runtime */ - fcall = build_chill_function_call ( - lookup_name (get_identifier ("__send_buffer")), - tree_cons (NULL_TREE, buffer_ptr, - tree_cons (NULL_TREE, value_ptr, - tree_cons (NULL_TREE, optpriority, - tree_cons (NULL_TREE, timeout_value, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE))))))); - build_timesupervised_call (fcall, timeout_value); -} -# if 0 - -void -process_buffer_decls (namelist, mode, optstatic) - tree namelist, mode; - int optstatic; -{ - tree names; - int quasi_flag = current_module->is_spec_module; - - if (pass < 2) - return; - - for (names = namelist; names != NULL_TREE; names = TREE_CHAIN (names)) - { - tree name = TREE_VALUE (names); - tree bufdecl = lookup_name (name); - tree code_decl = - decl_tasking_code_variable (name, &buffer_code, quasi_flag); - - /* remember the code variable in the buffer decl */ - DECL_TASKING_CODE_DECL (bufdecl) = (struct lang_decl *)code_decl; - - add_taskstuff_to_list (code_decl, "_TT_Buffer", - quasi_flag ? NULL_TREE : buffer_code, - bufdecl); - } -} -#endif - -/* - * if no queue size was specified, QUEUESIZE is integer_zero_node. - */ -tree -build_buffer_type (element_type, queuesize) - tree element_type, queuesize; -{ - tree type, field; - if (element_type == NULL_TREE || TREE_CODE (element_type) == ERROR_MARK) - return error_mark_node; - if (queuesize != NULL_TREE && TREE_CODE (queuesize) == ERROR_MARK) - return error_mark_node; - - type = make_node (RECORD_TYPE); - field = build_decl (FIELD_DECL, get_identifier("__buffer_data"), - ptr_type_node); - TYPE_FIELDS (type) = field; - TREE_CHAIN (field) - = build_lang_decl (TYPE_DECL, get_identifier ("__element_mode"), - element_type); - field = TREE_CHAIN (field); - if (queuesize) - { - tree size_field = build_decl (CONST_DECL, get_identifier("__queue_max"), - integer_type_node); - DECL_INITIAL (size_field) = queuesize; - TREE_CHAIN (field) = size_field; - } - CH_IS_BUFFER_MODE (type) = 1; - CH_TYPE_NONVALUE_P (type) = 1; - if (pass == 2) - type = layout_chill_struct_type (type); - return type; -} - -#if 0 -tree -build_buffer_descriptor (bufname, expr, optpriority) - tree bufname, expr, optpriority; -{ - tree bufdecl; - - if (bufname == NULL_TREE - || TREE_CODE (bufname) == ERROR_MARK) - return error_mark_node; - - if (expr != NULL_TREE - && TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; -#if 0 -/* FIXME: is this what we really want to test? */ - bufdecl = lookup_name (bufname); - if (TREE_CODE (bufdecl) != TYPE_DECL - || ! CH_IS_BUFFER_MODE (TREE_TYPE (bufdecl))) - { - error ("SEND requires a BUFFER; `%s' is not a BUFFER name", - bufname); - return error_mark_node; - } -#endif - { - /* build buffer/signal data structure */ - tree bufdataname = get_unique_identifier (IDENTIFIER_POINTER (bufname)); - tree dataptr; - - if (expr == NULL_TREE) - dataptr = null_pointer_node; - else - { - tree decl = - decl_temp1 (bufdataname, TREE_TYPE (bufdecl), 0, - expr, 0, 0); - /* prevent granting of this variable */ - DECL_SOURCE_LINE (decl) = 0; - - dataptr = force_addr_of (decl); - } - - /* build descriptor pointing to buffer data */ - { - tree tasking_message_var = get_unique_identifier (IDENTIFIER_POINTER (bufname)); - tree data_len = (expr == NULL_TREE) ? integer_zero_node : - size_in_bytes (TREE_TYPE (bufdecl)); - tree tasking_code = (tree)DECL_TASKING_CODE_DECL (bufdecl); - tree tuple = build_nt (CONSTRUCTOR, NULL_TREE, - tree_cons (NULL_TREE, - build1 (ADDR_EXPR, - build_chill_pointer_type (chill_integer_type_node), - tasking_code), - tree_cons (NULL_TREE, data_len, - tree_cons (NULL_TREE, dataptr, NULL_TREE)))); - - tree decl = decl_temp1 (tasking_message_var, - TREE_TYPE (tasking_message_type), 0, - tuple, 0, 0); - mark_addressable (tasking_code); - /* prevent granting of this variable */ - DECL_SOURCE_LINE (decl) = 0; - - tuple = force_addr_of (decl); - return tuple; - } - } -} -#endif - -#if 0 -void -process_event_decls (namelist, mode, optstatic) - tree namelist, mode; - int optstatic; -{ - tree names; - int quasi_flag = current_module->is_spec_module; - - if (pass < 2) - return; - - for (names = namelist; names != NULL_TREE; names = TREE_CHAIN (names)) - { - tree name = TREE_VALUE (names); - tree eventdecl = lookup_name (name); - tree code_decl = - decl_tasking_code_variable (name, &event_code, quasi_flag); - - /* remember the code variable in the event decl */ - DECL_TASKING_CODE_DECL (eventdecl) = (struct lang_decl *)code_decl; - - add_taskstuff_to_list (code_decl, "_TT_Event", - quasi_flag ? NULL_TREE : event_code, - eventdecl); - } -} -#endif - -/* Return the buffer or event length of a buffer or event mode. - (NULL_TREE means unlimited.) */ - -tree -max_queue_size (mode) - tree mode; -{ - tree field = TYPE_FIELDS (mode); - for ( ; field != NULL_TREE ; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == CONST_DECL) - return DECL_INITIAL (field); - } - return NULL_TREE; -} - -/* Return the buffer element mode of a buffer mode. */ - -tree -buffer_element_mode (bufmode) - tree bufmode; -{ - tree field = TYPE_FIELDS (bufmode); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == TYPE_DECL) - return TREE_TYPE (field); - } - return NULL_TREE; -} - -/* invalidate buffer element mode in case we detect, that the - elelment mode has the non-value property */ - -void -invalidate_buffer_element_mode (bufmode) - tree bufmode; -{ - tree field = TYPE_FIELDS (bufmode); - for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) - { - if (TREE_CODE (field) == TYPE_DECL) - { - TREE_TYPE (field) = error_mark_node; - return; - } - } -} - -/* For an EVENT or BUFFER mode TYPE, with a give maximum queue size QSIZE, - perform various error checks. Return a new queue size. */ - -tree -check_queue_size (qsize) - tree qsize; -{ - if (qsize == NULL_TREE || TREE_CODE (qsize) == ERROR_MARK) - return qsize; - if (TREE_TYPE (qsize) == NULL_TREE - || !CH_SIMILAR (TREE_TYPE (qsize), integer_type_node)) - { - error ("non-integral max queue size for EVENT/BUFFER mode"); - return integer_one_node; - } - if (TREE_CODE (qsize) != INTEGER_CST) - { - error ("non-constant max queue size for EVENT/BUFFER mode"); - return integer_one_node; - } - if (compare_int_csts (pedantic ? LE_EXPR : LT_EXPR, - qsize, - integer_zero_node)) - { - error ("max queue_size for EVENT/BUFFER is not positive"); - return integer_one_node; - } - return qsize; -} - -/* - * An EVENT type is modelled as a boolean type, which should - * allocate the minimum amount of space. - */ -tree -build_event_type (queuesize) - tree queuesize; -{ - tree type = make_node (RECORD_TYPE); - tree field = build_decl (FIELD_DECL, get_identifier("__event_data"), - ptr_type_node); - TYPE_FIELDS (type) = field; - if (queuesize) - { - tree size_field = build_decl (CONST_DECL, get_identifier("__queue_max"), - integer_type_node); - DECL_INITIAL (size_field) = queuesize; - TREE_CHAIN (field) = size_field; - } - CH_IS_EVENT_MODE (type) = 1; - CH_TYPE_NONVALUE_P (type) = 1; - if (pass == 2) - type = layout_chill_struct_type (type); - return type; -} - -/* - * Initialize the various types of tasking data. - */ -void -tasking_init () -{ - extern int ignore_case; - extern int special_UC; - extern tree chill_predefined_function_type; - tree temp, ins_ftype_void; - tree endlink = void_list_node; - tree int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int; - tree void_ftype_ptr; - tree void_ftype_ptr_ins_int_int_ptr_ptr_int; - tree int_ftype_ptr_ptr_int_ptr_ptr_int; - tree void_ftype_int_int_int_ptr_ptr_ptr_int; - tree int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int; - tree int_ftype_ptr_int; - - /* type of tasking code variables */ - chill_taskingcode_type_node = short_unsigned_type_node; - - void_ftype_void = - build_function_type (void_type_node, - tree_cons (NULL_TREE, void_type_node, NULL_TREE)); - - build_instance_type (); - ins_ftype_void - = build_function_type (instance_type_node, - tree_cons (NULL_TREE, void_type_node, - build_tree_list (NULL_TREE, void_type_node))); - - builtin_function ("__whoami", ins_ftype_void, - 0, NOT_BUILT_IN, NULL_PTR); - - build_tasking_message_type (); - - temp = build_decl (TYPE_DECL, - get_identifier ("__tmp_TaskingStruct"), - build_tasking_struct ()); - pushdecl (temp); - DECL_SOURCE_LINE (temp) = 0; - - /* any SIGNAL will be compatible with this one */ - generic_signal_type_node = copy_node (boolean_type_node); - - builtin_function ((ignore_case || ! special_UC) ? "copy_number" : "COPY_NUMBER", - chill_predefined_function_type, - BUILT_IN_COPY_NUMBER, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gen_code" : "GEN_CODE", - chill_predefined_function_type, - BUILT_IN_GEN_CODE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gen_inst" : "GEN_INST", - chill_predefined_function_type, - BUILT_IN_GEN_INST, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gen_ptype" : "GEN_PTYPE", - chill_predefined_function_type, - BUILT_IN_GEN_PTYPE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "proc_type" : "PROC_TYPE", - chill_predefined_function_type, - BUILT_IN_PROC_TYPE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "queue_length" : "QUEUE_LENGTH", - chill_predefined_function_type, - BUILT_IN_QUEUE_LENGTH, BUILT_IN_NORMAL, NULL_PTR); - - int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))))))); - void_ftype_ptr - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, endlink)); - - int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))))); - - void_ftype_ptr_ins_int_int_ptr_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, instance_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))))); - int_ftype_ptr_ptr_int_ptr_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))))); - - void_ftype_int_int_int_ptr_ptr_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))))); - - int_ftype_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))); - - builtin_function ("__delay_event", int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__queue_length", int_ftype_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__register_tasking", void_ftype_ptr, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__send_signal", void_ftype_ptr_ins_int_int_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__send_buffer", int_ftype_ptr_ptr_int_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__start_process", void_ftype_int_int_int_ptr_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__stop_process", void_ftype_void, 0, NOT_BUILT_IN, - NULL_PTR); - builtin_function ("__wait_buffer", int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__wait_signal_timed", int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - - infinite_buffer_event_length_node = build_int_2 (-1, 0); - TREE_TYPE (infinite_buffer_event_length_node) = long_integer_type_node; - TREE_UNSIGNED (infinite_buffer_event_length_node) = 1; -} diff --git a/gcc/ch/tasking.h b/gcc/ch/tasking.h deleted file mode 100644 index 7650c2f8cc9..00000000000 --- a/gcc/ch/tasking.h +++ /dev/null @@ -1,27 +0,0 @@ -/* Implement process-related declarations for CHILL. - Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#ifndef _CH_TASKING_H -#define _CH_TASKING_H - -/* list of this module's process, buffer, etc. decls */ -extern tree tasking_list; - -#endif diff --git a/gcc/ch/timing.c b/gcc/ch/timing.c deleted file mode 100644 index b7479071120..00000000000 --- a/gcc/ch/timing.c +++ /dev/null @@ -1,491 +0,0 @@ -/* Implement timing-related actions for CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 2000, 2001 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "rtl.h" -#include "ch-tree.h" -#include "flags.h" -#include "input.h" -#include "obstack.h" -#include "lex.h" -#include "toplev.h" - -/* set non-zero if input text is forced to lowercase */ -extern int ignore_case; - -/* set non-zero if special words are to be entered in uppercase */ -extern int special_UC; - -/* timing modes */ -tree abs_timing_type_node; -tree duration_timing_type_node; - -/* rts time type */ -static tree rtstime_type_node = NULL_TREE; - -/* the stack for AFTER primval [ DELAY ] IN - and has following layout - - TREE_VALUE (TREE_VALUE (after_stack)) = current time or NULL_TREE (if DELAY specified) - TREE_PURPOSE (TREE_VALUE (after_stack)) = the duration location - TREE_VALUE (TREE_PURPOSE (after_stack)) = label at TIMEOUT - TREE_PURPOSE (TREE_PURPOSE (after_stack)) = label at the end of AFTER action -*/ -tree after_stack = NULL_TREE; - -/* in pass 1 we need a separate list for the labels */ -static tree after_stack_pass_1 = NULL_TREE; -static tree after_help; - -void -timing_init () -{ - tree ptr_ftype_durt_ptr_int; - tree int_ftype_abst_ptr_int; - tree void_ftype_ptr; - tree long_ftype_int_int_int_int_int_int_int_ptr_int; - tree void_ftype_abstime_ptr; - tree int_ftype_ptr_durt_ptr; - tree void_ftype_durt_ptr; - tree void_ftype_ptr_durt_ptr_int; - tree temp; - tree endlink; - tree ulong_type; - - ulong_type = TREE_TYPE (lookup_name ( - get_identifier ((ignore_case || ! special_UC ) ? - "ulong" : "ULONG"))); - - /* build modes for TIME and DURATION */ - duration_timing_type_node = make_unsigned_type (LONG_TYPE_SIZE); - temp = pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_DURATION], - duration_timing_type_node)); - SET_CH_NOVELTY_NONNIL (duration_timing_type_node, temp); - abs_timing_type_node = make_unsigned_type (LONG_TYPE_SIZE); - temp = pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_TIME], - abs_timing_type_node)); - SET_CH_NOVELTY_NONNIL (abs_timing_type_node, temp); - - /* the mode of time the runtimesystem returns */ - if (rtstime_type_node == NULL_TREE) - { - tree decl1, decl2, result; - - decl1 = build_decl (FIELD_DECL, - get_identifier ("secs"), - ulong_type); - DECL_INITIAL (decl1) = NULL_TREE; - decl2 = build_decl (FIELD_DECL, - get_identifier ("nsecs"), - ulong_type); - DECL_INITIAL (decl2) = NULL_TREE; - TREE_CHAIN (decl2) = NULL_TREE; - TREE_CHAIN (decl1) = decl2; - - result = build_chill_struct_type (decl1); - pushdecl (temp = build_decl (TYPE_DECL, - get_identifier ("__tmp_rtstime"), result)); - DECL_SOURCE_LINE (temp) = 0; - satisfy_decl (temp, 0); - rtstime_type_node = TREE_TYPE (temp); - } - - endlink = void_list_node; - - ptr_ftype_durt_ptr_int - = build_function_type (ptr_type_node, - tree_cons (NULL_TREE, duration_timing_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - - int_ftype_abst_ptr_int - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, abs_timing_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))); - - void_ftype_ptr - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - endlink)); - - long_ftype_int_int_int_int_int_int_int_ptr_int - = build_function_type (abs_timing_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink)))))))))); - - void_ftype_abstime_ptr - = build_function_type (void_type_node, - tree_cons (NULL_TREE, abs_timing_type_node, - tree_cons (NULL_TREE, ptr_type_node, - endlink))); - - int_ftype_ptr_durt_ptr - = build_function_type (integer_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, duration_timing_type_node, - tree_cons (NULL_TREE, ptr_type_node, - endlink)))); - - void_ftype_durt_ptr - = build_function_type (void_type_node, - tree_cons (NULL_TREE, duration_timing_type_node, - tree_cons (NULL_TREE, ptr_type_node, - endlink))); - - void_ftype_ptr_durt_ptr_int - = build_function_type (void_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, duration_timing_type_node, - tree_cons (NULL_TREE, ptr_type_node, - tree_cons (NULL_TREE, integer_type_node, - endlink))))); - - builtin_function ("_abstime", long_ftype_int_int_int_int_int_int_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__check_cycle", void_ftype_ptr_durt_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__convert_duration_rtstime", void_ftype_durt_ptr, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__define_timeout", ptr_ftype_durt_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("_inttime", void_ftype_abstime_ptr, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__remaintime", int_ftype_ptr_durt_ptr, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__rtstime", void_ftype_ptr, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__wait_until", int_ftype_abst_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); -} - -#if 0 - * - * build AT action - * - * AT primval IN - * ok-actionlist - * TIMEOUT - * to-actionlist - * END; - * - * gets translated to - * - * if (__wait_until (primval) == 0) - * ok-actionlist - * else - * to-action-list - * -#endif - -void -build_at_action (t) - tree t; -{ - tree abstime, expr, filename, fcall; - - if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK) - abstime = convert (abs_timing_type_node, build_int_2 (0, 0)); - else - abstime = t; - - if (TREE_TYPE (abstime) != abs_timing_type_node) - { - error ("absolute time value must be of mode TIME."); - abstime = convert (abs_timing_type_node, build_int_2 (0, 0)); - } - filename = force_addr_of (get_chill_filename ()); - fcall = build_chill_function_call ( - lookup_name (get_identifier ("__wait_until")), - tree_cons (NULL_TREE, abstime, - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); - expr = build (EQ_EXPR, integer_type_node, fcall, integer_zero_node); - expand_start_cond (expr, 0); - emit_line_note (input_filename, lineno); -} - -#if 0 - * - * build CYCLE action - * - * CYCLE primval IN - * actionlist - * END; - * - * gets translated to - * - * { - * RtsTime now; - * label: - * __rtstime (&now); - * actionlist - * __check_cycle (&now, primval, filename, lineno); - * goto label; - * } - * -#endif - -tree -build_cycle_start (t) - tree t; -{ - tree purpose = build_tree_list (NULL_TREE, NULL_TREE); - tree toid = build_tree_list (purpose, NULL_TREE); - - /* define the label. Note: define_label needs to be called in - pass 1 and pass 2. */ - TREE_VALUE (toid) = define_label (input_filename, lineno, - get_unique_identifier ("CYCLE_label")); - if (! ignoring) - { - tree duration_value, now_location; - - if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK) - duration_value = convert (duration_timing_type_node, build_int_2 (0,0)); - else - duration_value = t; - - if (TREE_TYPE (duration_value) != duration_timing_type_node) - { - error ("duration primitive value must be of mode DURATION."); - duration_value = convert (duration_timing_type_node, build_int_2 (0,0)); - } - TREE_PURPOSE (TREE_PURPOSE (toid)) = duration_value; - /* define the variable */ - now_location = decl_temp1 (get_unique_identifier ("CYCLE_var"), - rtstime_type_node, 0, - NULL_TREE, 0, 0); - TREE_VALUE (TREE_PURPOSE (toid)) = force_addr_of (now_location); - - /* build the call to __rtstime */ - expand_expr_stmt ( - build_chill_function_call (lookup_name (get_identifier ("__rtstime")), - build_tree_list (NULL_TREE, TREE_VALUE (TREE_PURPOSE (toid))))); - } - - return toid; -} - -void -build_cycle_end (toid) - tree toid; -{ - tree filename, linenumber; - - /* here we call __check_cycle and then jump to beginning of this - action */ - filename = force_addr_of (get_chill_filename ()); - linenumber = get_chill_linenumber (); - expand_expr_stmt ( - build_chill_function_call ( - lookup_name (get_identifier ("__check_cycle")), - tree_cons (NULL_TREE, TREE_VALUE (TREE_PURPOSE (toid)), - tree_cons (NULL_TREE, TREE_PURPOSE (TREE_PURPOSE (toid)), - tree_cons (NULL_TREE, filename, - tree_cons (NULL_TREE, linenumber, NULL_TREE)))))); - expand_goto (TREE_VALUE (toid)); -} - -#if 0 - * - * build AFTER ACTION - * - * AFTER primval [ DELAY ] IN - * action-list - * TIMEOUT - * to-action-list - * END - * - * gets translated to - * - * { - * struct chill_time __now; - * duration dur = primval; - * if (! delay_spceified) - * __rts_time (&__now); - * . - * . - * goto end-label; - * to-label: - * . - * . - * end-label: - * } - * -#endif - -void -build_after_start (duration, delay_flag) - tree duration; - int delay_flag; -{ - tree value, purpose; - - if (! ignoring) - { - value = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - purpose = after_stack_pass_1; - after_stack_pass_1 = TREE_CHAIN (after_stack_pass_1); - after_stack = tree_cons (purpose, value, after_stack); - - if (TREE_TYPE (duration) != duration_timing_type_node) - { - error ("duration primitive value must be of mode DURATION."); - duration = convert (duration_timing_type_node, build_int_2 (0,0)); - } - TREE_PURPOSE (value) = decl_temp1 (get_identifier ("AFTER_duration"), - duration_timing_type_node, 0, - duration, 0, 0); - - if (! delay_flag) - { - /* in this case we have to get the current time */ - TREE_VALUE (value) = decl_temp1 (get_unique_identifier ("AFTER_now"), - rtstime_type_node, 0, - NULL_TREE, 0, 0); - /* build the function call to initialize the variable */ - expand_expr_stmt ( - build_chill_function_call (lookup_name (get_identifier ("__rtstime")), - build_tree_list (NULL_TREE, force_addr_of (TREE_VALUE (value))))); - } - } - else - { - /* in pass 1 we just save the labels */ - after_help = tree_cons (NULL_TREE, NULL_TREE, after_help); - after_stack_pass_1 = chainon (after_stack_pass_1, after_help); - } -} - -void -build_after_timeout_start () -{ - tree label_name; - - if (! ignoring) - { - /* jump to the end of AFTER action */ - lookup_and_expand_goto (TREE_PURPOSE (TREE_PURPOSE (after_stack))); - label_name = TREE_VALUE (TREE_PURPOSE (after_stack)); - /* mark we are in TIMEOUT part of AFTER action */ - TREE_VALUE (TREE_PURPOSE (after_stack)) = NULL_TREE; - } - else - { - label_name = get_unique_identifier ("AFTER_tolabel"); - TREE_VALUE (after_help) = label_name; - } - define_label (input_filename, lineno, label_name); -} - -void -build_after_end () -{ - tree label_name; - - /* define the end label */ - if (! ignoring) - { - label_name = TREE_PURPOSE (TREE_PURPOSE (after_stack)); - after_stack = TREE_CHAIN (after_stack); - } - else - { - label_name = get_unique_identifier ("AFTER_endlabel"); - TREE_PURPOSE (after_help) = label_name; - after_help = TREE_CHAIN (after_help); - } - define_label (input_filename, lineno, label_name); -} - -tree -build_timeout_preface () -{ - tree timeout_value = null_pointer_node; - - if (after_stack != NULL_TREE && - TREE_VALUE (TREE_PURPOSE (after_stack)) != NULL_TREE) - { - tree to_loc; - - to_loc = decl_temp1 (get_unique_identifier ("TOloc"), - rtstime_type_node, 0, NULL_TREE, 0, 0); - timeout_value = force_addr_of (to_loc); - - if (TREE_VALUE (TREE_VALUE (after_stack)) == NULL_TREE) - { - /* DELAY specified -- just call __convert_duration_rtstime for - given duration value */ - expand_expr_stmt ( - build_chill_function_call ( - lookup_name (get_identifier ("__convert_duration_rtstime")), - tree_cons (NULL_TREE, TREE_PURPOSE (TREE_VALUE (after_stack)), - tree_cons (NULL_TREE, timeout_value, NULL_TREE)))); - } - else - { - /* delay not specified -- call __remaintime which returns the - remaining time of duration in rtstime format and check the - result */ - tree fcall = - build_chill_function_call ( - lookup_name (get_identifier ("__remaintime")), - tree_cons (NULL_TREE, force_addr_of (TREE_VALUE (TREE_VALUE (after_stack))), - tree_cons (NULL_TREE, TREE_PURPOSE (TREE_VALUE (after_stack)), - tree_cons (NULL_TREE, timeout_value, NULL_TREE)))); - tree expr = build (NE_EXPR, integer_type_node, - fcall, integer_zero_node); - expand_start_cond (expr, 0); - lookup_and_expand_goto (TREE_VALUE (TREE_PURPOSE (after_stack))); - expand_end_cond (); - } - } - return timeout_value; -} - -void -build_timesupervised_call (fcall, to_loc) - tree fcall; - tree to_loc; -{ - if (to_loc == null_pointer_node) - expand_expr_stmt (fcall); - else - { - tree expr = build (NE_EXPR, integer_type_node, fcall, integer_zero_node); - expand_start_cond (expr, 0); - lookup_and_expand_goto (TREE_VALUE (TREE_PURPOSE (after_stack))); - expand_end_cond (); - } -} diff --git a/gcc/ch/tree.c b/gcc/ch/tree.c deleted file mode 100644 index 53485dbc2eb..00000000000 --- a/gcc/ch/tree.c +++ /dev/null @@ -1,298 +0,0 @@ -/* Language-dependent node constructors for parse phase of GNU compiler. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include "config.h" -#include "system.h" -#include "obstack.h" -#include "tree.h" -#include "ch-tree.h" -#include "toplev.h" - -/* Here is how primitive or already-canonicalized types' - hash codes are made. */ -#define TYPE_HASH(TYPE) ((HOST_WIDE_INT) (TYPE) & 0777777) - -extern struct obstack permanent_obstack; -/* This is special sentinel used to communicate from build_string_type - to layout_chill_range_type for the index range of a string. */ -tree string_index_type_dummy; - -static tree make_powerset_type PARAMS ((tree)); - -/* Build a chill string type. - For a character string, ELT_TYPE==char_type_node; - for a bit-string, ELT_TYPE==boolean_type_node. */ - -tree -build_string_type (elt_type, length) - tree elt_type; - tree length; -{ - register tree t; - - if (TREE_CODE (elt_type) == ERROR_MARK || TREE_CODE (length) == ERROR_MARK) - return error_mark_node; - - /* Allocate the array after the pointer type, - in case we free it in type_hash_canon. */ - - if (pass > 0 && TREE_CODE (length) == INTEGER_CST - && ! tree_int_cst_equal (length, integer_zero_node) - && compare_int_csts (LT_EXPR, TYPE_MAX_VALUE (chill_unsigned_type_node), - length)) - { - error ("string length > UPPER (UINT)"); - length = integer_one_node; - } - - /* Subtract 1 from length to get max index value. - Note we cannot use size_binop for pass 1 expressions. */ - if (TREE_CODE (length) == INTEGER_CST || pass != 1) - length = size_binop (MINUS_EXPR, length, size_one_node); - else - length = build (MINUS_EXPR, sizetype, length, size_one_node); - - t = make_node (elt_type == boolean_type_node ? SET_TYPE : ARRAY_TYPE); - TREE_TYPE (t) = elt_type; - - MARK_AS_STRING_TYPE (t); - - TYPE_DOMAIN (t) = build_chill_range_type (string_index_type_dummy, - integer_zero_node, length); - if (pass == 1 && TREE_CODE (length) == INTEGER_CST) - TYPE_DOMAIN (t) = layout_chill_range_type (TYPE_DOMAIN (t), 0); - - if (pass != 1 - || (TREE_CODE (length) == INTEGER_CST && TYPE_SIZE (elt_type))) - { - if (TREE_CODE (t) == SET_TYPE) - t = layout_powerset_type (t); - else - t = layout_chill_array_type (t); - } - return t; -} - -static tree -make_powerset_type (domain) - tree domain; -{ - tree t = make_node (SET_TYPE); - - TREE_TYPE (t) = boolean_type_node; - TYPE_DOMAIN (t) = domain; - - return t; -} - -/* Used to layout both bitstring and powerset types. */ - -tree -layout_powerset_type (type) - tree type; -{ - tree domain = TYPE_DOMAIN (type); - - if (! discrete_type_p (domain)) - { - error ("Can only build a powerset from a discrete mode"); - return error_mark_node; - } - - if (TREE_CODE (TYPE_MAX_VALUE (domain)) == ERROR_MARK || - TREE_CODE (TYPE_MIN_VALUE (domain)) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (TYPE_MAX_VALUE (domain)) != INTEGER_CST - || TREE_CODE (TYPE_MIN_VALUE (domain)) != INTEGER_CST) - { - if (CH_BOOLS_TYPE_P (type)) - error ("non-constant bitstring size invalid"); - else - error ("non-constant powerset size invalid"); - return error_mark_node; - } - - if (TYPE_SIZE (type) == 0) - layout_type (type); - return type; -} - -/* Build a SET_TYPE node whose elements are from the set of values - in TYPE. TYPE must be a discrete mode; we check for that here. */ -tree -build_powerset_type (type) - tree type; -{ - tree t = make_powerset_type (type); - if (pass != 1) - t = layout_powerset_type (t); - return t; -} - -tree -build_bitstring_type (size_in_bits) - tree size_in_bits; -{ - return build_string_type (boolean_type_node, size_in_bits); -} - -/* Return get_identifier (the concatenations of part1, part2, and part3). */ - -tree -get_identifier3 (part1, part2, part3) - const char *part1, *part2, *part3; -{ - char *buf = (char*) - alloca (strlen(part1) + strlen(part2) + strlen(part3) + 1); - sprintf (buf, "%s%s%s", part1, part2, part3); - return get_identifier (buf); -} - -/* Build an ALIAS_DECL for the prefix renamed clause: - (OLD_PREFIX -> NEW_PREFIX) ! POSTFIX. */ - -tree -build_alias_decl (old_prefix, new_prefix, postfix) - tree old_prefix, new_prefix, postfix; -{ - tree decl = make_node (ALIAS_DECL); - - const char *postfix_pointer = IDENTIFIER_POINTER (postfix); - int postfix_length = IDENTIFIER_LENGTH (postfix); - int old_length = old_prefix ? IDENTIFIER_LENGTH(old_prefix) : 0; - int new_length = new_prefix ? IDENTIFIER_LENGTH(new_prefix) : 0; - - char *buf = (char*) alloca (old_length + new_length + postfix_length + 3); - - /* Convert (OP->NP)!P!ALL to (OP!P->NP!P)!ALL */ - if (postfix_length > 1 && postfix_pointer[postfix_length-1] == '*') - { - int chopped_length = postfix_length - 2; /* Without final "!*" */ - if (old_prefix) - sprintf (buf, "%s!%.*s", IDENTIFIER_POINTER (old_prefix), - chopped_length, postfix_pointer); - else - sprintf (buf, "%.*s", chopped_length, postfix_pointer); - old_prefix = get_identifier (buf); - if (new_prefix) - sprintf (buf, "%s!%.*s", IDENTIFIER_POINTER (new_prefix), - chopped_length, postfix_pointer); - else - sprintf (buf, "%.*s", chopped_length, postfix_pointer); - new_prefix = get_identifier (buf); - postfix = ALL_POSTFIX; - } - - DECL_OLD_PREFIX (decl) = old_prefix; - DECL_NEW_PREFIX (decl) = new_prefix; - DECL_POSTFIX (decl) = postfix; - - if (DECL_POSTFIX_ALL (decl)) - DECL_NAME (decl) = NULL_TREE; - else if (new_prefix == NULL_TREE) - DECL_NAME (decl) = postfix; - else - DECL_NAME (decl) = get_identifier3 (IDENTIFIER_POINTER (new_prefix), - "!", IDENTIFIER_POINTER (postfix)); - - return decl; -} - -/* Return the "old name string" of an ALIAS_DECL. */ - -tree -decl_old_name (decl) - tree decl; -{ - - if (DECL_OLD_PREFIX (decl) == NULL_TREE) - return DECL_POSTFIX (decl); - return get_identifier3 (IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)), - "!", IDENTIFIER_POINTER (DECL_POSTFIX (decl))); -} - -/* See if OLD_NAME (an identifier) matches the OLD_PREFIX!POSTFIX - of ALIAS. If so, return the corresponding NEW_NEW!POSTFIX. */ - -tree -decl_check_rename (alias, old_name) - tree alias, old_name; -{ - const char *old_pointer = IDENTIFIER_POINTER (old_name); - int old_len = IDENTIFIER_LENGTH (old_name); - if (DECL_OLD_PREFIX (alias)) - { - int old_prefix_len = IDENTIFIER_LENGTH (DECL_OLD_PREFIX (alias)); - if (old_prefix_len >= old_len - || old_pointer[old_prefix_len] != '!' - || strncmp (old_pointer, IDENTIFIER_POINTER (DECL_OLD_PREFIX (alias)), old_prefix_len) != 0) - return NULL_TREE; - - /* Skip the old prefix. */ - old_pointer += old_prefix_len + 1; /* Also skip the '!', */ - } - if (DECL_POSTFIX_ALL (alias) - || strcmp (IDENTIFIER_POINTER (DECL_POSTFIX (alias)), old_pointer) == 0) - { - if (DECL_NEW_PREFIX (alias)) - return get_identifier3 (IDENTIFIER_POINTER (DECL_NEW_PREFIX (alias)), - "!", old_pointer); - else if (old_pointer == IDENTIFIER_POINTER (old_name)) - return old_name; - else - return get_identifier (old_pointer); - } - else - return NULL_TREE; -} - -/* 'EXIT foo' is treated like 'GOTO EXIT!foo'. - This function converts LABEL into a labal name for EXIT. */ - -tree -munge_exit_label (label) - tree label; -{ - return get_identifier3 ("EXIT", "!", IDENTIFIER_POINTER (label)); -} - -/* Make SAVE_EXPRs as needed, but don't turn a location into a non-location. */ - -tree -save_if_needed (exp) -tree exp; -{ - return CH_REFERABLE (exp) ? stabilize_reference (exp) : save_expr (exp); -} - -/* Return the number of elements in T, which must be a discrete type. */ -tree -discrete_count (t) - tree t; -{ - tree hi = convert (sizetype, TYPE_MAX_VALUE (t)); - - if (TYPE_MIN_VALUE (t)) - hi = size_binop (MINUS_EXPR, hi, convert (sizetype, TYPE_MIN_VALUE (t))); - - return size_binop (PLUS_EXPR, hi, integer_one_node); -} diff --git a/gcc/ch/typeck.c b/gcc/ch/typeck.c deleted file mode 100644 index ef4a2e3bae6..00000000000 --- a/gcc/ch/typeck.c +++ /dev/null @@ -1,3825 +0,0 @@ -/* Build expressions with type checking for CHILL compiler. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -/* This file is part of the CHILL front end. - It contains routines to build C expressions given their operands, - including computing the modes of the result, C-specific error checks, - and some optimization. - - There are also routines to build RETURN_STMT nodes and CASE_STMT nodes, - and to process initializations in declarations (since they work - like a strange sort of assignment). */ - -#include "config.h" -#include "system.h" -#include "tree.h" -#include "ch-tree.h" -#include "flags.h" -#include "rtl.h" -#include "expr.h" -#include "lex.h" -#include "toplev.h" -#include "output.h" - -/* forward declarations */ -static int chill_l_equivalent PARAMS ((tree, tree, struct mode_chain*)); -static tree extract_constant_from_buffer PARAMS ((tree, const unsigned char *, int)); -static int expand_constant_to_buffer PARAMS ((tree, unsigned char *, int)); -static tree build_empty_string PARAMS ((tree)); -static tree make_chill_pointer_type PARAMS ((tree, enum tree_code)); -static unsigned int min_precision PARAMS ((tree, int)); -static tree make_chill_range_type PARAMS ((tree, tree, tree)); -static void apply_chill_array_layout PARAMS ((tree)); -static int field_decl_cmp PARAMS ((tree *, tree*)); -static tree make_chill_struct_type PARAMS ((tree)); -static int apply_chill_field_layout PARAMS ((tree, int *)); - -/* - * This function checks an array access. - * It calls error (ERROR_MESSAGE) if the condition (index <= domain max value - * index >= domain min value) - * is not met at compile time, - * If a runtime test is required and permitted, - * check_expression is used to do so. - * the global RANGE_CHECKING flags controls the - * generation of runtime checking code. - */ -tree -valid_array_index_p (array, idx, error_message, is_varying_lhs) - tree array, idx; - const char *error_message; - int is_varying_lhs; -{ - tree cond, low_limit, high_cond, atype, domain; - tree orig_index = idx; - enum chill_tree_code condition; - - if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK - || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (idx) == TYPE_DECL - || TREE_CODE_CLASS (TREE_CODE (idx)) == 't') - { - error ("array or string index is a mode (instead of a value)"); - return error_mark_node; - } - - atype = TREE_TYPE (array); - - if (chill_varying_type_p (atype)) - { - domain = TYPE_DOMAIN (CH_VARYING_ARRAY_TYPE (atype)); - high_cond = build_component_ref (array, var_length_id); - if (chill_varying_string_type_p (atype)) - { - if (is_varying_lhs) - condition = GT_EXPR; - else - condition = GE_EXPR; - } - else - condition = GT_EXPR; - } - else - { - domain = TYPE_DOMAIN (atype); - high_cond = TYPE_MAX_VALUE (domain); - condition = GT_EXPR; - } - - if (CH_STRING_TYPE_P (atype)) - { - if (! CH_SIMILAR (TREE_TYPE (orig_index), integer_type_node)) - { - error ("index is not an integer expression"); - return error_mark_node; - } - } - else - { - if (! CH_COMPATIBLE (orig_index, domain)) - { - error ("index not compatible with index mode"); - return error_mark_node; - } - } - - /* Convert BOOLS(1) to BOOL and CHARS(1) to CHAR. */ - if (flag_old_strings) - { - idx = convert_to_discrete (idx); - if (idx == NULL) /* should never happen */ - error ("index is not discrete"); - } - - /* we know we'll refer to this value twice */ - if (range_checking) - idx = save_expr (idx); - - low_limit = TYPE_MIN_VALUE (domain); - high_cond = build_compare_discrete_expr (condition, idx, high_cond); - - /* an invalid index expression meets this condition */ - cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, - build_compare_discrete_expr (LT_EXPR, idx, low_limit), - high_cond)); - - /* strip a redundant NOP_EXPR */ - if (TREE_CODE (cond) == NOP_EXPR - && TREE_TYPE (cond) == boolean_type_node - && TREE_CODE (TREE_OPERAND (cond, 0)) == INTEGER_CST) - cond = TREE_OPERAND (cond, 0); - - idx = convert (CH_STRING_TYPE_P (atype) ? integer_type_node : domain, - idx); - - if (TREE_CODE (cond) == INTEGER_CST) - { - if (tree_int_cst_equal (cond, boolean_false_node)) - return idx; /* condition met at compile time */ - error ("%s", error_message); /* condition failed at compile time */ - return error_mark_node; - } - else if (range_checking) - { - /* FIXME: often, several of these conditions will - be generated for the same source file and line number. - A great optimization would be to share the - cause_exception function call among them rather - than generating a cause_exception call for each. */ - return check_expression (idx, cond, - ridpointers[(int) RID_RANGEFAIL]); - } - else - return idx; /* don't know at compile time */ -} - -/* - * Extract a slice from an array, which could look like a - * SET_TYPE if it's a bitstring. The array could also be VARYING - * if the element type is CHAR. The min_value and length values - * must have already been checked with valid_array_index_p. No - * checking is done here. - */ -tree -build_chill_slice (array, min_value, length) - tree array, min_value, length; -{ - tree result; - tree array_type = TREE_TYPE (array); - - if (!CH_REFERABLE (array) && TREE_CODE (array) != SAVE_EXPR - && (TREE_CODE (array) != COMPONENT_REF - || TREE_CODE (TREE_OPERAND (array, 0)) != SAVE_EXPR)) - { - if (!TREE_CONSTANT (array)) - warning ("possible internal error - slice argument is neither referable nor constant"); - else - { - /* Force to storage. - NOTE: This could mean multiple identical copies of - the same constant. FIXME. */ - tree mydecl = decl_temp1 (get_unique_identifier("SLICEE"), - array_type, 1, array, 0, 0); - TREE_READONLY (mydecl) = 1; - /* mark_addressable (mydecl); FIXME: necessary? */ - array = mydecl; - } - } - - /* - The code-generation which uses a slice tree needs not only to - know the dynamic upper and lower limits of that slice, but the - original static allocation, to use to build temps where one or both - of the dynamic limits must be calculated at runtime.. We pass the - dynamic size by building a new array_type whose limits are the - min_value and min_value + length values passed to us. - - The static allocation info is passed by using the parent array's - limits to compute a temp_size, which is passed in the lang_specific - field of the slice_type. */ - - if (TREE_CODE (array_type) == ARRAY_TYPE) - { - tree domain_type = TYPE_DOMAIN (array_type); - tree domain_min = TYPE_MIN_VALUE (domain_type); - tree domain_max - = fold (build (PLUS_EXPR, domain_type, - domain_min, - fold (build (MINUS_EXPR, integer_type_node, - length, integer_one_node)))); - tree index_type = build_chill_range_type (TYPE_DOMAIN (array_type), - domain_min, - domain_max); - - tree element_type = TREE_TYPE (array_type); - tree slice_type = build_simple_array_type (element_type, index_type, NULL_TREE); - tree slice_pointer_type; - tree max_size; - - if (CH_CHARS_TYPE_P (array_type)) - MARK_AS_STRING_TYPE (slice_type); - else - TYPE_PACKED (slice_type) = TYPE_PACKED (array_type); - - SET_CH_NOVELTY (slice_type, CH_NOVELTY (array_type)); - - if (TREE_CONSTANT (array) && host_integerp (min_value, 0) - && host_integerp (length, 0)) - { - unsigned HOST_WIDE_INT type_size = int_size_in_bytes (array_type); - unsigned char *buffer = (unsigned char *) alloca (type_size); - int delta = (int_size_in_bytes (element_type) - * (tree_low_cst (min_value, 0) - - tree_low_cst (domain_min, 0))); - - memset (buffer, 0, type_size); - if (expand_constant_to_buffer (array, buffer, type_size)) - { - result = extract_constant_from_buffer (slice_type, - buffer + delta, - type_size - delta); - if (result) - return result; - } - } - - /* Kludge used by case CONCAT_EXPR in chill_expand_expr. - Set TYPE_ARRAY_MAX_SIZE to a constant upper bound on the - bytes needed. */ - max_size = size_in_bytes (slice_type); - if (TREE_CODE (max_size) != INTEGER_CST) - { - max_size = TYPE_ARRAY_MAX_SIZE (array_type); - if (max_size == NULL_TREE) - max_size = size_in_bytes (array_type); - } - TYPE_ARRAY_MAX_SIZE (slice_type) = max_size; - - mark_addressable (array); - /* Contruct a SLICE_EXPR to represent a slice of a packed array of bits. */ - if (TYPE_PACKED (array_type)) - { - if (pass == 2 && TREE_CODE (length) != INTEGER_CST) - { - sorry ("bit array slice with non-constant length"); - return error_mark_node; - } - if (domain_min && ! integer_zerop (domain_min)) - min_value = size_binop (MINUS_EXPR, min_value, - convert (sizetype, domain_min)); - result = build (SLICE_EXPR, slice_type, array, min_value, length); - TREE_READONLY (result) - = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type)); - return result; - } - - slice_pointer_type = build_chill_pointer_type (slice_type); - if (TREE_CODE (min_value) == INTEGER_CST - && domain_min && TREE_CODE (domain_min) == INTEGER_CST - && compare_int_csts (EQ_EXPR, min_value, domain_min)) - result = fold (build1 (ADDR_EXPR, slice_pointer_type, array)); - else - { - min_value = convert (sizetype, min_value); - if (domain_min && ! integer_zerop (domain_min)) - min_value = size_binop (MINUS_EXPR, min_value, - convert (sizetype, domain_min)); - min_value = size_binop (MULT_EXPR, min_value, - size_in_bytes (element_type)); - result = fold (build (PLUS_EXPR, slice_pointer_type, - build1 (ADDR_EXPR, slice_pointer_type, - array), - convert (slice_pointer_type, min_value))); - } - /* Return the final array value. */ - result = fold (build1 (INDIRECT_REF, slice_type, result)); - TREE_READONLY (result) - = TREE_READONLY (array) | TYPE_READONLY (element_type); - return result; - } - else if (TREE_CODE (array_type) == SET_TYPE) /* actually a bitstring */ - { - if (pass == 2 && TREE_CODE (length) != INTEGER_CST) - { - sorry ("bitstring slice with non-constant length"); - return error_mark_node; - } - result = build (SLICE_EXPR, build_bitstring_type (length), - array, min_value, length); - TREE_READONLY (result) - = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type)); - return result; - } - else if (chill_varying_type_p (array_type)) - return build_chill_slice (varying_to_slice (array), min_value, length); - else - { - error ("slice operation on non-array, non-bitstring value not supported"); - return error_mark_node; - } -} - -static tree -build_empty_string (type) - tree type; -{ - int orig_pass = pass; - tree range, result; - - range = build_chill_range_type (type, integer_zero_node, - integer_minus_one_node); - result = build_chill_array_type (type, - tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE); - pass = 2; - range = build_chill_range_type (type, integer_zero_node, - integer_minus_one_node); - result = build_chill_array_type (type, - tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE); - pass = orig_pass; - - return decl_temp1 (get_unique_identifier ("EMPTY_STRING"), - result, 0, NULL_TREE, 0, 0); -} - -/* We build the runtime range-checking as a separate list - * rather than making a compound_expr with min_value - * (for example), to control when that comparison gets - * generated. We cannot allow it in a TYPE_MAX_VALUE or - * TYPE_MIN_VALUE expression, for instance, because that code - * will get generated when the slice is laid out, which would - * put it outside the scope of an exception handler for the - * statement we're generating. I.e. we would be generating - * cause_exception calls which might execute before the - * necessary ch_link_handler call. - */ -tree -build_chill_slice_with_range (array, min_value, max_value) - tree array, min_value, max_value; -{ - if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK - || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK - || max_value == NULL_TREE || TREE_CODE(max_value) == ERROR_MARK) - return error_mark_node; - - if (TREE_TYPE (array) == NULL_TREE - || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE - && TREE_CODE (TREE_TYPE (array)) != SET_TYPE - && !chill_varying_type_p (TREE_TYPE (array)))) - { - error ("can only take slice of array or string"); - return error_mark_node; - } - - array = save_if_needed (array); - - /* FIXME: test here for max_value >= min_value, except - for max_value == -1, min_value == 0 (empty string) */ - min_value = valid_array_index_p (array, min_value, - "slice lower limit out-of-range", 0); - if (TREE_CODE (min_value) == ERROR_MARK) - return min_value; - - /* FIXME: suppress this test if max_value is the LENGTH of a - varying array, which has presumably already been checked. */ - max_value = valid_array_index_p (array, max_value, - "slice upper limit out-of-range", 0); - if (TREE_CODE (max_value) == ERROR_MARK) - return error_mark_node; - - if (TREE_CODE (min_value) == INTEGER_CST - && TREE_CODE (max_value) == INTEGER_CST - && tree_int_cst_lt (max_value, min_value)) - return build_empty_string (TREE_TYPE (TREE_TYPE (array))); - - return - build_chill_slice - (array, min_value, - save_expr (fold (build (PLUS_EXPR, integer_type_node, - fold (build (MINUS_EXPR, integer_type_node, - max_value, min_value)), - integer_one_node)))); -} - -tree -build_chill_slice_with_length (array, min_value, length) - tree array, min_value, length; -{ - tree max_index; - tree cond, high_cond, atype; - - if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK - || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK - || length == NULL_TREE || TREE_CODE(length) == ERROR_MARK) - return error_mark_node; - - if (TREE_TYPE (array) == NULL_TREE - || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE - && TREE_CODE (TREE_TYPE (array)) != SET_TYPE - && !chill_varying_type_p (TREE_TYPE (array)))) - { - error ("can only take slice of array or string"); - return error_mark_node; - } - - if (TREE_CONSTANT (length) - && tree_int_cst_lt (length, integer_zero_node)) - return build_empty_string (TREE_TYPE (TREE_TYPE (array))); - - array = save_if_needed (array); - min_value = save_expr (min_value); - length = save_expr (length); - - if (! CH_SIMILAR (TREE_TYPE (length), integer_type_node)) - { - error ("slice length is not an integer"); - length = integer_one_node; - } - - max_index = fold (build (MINUS_EXPR, integer_type_node, - fold (build (PLUS_EXPR, integer_type_node, - length, min_value)), - integer_one_node)); - max_index = convert_to_class (chill_expr_class (min_value), max_index); - - min_value = valid_array_index_p (array, min_value, - "slice start index out-of-range", 0); - if (TREE_CODE (min_value) == ERROR_MARK) - return error_mark_node; - - atype = TREE_TYPE (array); - - if (chill_varying_type_p (atype)) - high_cond = build_component_ref (array, var_length_id); - else - high_cond = TYPE_MAX_VALUE (TYPE_DOMAIN (atype)); - - /* an invalid index expression meets this condition */ - cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, - build_compare_discrete_expr (LT_EXPR, - length, integer_zero_node), - build_compare_discrete_expr (GT_EXPR, - max_index, high_cond))); - - if (TREE_CODE (cond) == INTEGER_CST) - { - if (! tree_int_cst_equal (cond, boolean_false_node)) - { - error ("slice length out-of-range"); - return error_mark_node; - } - - } - else if (range_checking) - { - min_value = check_expression (min_value, cond, - ridpointers[(int) RID_RANGEFAIL]); - } - - return build_chill_slice (array, min_value, length); -} - -tree -build_chill_array_ref (array, indexlist) - tree array, indexlist; -{ - tree idx; - - if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK) - return error_mark_node; - if (indexlist == NULL_TREE || TREE_CODE (indexlist) == ERROR_MARK) - return error_mark_node; - - idx = TREE_VALUE (indexlist); /* handle first index */ - - idx = valid_array_index_p (array, idx, - "array index out-of-range", 0); - if (TREE_CODE (idx) == ERROR_MARK) - return error_mark_node; - - array = build_chill_array_ref_1 (array, idx); - - if (array && TREE_CODE (array) != ERROR_MARK - && TREE_CHAIN (indexlist)) - { - /* Z.200 (1988) section 4.2.8 says that: - <array> '(' <expression {',' <expression> }* ')' - is derived syntax (i.e. syntactic sugar) for: - <array> '(' <expression ')' { '(' <expression> ')' }* - The intent is clear if <array> has mode: ARRAY (...) ARRAY (...) XXX. - But what if <array> has mode: ARRAY (...) CHARS (N) - or: ARRAY (...) BOOLS (N). - Z.200 doesn't explicitly prohibit it, but the intent is unclear. - We'll allow it, since it seems reasonable and useful. - However, we won't allow it if <array> is: - ARRAY (...) PROC (...). - (The latter would make sense if we allowed general - Currying, which Chill doesn't.) */ - if (TREE_CODE (TREE_TYPE (array)) == ARRAY_TYPE - || chill_varying_type_p (TREE_TYPE (array)) - || CH_BOOLS_TYPE_P (TREE_TYPE (array))) - array = build_generalized_call (array, TREE_CHAIN (indexlist)); - else - error ("too many index expressions"); - } - return array; -} - -/* - * Don't error check the index in here. It's supposed to be - * checked by the caller. - */ -tree -build_chill_array_ref_1 (array, idx) - tree array, idx; -{ - tree type; - tree domain; - tree rval; - - if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK - || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK) - return error_mark_node; - - if (chill_varying_type_p (TREE_TYPE (array))) - array = varying_to_slice (array); - - domain = TYPE_DOMAIN (TREE_TYPE (array)); - -#if 0 - if (! integer_zerop (TYPE_MIN_VALUE (domain))) - { - /* The C part of the compiler doesn't understand how to do - arithmetic with dissimilar enum types. So we check compatability - here, and perform the math in INTEGER_TYPE. */ - if (TREE_CODE (TREE_TYPE (idx)) == ENUMERAL_TYPE - && chill_comptypes (TREE_TYPE (idx), domain, 0)) - idx = convert (TREE_TYPE (TYPE_MIN_VALUE (domain)), idx); - idx = build_binary_op (MINUS_EXPR, idx, TYPE_MIN_VALUE (domain), 0); - } -#endif - - if (CH_STRING_TYPE_P (TREE_TYPE (array))) - { - /* Could be bitstring or char string. */ - if (TREE_TYPE (TREE_TYPE (array)) == boolean_type_node) - { - rval = build (SET_IN_EXPR, boolean_type_node, idx, array); - TREE_READONLY (rval) = TREE_READONLY (array); - return rval; - } - } - - if (!discrete_type_p (TREE_TYPE (idx))) - { - error ("array index is not discrete"); - return error_mark_node; - } - - /* An array that is indexed by a non-constant - cannot be stored in a register; we must be able to do - address arithmetic on its address. - Likewise an array of elements of variable size. */ - if (TREE_CODE (idx) != INTEGER_CST - || (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))) != 0 - && TREE_CODE (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array)))) != INTEGER_CST)) - { - if (mark_addressable (array) == 0) - return error_mark_node; - } - - type = TREE_TYPE (TREE_TYPE (array)); - - /* Do constant folding */ - if (TREE_CODE (idx) == INTEGER_CST && TREE_CONSTANT (array)) - { - struct ch_class class; - class.kind = CH_VALUE_CLASS; - class.mode = type; - - if (TREE_CODE (array) == CONSTRUCTOR) - { - tree list = CONSTRUCTOR_ELTS (array); - for ( ; list != NULL_TREE; list = TREE_CHAIN (list)) - { - if (tree_int_cst_equal (TREE_PURPOSE (list), idx)) - return convert_to_class (class, TREE_VALUE (list)); - } - } - else if (TREE_CODE (array) == STRING_CST - && CH_CHARS_TYPE_P (TREE_TYPE (array))) - { - HOST_WIDE_INT i = tree_low_cst (idx, 0); - - if (i >= 0 && i < TREE_STRING_LENGTH (array)) - return - convert_to_class - (class, - build_int_2 - ((unsigned char) TREE_STRING_POINTER (array) [i], 0)); - } - } - - if (TYPE_PACKED (TREE_TYPE (array))) - rval = build (PACKED_ARRAY_REF, type, array, idx); - else - rval = build (ARRAY_REF, type, array, idx); - - /* Array ref is const/volatile if the array elements are - or if the array is. */ - TREE_READONLY (rval) = TREE_READONLY (array) | TYPE_READONLY (type); - TREE_SIDE_EFFECTS (rval) - |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array))) - | TREE_SIDE_EFFECTS (array)); - TREE_THIS_VOLATILE (rval) - |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array))) - /* This was added by rms on 16 Nov 91. - It fixes vol struct foo *a; a->elts[1] - in an inline function. - Hope it doesn't break something else. */ - | TREE_THIS_VOLATILE (array)); - return fold (rval); -} - -tree -build_chill_bitref (bitstring, indexlist) - tree bitstring, indexlist; -{ - if (TREE_CODE (bitstring) == ERROR_MARK) - return bitstring; - if (TREE_CODE (indexlist) == ERROR_MARK) - return indexlist; - - if (TREE_CHAIN (indexlist) != NULL_TREE) - { - error ("invalid compound index for bitstring mode"); - return error_mark_node; - } - - if (TREE_CODE (indexlist) == TREE_LIST) - { - tree result = build (SET_IN_EXPR, boolean_type_node, - TREE_VALUE (indexlist), bitstring); - TREE_READONLY (result) = TREE_READONLY (bitstring); - return result; - } - else abort (); -} - - -int -discrete_type_p (type) - tree type; -{ - return INTEGRAL_TYPE_P (type); -} - -/* Checks that EXP has discrete type, or can be converted to discrete. - Otherwise, returns NULL_TREE. - Normally returns the (possibly-converted) EXP. */ - -tree -convert_to_discrete (exp) - tree exp; -{ - if (! discrete_type_p (TREE_TYPE (exp))) - { - if (flag_old_strings) - { - if (CH_CHARS_ONE_P (TREE_TYPE (exp))) - return convert (char_type_node, exp); - if (CH_BOOLS_ONE_P (TREE_TYPE (exp))) - return convert (boolean_type_node, exp); - } - return NULL_TREE; - } - return exp; -} - -/* Write into BUFFER the target-machine representation of VALUE. - Returns 1 on success, or 0 on failure. (Either the VALUE was - not constant, or we don't know how to do the conversion.) */ - -static int -expand_constant_to_buffer (value, buffer, buf_size) - tree value; - unsigned char *buffer; - int buf_size; -{ - tree type = TREE_TYPE (value); - int size = int_size_in_bytes (type); - int i; - if (size < 0 || size > buf_size) - return 0; - switch (TREE_CODE (value)) - { - case INTEGER_CST: - { - unsigned HOST_WIDE_INT lo = TREE_INT_CST_LOW (value); - HOST_WIDE_INT hi = TREE_INT_CST_HIGH (value); - for (i = 0; i < size; i++) - { - /* Doesn't work if host and target BITS_PER_UNIT differ. */ - unsigned char byte = lo & ((1 << BITS_PER_UNIT) - 1); - - if (BYTES_BIG_ENDIAN) - buffer[size - i - 1] = byte; - else - buffer[i] = byte; - - rshift_double (lo, hi, BITS_PER_UNIT, BITS_PER_UNIT * size, - &lo, &hi, 0); - } - } - break; - case STRING_CST: - { - size = TREE_STRING_LENGTH (value); - if (size > buf_size) - return 0; - bcopy (TREE_STRING_POINTER (value), buffer, size); - break; - } - case CONSTRUCTOR: - if (TREE_CODE (type) == ARRAY_TYPE) - { - tree element_type = TREE_TYPE (type); - int element_size = int_size_in_bytes (element_type); - tree list = CONSTRUCTOR_ELTS (value); - HOST_WIDE_INT next_index; - HOST_WIDE_INT min_index = 0; - if (element_size < 0) - return 0; - - if (TYPE_DOMAIN (type) != 0) - { - tree min_val = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); - if (min_val) - { - if (! host_integerp (min_val, 0)) - return 0; - else - min_index = tree_low_cst (min_val, 0); - } - } - - next_index = min_index; - - for (; list != NULL_TREE; list = TREE_CHAIN (list)) - { - HOST_WIDE_INT offset; - HOST_WIDE_INT last_index; - tree purpose = TREE_PURPOSE (list); - - if (purpose) - { - if (host_integerp (purpose, 0)) - last_index = next_index = tree_low_cst (purpose, 0); - else if (TREE_CODE (purpose) == RANGE_EXPR) - { - next_index = tree_low_cst (TREE_OPERAND (purpose, 0), 0); - last_index = tree_low_cst (TREE_OPERAND (purpose, 1), 0); - } - else - return 0; - } - else - last_index = next_index; - for ( ; next_index <= last_index; next_index++) - { - offset = (next_index - min_index) * element_size; - if (!expand_constant_to_buffer (TREE_VALUE (list), - buffer + offset, - buf_size - offset)) - return 0; - } - } - break; - } - else if (TREE_CODE (type) == RECORD_TYPE) - { - tree list = CONSTRUCTOR_ELTS (value); - for (; list != NULL_TREE; list = TREE_CHAIN (list)) - { - tree field = TREE_PURPOSE (list); - HOST_WIDE_INT offset; - - if (field == NULL_TREE || TREE_CODE (field) != FIELD_DECL) - return 0; - - if (DECL_BIT_FIELD (field)) - return 0; - - offset = int_byte_position (field); - if (!expand_constant_to_buffer (TREE_VALUE (list), - buffer + offset, - buf_size - offset)) - return 0; - } - break; - } - else if (TREE_CODE (type) == SET_TYPE) - { - if (get_set_constructor_bytes (value, buffer, buf_size) - != NULL_TREE) - return 0; - } - break; - default: - return 0; - } - return 1; -} - -/* Given that BUFFER contains a target-machine representation of - a value of type TYPE, return that value as a tree. - Returns NULL_TREE on failure. (E.g. the TYPE might be variable size, - or perhaps we don't know how to do the conversion.) */ - -static tree -extract_constant_from_buffer (type, buffer, buf_size) - tree type; - const unsigned char *buffer; - int buf_size; -{ - tree value; - HOST_WIDE_INT size = int_size_in_bytes (type); - HOST_WIDE_INT i; - - if (size < 0 || size > buf_size) - return 0; - - switch (TREE_CODE (type)) - { - case INTEGER_TYPE: - case CHAR_TYPE: - case BOOLEAN_TYPE: - case ENUMERAL_TYPE: - case POINTER_TYPE: - { - HOST_WIDE_INT lo = 0, hi = 0; - /* Accumulate (into (lo,hi) the bytes (from buffer). */ - for (i = size; --i >= 0; ) - { - unsigned char byte; - /* Get next byte (in big-endian order). */ - if (BYTES_BIG_ENDIAN) - byte = buffer[size - i - 1]; - else - byte = buffer[i]; - lshift_double (lo, hi, BITS_PER_UNIT, TYPE_PRECISION (type), - &lo, &hi, 0); - add_double (lo, hi, byte, 0, &lo, &hi); - } - value = build_int_2 (lo, hi); - TREE_TYPE (value) = type; - return value; - } - case ARRAY_TYPE: - { - tree element_type = TREE_TYPE (type); - int element_size = int_size_in_bytes (element_type); - tree list = NULL_TREE; - HOST_WIDE_INT min_index = 0, max_index, cur_index; - if (element_size == 1 && CH_CHARS_TYPE_P (type)) - { - value = build_string (size, buffer); - CH_DERIVED_FLAG (value) = 1; - TREE_TYPE (value) = type; - return value; - } - if (TYPE_DOMAIN (type) == 0) - return 0; - value = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); - if (value) - { - if (! host_integerp (value, 0)) - return 0; - else - min_index = tree_low_cst (value, 0); - } - - value = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - if (value == NULL_TREE || ! host_integerp (value, 0)) - return 0; - else - max_index = tree_low_cst (value, 0); - - for (cur_index = max_index; cur_index >= min_index; cur_index--) - { - HOST_WIDE_INT offset = (cur_index - min_index) * element_size; - value = extract_constant_from_buffer (element_type, - buffer + offset, - buf_size - offset); - if (value == NULL_TREE) - return NULL_TREE; - list = tree_cons (build_int_2 (cur_index, 0), value, list); - } - value = build (CONSTRUCTOR, type, NULL_TREE, list); - TREE_CONSTANT (value) = 1; - TREE_STATIC (value) = 1; - return value; - } - case RECORD_TYPE: - { - tree list = NULL_TREE; - tree field = TYPE_FIELDS (type); - for (; field != NULL_TREE; field = TREE_CHAIN (field)) - { - HOST_WIDE_INT offset = int_byte_position (field); - - if (DECL_BIT_FIELD (field)) - return 0; - value = extract_constant_from_buffer (TREE_TYPE (field), - buffer + offset, - buf_size - offset); - if (value == NULL_TREE) - return NULL_TREE; - list = tree_cons (field, value, list); - } - value = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list)); - TREE_CONSTANT (value) = 1; - TREE_STATIC (value) = 1; - return value; - } - - case UNION_TYPE: - { - tree longest_variant = NULL_TREE; - unsigned HOST_WIDE_INT longest_size = 0; - tree field = TYPE_FIELDS (type); - - /* This is a kludge. We assume that converting the data to te - longest variant will provide valid data for the "correct" - variant. This is usually the case, but is not guaranteed. - For example, the longest variant may include holes. - Also incorrect interpreting the given value as the longest - variant may confuse the compiler if that should happen - to yield invalid values. ??? */ - - for (; field != NULL_TREE; field = TREE_CHAIN (field)) - { - unsigned HOST_WIDE_INT size - = int_size_in_bytes (TREE_TYPE (field)); - - if (size > longest_size) - { - longest_size = size; - longest_variant = field; - } - } - - if (longest_variant == NULL_TREE) - return NULL_TREE; - - return - extract_constant_from_buffer (TREE_TYPE (longest_variant), - buffer, buf_size); - } - - case SET_TYPE: - { - tree list = NULL_TREE; - int i; - HOST_WIDE_INT min_index, max_index; - - if (TYPE_DOMAIN (type) == 0) - return 0; - - value = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); - if (value == NULL_TREE) - min_index = 0; - - else if (! host_integerp (value, 0)) - return 0; - else - min_index = tree_low_cst (value, 0); - - value = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - if (value == NULL_TREE) - max_index = 0; - else if (! host_integerp (value, 0)) - return 0; - else - max_index = tree_low_cst (value, 0); - - for (i = max_index + 1 - min_index; --i >= 0; ) - { - unsigned char byte = (unsigned char) buffer[i / BITS_PER_UNIT]; - unsigned bit_pos = (unsigned) i % (unsigned) BITS_PER_UNIT; - - if (BYTES_BIG_ENDIAN - ? (byte & (1 << (BITS_PER_UNIT - 1 - bit_pos))) - : (byte & (1 << bit_pos))) - list = tree_cons (NULL_TREE, - build_int_2 (i + min_index, 0), list); - } - value = build (CONSTRUCTOR, type, NULL_TREE, list); - TREE_CONSTANT (value) = 1; - TREE_STATIC (value) = 1; - return value; - } - - default: - return NULL_TREE; - } -} - -tree -build_chill_cast (type, expr) - tree type, expr; -{ - tree expr_type; - int expr_type_size; - int type_size; - int type_is_discrete; - int expr_type_is_discrete; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return error_mark_node; - - /* if expression was untyped because of its context (an - if_expr or case_expr in a tuple, perhaps) just apply - the type */ - expr_type = TREE_TYPE (expr); - if (expr_type == NULL_TREE - || TREE_CODE (expr_type) == ERROR_MARK) - return convert (type, expr); - - if (expr_type == type) - return expr; - - expr_type_size = int_size_in_bytes (expr_type); - type_size = int_size_in_bytes (type); - - if (expr_type_size == -1) - { - error ("conversions from variable_size value"); - return error_mark_node; - } - if (type_size == -1) - { - error ("conversions to variable_size mode"); - return error_mark_node; - } - - /* FIXME: process REAL ==> INT && INT ==> REAL && REAL ==> REAL. I hope this is correct. */ - if ((TREE_CODE (expr_type) == INTEGER_TYPE && TREE_CODE (type) == REAL_TYPE) || - (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == INTEGER_TYPE) || - (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == REAL_TYPE)) - return convert (type, expr); - - /* FIXME: Don't know if this is correct */ - /* Don't allow conversions to or from REAL with others then integer */ - if (TREE_CODE (type) == REAL_TYPE) - { - error ("cannot convert to float"); - return error_mark_node; - } - else if (TREE_CODE (expr_type) == REAL_TYPE) - { - error ("cannot convert float to this mode"); - return error_mark_node; - } - - if (expr_type_size == type_size && CH_REFERABLE (expr)) - goto do_location_conversion; - - type_is_discrete - = discrete_type_p (type) || TREE_CODE (type) == POINTER_TYPE; - expr_type_is_discrete - = discrete_type_p (expr_type) || TREE_CODE (expr_type) == POINTER_TYPE; - if (expr_type_is_discrete && type_is_discrete) - { - /* do an overflow check - FIXME: is this always neccessary ??? */ - /* FIXME: don't do range chacking when target type is PTR. - PTR doesn't have MIN and MAXVALUE. result is sigsegv. */ - if (range_checking && type != ptr_type_node) - { - tree tmp = expr; - - STRIP_NOPS (tmp); - if (TREE_CONSTANT (tmp) && TREE_CODE (tmp) != ADDR_EXPR) - { - if (compare_int_csts (LT_EXPR, tmp, TYPE_MIN_VALUE (type)) || - compare_int_csts (GT_EXPR, tmp, TYPE_MAX_VALUE (type))) - { - error ("OVERFLOW in expression conversion"); - return error_mark_node; - } - } - else - { - int cond1 = tree_int_cst_lt (TYPE_SIZE (type), - TYPE_SIZE (expr_type)); - int cond2 = TREE_UNSIGNED (type) && (! TREE_UNSIGNED (expr_type)); - int cond3 = (! TREE_UNSIGNED (type)) - && TREE_UNSIGNED (expr_type) - && tree_int_cst_equal (TYPE_SIZE (type), - TYPE_SIZE (expr_type)); - int cond4 = TREE_TYPE (type) && type_is_discrete; - - if (cond1 || cond2 || cond3 || cond4) - { - tree type_min = TYPE_MIN_VALUE (type); - tree type_max = TYPE_MAX_VALUE (type); - - expr = save_if_needed (expr); - if (expr && type_min && type_max) - { - tree check = test_range (expr, type_min, type_max); - if (!integer_zerop (check)) - { - if (current_function_decl == NULL_TREE) - { - if (TREE_CODE (check) == INTEGER_CST) - error ("overflow (not inside function)"); - else - warning ("possible overflow (not inside function)"); - } - else - { - if (TREE_CODE (check) == INTEGER_CST) - warning ("expression will always cause OVERFLOW"); - expr = check_expression (expr, check, - ridpointers[(int) RID_OVERFLOW]); - } - } - } - } - } - } - return convert (type, expr); - } - - if (TREE_CODE (expr) == INTEGER_CST && expr_type_size != type_size) - { - /* There should probably be a pedwarn here ... */ - tree itype = type_for_size (type_size * BITS_PER_UNIT, 1); - if (itype) - { - expr = convert (itype, expr); - expr_type = TREE_TYPE (expr); - expr_type_size= type_size; - } - } - - /* If expr is a constant of the right size, use it to to - initialize a static variable. */ - if (expr_type_size == type_size && TREE_CONSTANT (expr) && !pedantic) - { - unsigned char *buffer = (unsigned char*) alloca (type_size); - tree value; - memset (buffer, 0, type_size); - if (!expand_constant_to_buffer (expr, buffer, type_size)) - { - error ("not implemented: constant conversion from that kind of expression"); - return error_mark_node; - } - value = extract_constant_from_buffer (type, buffer, type_size); - if (value == NULL_TREE) - { - error ("not implemented: constant conversion to that kind of mode"); - return error_mark_node; - } - return value; - } - - if (!CH_REFERABLE (expr) && expr_type_size == type_size) - { - tree temp = decl_temp1 (get_unique_identifier ("CAST"), - TREE_TYPE (expr), 0, 0, 0, 0); - tree convert1 = build_chill_modify_expr (temp, expr); - pedwarn ("non-standard, non-portable value conversion"); - return build (COMPOUND_EXPR, type, convert1, - build_chill_cast (type, temp)); - } - - if (CH_REFERABLE (expr) && expr_type_size != type_size) - error ("location conversion between differently-sized modes"); - else - error ("unsupported value conversion"); - return error_mark_node; - - do_location_conversion: - /* To avoid confusing other parts of gcc, - represent this as the C expression: *(TYPE*)EXPR. */ - mark_addressable (expr); - expr = build1 (INDIRECT_REF, type, - build1 (NOP_EXPR, build_pointer_type (type), - build1 (ADDR_EXPR, build_pointer_type (expr_type), - expr))); - TREE_READONLY (expr) = TYPE_READONLY (type); - return expr; -} - -/* Given a set_type, build an integer array from it that C will grok. */ - -tree -build_array_from_set (type) - tree type; -{ - tree bytespint, bit_array_size, int_array_count; - - if (type == NULL_TREE || type == error_mark_node - || TREE_CODE (type) != SET_TYPE) - return error_mark_node; - - /* ??? Should this really be *HOST*?? */ - bytespint = size_int (HOST_BITS_PER_INT / HOST_BITS_PER_CHAR); - bit_array_size = size_in_bytes (type); - int_array_count = size_binop (TRUNC_DIV_EXPR, bit_array_size, bytespint); - if (integer_zerop (int_array_count)) - int_array_count = size_one_node; - type = build_array_type (integer_type_node, - build_index_type (int_array_count)); - return type; -} - - -tree -build_chill_bin_type (size) - tree size; -{ -#if 0 - HOST_WIDE_INT isize; - - if (! host_integerp (size, 1)) - { - error ("operand to bin must be a non-negative integer literal"); - return error_mark_node; - } - - isize = tree_low_cst (size, 1); - - if (isize <= TYPE_PRECISION (unsigned_char_type_node)) - return unsigned_char_type_node; - if (isize <= TYPE_PRECISION (short_unsigned_type_node)) - return short_unsigned_type_node; - if (isize <= TYPE_PRECISION (unsigned_type_node)) - return unsigned_type_node; - if (isize <= TYPE_PRECISION (long_unsigned_type_node)) - return long_unsigned_type_node; - if (isize <= TYPE_PRECISION (long_long_unsigned_type_node)) - return long_long_unsigned_type_node; - error ("size %d of BIN too big - no such integer mode", isize); - return error_mark_node; -#endif - tree bintype; - - if (pass == 1) - { - bintype = make_node (INTEGER_TYPE); - TREE_TYPE (bintype) = ridpointers[(int) RID_BIN]; - TYPE_MIN_VALUE (bintype) = size; - TYPE_MAX_VALUE (bintype) = size; - } - else - { - error ("BIN in pass 2"); - return error_mark_node; - } - return bintype; -} - -tree -chill_expand_tuple (type, constructor) - tree type, constructor; -{ - const char *name; - tree nonreft = type; - - if (TYPE_NAME (type) != NULL_TREE) - { - if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE) - name = IDENTIFIER_POINTER (TYPE_NAME (type)); - else - name = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))); - } - else - name = ""; - - /* get to actual underlying type for digest_init */ - while (nonreft && TREE_CODE (nonreft) == REFERENCE_TYPE) - nonreft = TREE_TYPE (nonreft); - - if (TREE_CODE (nonreft) == ARRAY_TYPE - || TREE_CODE (nonreft) == RECORD_TYPE - || TREE_CODE (nonreft) == SET_TYPE) - return convert (nonreft, constructor); - else - { - error ("mode of tuple is neither ARRAY, STRUCT, nor POWERSET"); - return error_mark_node; - } -} - -/* This function classifies an expr into the Null class, - the All class, the M-Value, the M-derived, or the M-reference class. - It probably has some inaccuracies. */ - -struct ch_class -chill_expr_class (expr) - tree expr; -{ - struct ch_class class; - /* The Null class contains the NULL pointer constant (only). */ - if (expr == null_pointer_node) - { - class.kind = CH_NULL_CLASS; - class.mode = NULL_TREE; - return class; - } - - /* The All class contains the <undefined value> "*". */ - if (TREE_CODE (expr) == UNDEFINED_EXPR) - { - class.kind = CH_ALL_CLASS; - class.mode = NULL_TREE; - return class; - } - - if (CH_DERIVED_FLAG (expr)) - { - class.kind = CH_DERIVED_CLASS; - class.mode = TREE_TYPE (expr); - return class; - } - - /* The M-Reference contains <references location> (address-of) expressions. - Note that something that's been converted to a reference doesn't count. */ - if (TREE_CODE (expr) == ADDR_EXPR - && TREE_CODE (TREE_TYPE (expr)) != REFERENCE_TYPE) - { - class.kind = CH_REFERENCE_CLASS; - class.mode = TREE_TYPE (TREE_TYPE (expr)); - return class; - } - - /* The M-Value class contains expressions with a known, specific mode M. */ - class.kind = CH_VALUE_CLASS; - class.mode = TREE_TYPE (expr); - return class; -} - -/* Returns >= 1 iff REF is a location. Return 2 if it is referable. */ - -int chill_location (ref) - tree ref; -{ - register enum tree_code code = TREE_CODE (ref); - - switch (code) - { - case REALPART_EXPR: - case IMAGPART_EXPR: - case ARRAY_REF: - case PACKED_ARRAY_REF: - case COMPONENT_REF: - case NOP_EXPR: /* RETYPE_EXPR */ - return chill_location (TREE_OPERAND (ref, 0)); - case COMPOUND_EXPR: - return chill_location (TREE_OPERAND (ref, 1)); - - case BIT_FIELD_REF: - case SLICE_EXPR: - /* A bit-string slice is nor referable. */ - return chill_location (TREE_OPERAND (ref, 0)) == 0 ? 0 : 1; - - case CONSTRUCTOR: - case STRING_CST: - return 0; - - case INDIRECT_REF: - case VAR_DECL: - case PARM_DECL: - case RESULT_DECL: - case ERROR_MARK: - if (TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE - && TREE_CODE (TREE_TYPE (ref)) != METHOD_TYPE) - return 2; - break; - - default: - break; - } - return 0; -} - -int -chill_referable (val) - tree val; -{ - return chill_location (val) > 1; -} - -/* Make a copy of MODE, but with the given NOVELTY. */ - -tree -copy_novelty (novelty, mode) - tree novelty, mode; -{ - if (CH_NOVELTY (mode) != novelty) - { - mode = copy_node (mode); - TYPE_MAIN_VARIANT (mode) = mode; - TYPE_NEXT_VARIANT (mode) = 0; - TYPE_POINTER_TO (mode) = 0; - TYPE_REFERENCE_TO (mode) = 0; - SET_CH_NOVELTY (mode, novelty); - } - return mode; -} - - -struct mode_chain -{ - struct mode_chain *prev; - tree mode1, mode2; -}; - -/* Tests if MODE1 and MODE2 are SIMILAR. - This is more or less as defined in the Blue Book, though - see FIXME for parts that are unfinished. - CHAIN is used to catch infinite recursion: It is a list of pairs - of mode arguments to calls to chill_similar "outer" to this call. */ - -int -chill_similar (mode1, mode2, chain) - tree mode1, mode2; - struct mode_chain *chain; -{ - int varying1, varying2; - tree t1, t2; - struct mode_chain *link, node; - if (mode1 == NULL_TREE || mode2 == NULL_TREE) - return 0; - - while (TREE_CODE (mode1) == REFERENCE_TYPE) - mode1 = TREE_TYPE (mode1); - while (TREE_CODE (mode2) == REFERENCE_TYPE) - mode2 = TREE_TYPE (mode2); - - /* Range modes are similar to their parent types. */ - while (TREE_CODE (mode1) == INTEGER_TYPE && TREE_TYPE (mode1) != NULL_TREE) - mode1 = TREE_TYPE (mode1); - while (TREE_CODE (mode2) == INTEGER_TYPE && TREE_TYPE (mode2) != NULL_TREE) - mode2 = TREE_TYPE (mode2); - - - /* see Z.200 sections 12.1.2.2 and 13.2 - all integer precisions - are similar to INT and to each other */ - if (mode1 == mode2 || - (TREE_CODE (mode1) == INTEGER_TYPE && TREE_CODE (mode2) == INTEGER_TYPE)) - return 1; - - /* This guards against certain kinds of recursion. - For example: - SYNMODE a = STRUCT ( next REF a ); - SYNMODE b = STRUCT ( next REF b ); - These moes are similar, but will get an infite recursion trying - to prove that. So, if we are recursing, assume the moes are similar. - If they are not, we'll find some other discrepancy. */ - for (link = chain; link != NULL; link = link->prev) - { - if (link->mode1 == mode1 && link->mode2 == mode2) - return 1; - } - - node.mode1 = mode1; - node.mode2 = mode2; - node.prev = chain; - - varying1 = chill_varying_type_p (mode1); - varying2 = chill_varying_type_p (mode2); - /* FIXME: This isn't quite strict enough. */ - if ((varying1 && varying2) - || (varying1 && TREE_CODE (mode2) == ARRAY_TYPE) - || (varying2 && TREE_CODE (mode1) == ARRAY_TYPE)) - return 1; - - if (TREE_CODE(mode1) != TREE_CODE(mode2)) - { - if (flag_old_strings) - { - /* The recursion is to handle varying strings. */ - if ((TREE_CODE (mode1) == CHAR_TYPE - && CH_SIMILAR (mode2, string_one_type_node)) - || (TREE_CODE (mode2) == CHAR_TYPE - && CH_SIMILAR (mode1, string_one_type_node))) - return 1; - if ((TREE_CODE (mode1) == BOOLEAN_TYPE - && CH_SIMILAR (mode2, bitstring_one_type_node)) - || (TREE_CODE (mode2) == BOOLEAN_TYPE - && CH_SIMILAR (mode1, bitstring_one_type_node))) - return 1; - } - if (TREE_CODE (mode1) == FUNCTION_TYPE - && TREE_CODE (mode2) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (mode2)) == FUNCTION_TYPE) - mode2 = TREE_TYPE (mode2); - else if (TREE_CODE (mode2) == FUNCTION_TYPE - && TREE_CODE (mode1) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE) - mode1 = TREE_TYPE (mode1); - else - return 0; - } - - if (CH_IS_BUFFER_MODE (mode1) && CH_IS_BUFFER_MODE (mode2)) - { - tree len1 = max_queue_size (mode1); - tree len2 = max_queue_size (mode2); - return tree_int_cst_equal (len1, len2); - } - else if (CH_IS_EVENT_MODE (mode1) && CH_IS_EVENT_MODE (mode2)) - { - tree len1 = max_queue_size (mode1); - tree len2 = max_queue_size (mode2); - return tree_int_cst_equal (len1, len2); - } - else if (CH_IS_ACCESS_MODE (mode1) && CH_IS_ACCESS_MODE (mode2)) - { - tree index1 = access_indexmode (mode1); - tree index2 = access_indexmode (mode2); - tree record1 = access_recordmode (mode1); - tree record2 = access_recordmode (mode2); - if (! chill_read_compatible (index1, index2)) - return 0; - return chill_read_compatible (record1, record2); - } - switch ((enum chill_tree_code)TREE_CODE (mode1)) - { - case INTEGER_TYPE: - case BOOLEAN_TYPE: - case CHAR_TYPE: - return 1; - case ENUMERAL_TYPE: - if (TYPE_VALUES (mode1) == TYPE_VALUES (mode2)) - return 1; - else - { - /* FIXME: This is more strict than z.200, which seems to - allow the elements to be reordered, as long as they - have the same values. */ - - tree field1 = TYPE_VALUES (mode1); - tree field2 = TYPE_VALUES (mode2); - - while (field1 != NULL_TREE && field2 != NULL_TREE) - { - tree value1, value2; - /* Check that the names are equal. */ - if (TREE_PURPOSE (field1) != TREE_PURPOSE (field2)) - break; - - value1 = TREE_VALUE (field1); - value2 = TREE_VALUE (field2); - /* This isn't quite sufficient in general, but will do ... */ - /* Note that proclaim_decl can cause the SET modes to be - compared BEFORE they are satisfied, but otherwise - chill_similar is mostly called after satisfaction. */ - if (TREE_CODE (value1) == CONST_DECL) - value1 = DECL_INITIAL (value1); - if (TREE_CODE (value2) == CONST_DECL) - value2 = DECL_INITIAL (value2); - /* Check that the values are equal or both NULL. */ - if (!(value1 == NULL_TREE && value2 == NULL_TREE) - && (value1 == NULL_TREE || value2 == NULL_TREE - || ! tree_int_cst_equal (value1, value2))) - break; - field1 = TREE_CHAIN (field1); - field2 = TREE_CHAIN (field2); - } - return field1 == NULL_TREE && field2 == NULL_TREE; - } - case SET_TYPE: - /* check for bit strings */ - if (CH_BOOLS_TYPE_P (mode1)) - return CH_BOOLS_TYPE_P (mode2); - if (CH_BOOLS_TYPE_P (mode2)) - return CH_BOOLS_TYPE_P (mode1); - /* both are powerset modes */ - return CH_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2)); - - case POINTER_TYPE: - /* Are the referenced modes equivalent? */ - return !integer_zerop (chill_equivalent (TREE_TYPE (mode1), - TREE_TYPE (mode2), - &node)); - - case ARRAY_TYPE: - /* char for char strings */ - if (CH_CHARS_TYPE_P (mode1)) - return CH_CHARS_TYPE_P (mode2); - if (CH_CHARS_TYPE_P (mode2)) - return CH_CHARS_TYPE_P (mode1); - /* array modes */ - if (CH_V_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2)) - /* Are the elements modes equivalent? */ - && !integer_zerop (chill_equivalent (TREE_TYPE (mode1), - TREE_TYPE (mode2), - &node))) - { - /* FIXME: Check that element layouts are equivalent */ - - tree count1 = fold (build (MINUS_EXPR, sizetype, - TYPE_MAX_VALUE (TYPE_DOMAIN (mode1)), - TYPE_MIN_VALUE (TYPE_DOMAIN (mode1)))); - tree count2 = fold (build (MINUS_EXPR, sizetype, - TYPE_MAX_VALUE (TYPE_DOMAIN (mode2)), - TYPE_MIN_VALUE (TYPE_DOMAIN (mode2)))); - tree cond = build_compare_discrete_expr (EQ_EXPR, count1, count2); - if (TREE_CODE (cond) == INTEGER_CST) - return !integer_zerop (cond); - else - { -#if 0 - extern int ignoring; - if (!ignoring - && range_checking - && current_function_decl) - return cond; -#endif - return 1; - } - } - return 0; - - case RECORD_TYPE: - case UNION_TYPE: - for (t1 = TYPE_FIELDS (mode1), t2 = TYPE_FIELDS (mode2); - t1 && t2; t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2)) - { - if (TREE_CODE (t1) != TREE_CODE (t2)) - return 0; - /* Are the field modes equivalent? */ - if (integer_zerop (chill_equivalent (TREE_TYPE (t1), - TREE_TYPE (t2), - &node))) - return 0; - } - return t1 == t2; - - case FUNCTION_TYPE: - if (!chill_l_equivalent (TREE_TYPE (mode1), TREE_TYPE (mode2), &node)) - return 0; - for (t1 = TYPE_ARG_TYPES (mode1), t2 = TYPE_ARG_TYPES (mode2); - t1 != NULL_TREE && t2 != NULL_TREE; - t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2)) - { - tree attr1 = TREE_PURPOSE (t1) - ? TREE_PURPOSE (t1) : ridpointers[(int) RID_IN]; - tree attr2 = TREE_PURPOSE (t2) - ? TREE_PURPOSE (t2) : ridpointers[(int) RID_IN]; - if (attr1 != attr2) - return 0; - if (!chill_l_equivalent (TREE_VALUE (t1), TREE_VALUE (t2), &node)) - return 0; - } - if (t1 != t2) /* Both NULL_TREE */ - return 0; - /* check list of exception names */ - t1 = TYPE_RAISES_EXCEPTIONS (mode1); - t2 = TYPE_RAISES_EXCEPTIONS (mode2); - if (t1 == NULL_TREE && t2 != NULL_TREE) - return 0; - if (t1 != NULL_TREE && t2 == NULL_TREE) - return 0; - if (list_length (t1) != list_length (t2)) - return 0; - while (t1 != NULL_TREE) - { - if (value_member (TREE_VALUE (t1), t2) == NULL_TREE) - return 0; - t1 = TREE_CHAIN (t1); - } - /* FIXME: Should also check they have the same RECURSIVITY */ - return 1; - - default: - ; -#if 0 - /* Need to handle row modes, instance modes, - association modes, access modes, text modes, - duration modes, absolute time modes, structure modes, - parameterized structure modes */ -#endif - } - return 1; -} - -/* Return a node that is true iff MODE1 and MODE2 are equivalent. - This is normally boolean_true_node or boolean_false_node, - but can be dynamic for dynamic types. - CHAIN is as for chill_similar. */ - -tree -chill_equivalent (mode1, mode2, chain) - tree mode1, mode2; - struct mode_chain *chain; -{ - int varying1, varying2; - int is_string1, is_string2; - tree base_mode1, base_mode2; - - /* Are the modes v-equivalent? */ -#if 0 - if (!chill_similar (mode1, mode2, chain) - || CH_NOVELTY(mode1) != CH_NOVELTY(mode2)) - return boolean_false_node; -#endif - if (!chill_similar (mode1, mode2, chain)) - return boolean_false_node; - else if (TREE_CODE (mode2) == FUNCTION_TYPE - && TREE_CODE (mode1) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE) - /* don't check novelty in this case to avoid error in case of - NEWMODE'd proceduremode gets assigned a function */ - return boolean_true_node; - else if (CH_NOVELTY(mode1) != CH_NOVELTY(mode2)) - return boolean_false_node; - - varying1 = chill_varying_type_p (mode1); - varying2 = chill_varying_type_p (mode2); - - if (varying1 != varying2) - return boolean_false_node; - base_mode1 = varying1 ? CH_VARYING_ARRAY_TYPE (mode1) : mode1; - base_mode2 = varying2 ? CH_VARYING_ARRAY_TYPE (mode2) : mode2; - is_string1 = CH_STRING_TYPE_P (base_mode1); - is_string2 = CH_STRING_TYPE_P (base_mode2); - if (is_string1 || is_string2) - { - if (is_string1 != is_string2) - return boolean_false_node; - return fold (build (EQ_EXPR, boolean_type_node, - TYPE_SIZE (base_mode1), - TYPE_SIZE (base_mode2))); - } - - /* && some more stuff FIXME! */ - if (TREE_CODE(mode1) == INTEGER_TYPE || TREE_CODE(mode2) == INTEGER_TYPE) - { - if (TREE_CODE(mode1) != INTEGER_TYPE || TREE_CODE(mode2) != INTEGER_TYPE) - return boolean_false_node; - /* If one is a range, the other has to be a range. */ - if ((TREE_TYPE (mode1) != NULL_TREE) != (TREE_TYPE (mode2) != NULL_TREE)) - return boolean_false_node; - if (TYPE_PRECISION (mode1) != TYPE_PRECISION (mode2)) - return boolean_false_node; - if (!tree_int_cst_equal (TYPE_MIN_VALUE (mode1), TYPE_MIN_VALUE (mode2))) - return boolean_false_node; - if (!tree_int_cst_equal (TYPE_MAX_VALUE (mode1), TYPE_MAX_VALUE (mode2))) - return boolean_false_node; - } - return boolean_true_node; -} - -static int -chill_l_equivalent (mode1, mode2, chain) - tree mode1, mode2; - struct mode_chain *chain; -{ - /* Are the modes equivalent? */ - if (integer_zerop (chill_equivalent (mode1, mode2, chain))) - return 0; - if (TYPE_READONLY (mode1) != TYPE_READONLY (mode2)) - return 0; -#if 0 - ... other conditions ...; -#endif - return 1; -} - -/* See Z200 12.1.2.12 */ - -int -chill_read_compatible (modeM, modeN) - tree modeM, modeN; -{ - while (TREE_CODE (modeM) == REFERENCE_TYPE) - modeM = TREE_TYPE (modeM); - while (TREE_CODE (modeN) == REFERENCE_TYPE) - modeN = TREE_TYPE (modeN); - - if (!CH_EQUIVALENT (modeM, modeN)) - return 0; - if (TYPE_READONLY (modeN)) - { - if (!TYPE_READONLY (modeM)) - return 0; - if (CH_IS_BOUND_REFERENCE_MODE (modeM) - && CH_IS_BOUND_REFERENCE_MODE (modeN)) - { - return chill_l_equivalent (TREE_TYPE (modeM), TREE_TYPE (modeN), 0); - } -#if 0 - ...; -#endif - } - return 1; -} - -/* Tests if MODE is compatible with the class of EXPR. - Cfr. Chill Blue Book 12.1.2.15. */ - -int -chill_compatible (expr, mode) - tree expr, mode; -{ - struct ch_class class; - - if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) - return 0; - if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK) - return 0; - - while (TREE_CODE (mode) == REFERENCE_TYPE) - mode = TREE_TYPE (mode); - - if (TREE_TYPE (expr) == NULL_TREE) - { - if (TREE_CODE (expr) == CONSTRUCTOR) - return TREE_CODE (mode) == RECORD_TYPE - || ((TREE_CODE (mode) == SET_TYPE || TREE_CODE (mode) == ARRAY_TYPE) - && ! TYPE_STRING_FLAG (mode)); - else - return TREE_CODE (expr) == CASE_EXPR || TREE_CODE (expr) == COND_EXPR; - } - - class = chill_expr_class (expr); - switch (class.kind) - { - case CH_ALL_CLASS: - return 1; - case CH_NULL_CLASS: - return CH_IS_REFERENCE_MODE (mode) || CH_IS_PROCEDURE_MODE (mode) - || CH_IS_INSTANCE_MODE (mode); - case CH_VALUE_CLASS: - if (CH_HAS_REFERENCING_PROPERTY (mode)) - return CH_RESTRICTABLE_TO(mode, class.mode); - else - return CH_V_EQUIVALENT(mode, class.mode); - case CH_DERIVED_CLASS: - return CH_SIMILAR (class.mode, mode); - case CH_REFERENCE_CLASS: - if (!CH_IS_REFERENCE_MODE (mode)) - return 0; -#if 0 - /* FIXME! */ - if (class.mode is a row mode) - ...; - else if (class.mode is not a static mode) - return 0; /* is this possible? FIXME */ -#endif - return !CH_IS_BOUND_REFERENCE_MODE(mode) - || CH_READ_COMPATIBLE (TREE_TYPE (mode), class.mode); - } - return 0; /* ERROR! */ -} - -/* Tests if the class of of EXPR1 and EXPR2 are compatible. - Cfr. Chill Blue Book 12.1.2.16. */ - -int -chill_compatible_classes (expr1, expr2) - tree expr1, expr2; -{ - struct ch_class temp; - struct ch_class class1, class2; - class1 = chill_expr_class (expr1); - class2 = chill_expr_class (expr2); - - switch (class1.kind) - { - case CH_ALL_CLASS: - return 1; - case CH_NULL_CLASS: - switch (class2.kind) - { - case CH_ALL_CLASS: - case CH_NULL_CLASS: - case CH_REFERENCE_CLASS: - return 1; - case CH_VALUE_CLASS: - case CH_DERIVED_CLASS: - goto rule4; - } - case CH_REFERENCE_CLASS: - switch (class2.kind) - { - case CH_ALL_CLASS: - case CH_NULL_CLASS: - return 1; - case CH_REFERENCE_CLASS: - return CH_EQUIVALENT (class1.mode, class2.mode); - case CH_VALUE_CLASS: - goto rule6; - case CH_DERIVED_CLASS: - return 0; - } - case CH_DERIVED_CLASS: - switch (class2.kind) - { - case CH_ALL_CLASS: - return 1; - case CH_VALUE_CLASS: - case CH_DERIVED_CLASS: - return CH_SIMILAR (class1.mode, class2.mode); - case CH_NULL_CLASS: - class2 = class1; - goto rule4; - case CH_REFERENCE_CLASS: - return 0; - } - case CH_VALUE_CLASS: - switch (class2.kind) - { - case CH_ALL_CLASS: - return 1; - case CH_DERIVED_CLASS: - return CH_SIMILAR (class1.mode, class2.mode); - case CH_VALUE_CLASS: - return CH_V_EQUIVALENT (class1.mode, class2.mode); - case CH_NULL_CLASS: - class2 = class1; - goto rule4; - case CH_REFERENCE_CLASS: - temp = class1; class1 = class2; class2 = temp; - goto rule6; - } - } - rule4: - /* The Null class is Compatible with the M-derived class or M-value class - if and only if M is a reference mdoe, procedure mode or instance mode.*/ - return CH_IS_REFERENCE_MODE (class2.mode) - || CH_IS_PROCEDURE_MODE (class2.mode) - || CH_IS_INSTANCE_MODE (class2.mode); - - rule6: - /* The M-reference class is compatible with the N-value class if and - only if N is a reference mode and ... */ - if (!CH_IS_REFERENCE_MODE (class2.mode)) - return 0; - if (1) /* If M is a static mode - FIXME */ - { - if (!CH_IS_BOUND_REFERENCE_MODE (class2.mode)) - return 1; - if (CH_EQUIVALENT (TREE_TYPE (class2.mode), class1.mode)) - return 1; - } - /* If N is a row mode whose .... FIXME */ - return 0; -} - -/* Cfr. Blue Book 12.1.1.6, with some "extensions." */ - -tree -chill_root_mode (mode) - tree mode; -{ - /* Reference types are not user-visible types. - This seems like a good place to get rid of them. */ - if (TREE_CODE (mode) == REFERENCE_TYPE) - mode = TREE_TYPE (mode); - - while (TREE_CODE (mode) == INTEGER_TYPE && TREE_TYPE (mode) != NULL_TREE) - mode = TREE_TYPE (mode); /* a sub-range */ - - /* This extension in not in the Blue Book - which only has a - single Integer type. - We should probably use chill_integer_type_node rather - than integer_type_node, but that is likely to bomb. - At some point, these will become the same, I hope. FIXME */ - if (TREE_CODE (mode) == INTEGER_TYPE - && TYPE_PRECISION (mode) < TYPE_PRECISION (integer_type_node) - && CH_NOVELTY (mode) == NULL_TREE) - mode = integer_type_node; - - if (TREE_CODE (mode) == FUNCTION_TYPE) - return build_pointer_type (mode); - - return mode; -} - -/* Cfr. Blue Book 12.1.1.7. */ - -tree -chill_resulting_mode (mode1, mode2) - tree mode1, mode2; -{ - mode1 = CH_ROOT_MODE (mode1); - mode2 = CH_ROOT_MODE (mode2); - if (chill_varying_type_p (mode1)) - return mode1; - if (chill_varying_type_p (mode2)) - return mode2; - return mode1; -} - -/* Cfr. Blue Book (z200, 1988) 12.1.1.7 Resulting class. */ - -struct ch_class -chill_resulting_class (class1, class2) - struct ch_class class1, class2; -{ - struct ch_class class; - switch (class1.kind) - { - case CH_VALUE_CLASS: - switch (class2.kind) - { - case CH_DERIVED_CLASS: - case CH_ALL_CLASS: - class.kind = CH_VALUE_CLASS; - class.mode = CH_ROOT_MODE (class1.mode); - return class; - case CH_VALUE_CLASS: - class.kind = CH_VALUE_CLASS; - class.mode - = CH_ROOT_MODE (CH_RESULTING_MODE (class1.mode, class2.mode)); - return class; - default: - break; - } - break; - case CH_DERIVED_CLASS: - switch (class2.kind) - { - case CH_VALUE_CLASS: - class.kind = CH_VALUE_CLASS; - class.mode = CH_ROOT_MODE (class2.mode); - return class; - case CH_DERIVED_CLASS: - class.kind = CH_DERIVED_CLASS; - class.mode = CH_RESULTING_MODE (class1.mode, class2.mode); - return class; - case CH_ALL_CLASS: - class.kind = CH_DERIVED_CLASS; - class.mode = CH_ROOT_MODE (class1.mode); - return class; - default: - break; - } - break; - case CH_ALL_CLASS: - switch (class2.kind) - { - case CH_VALUE_CLASS: - class.kind = CH_VALUE_CLASS; - class.mode = CH_ROOT_MODE (class2.mode); - return class; - case CH_ALL_CLASS: - class.kind = CH_ALL_CLASS; - class.mode = NULL_TREE; - return class; - case CH_DERIVED_CLASS: - class.kind = CH_DERIVED_CLASS; - class.mode = CH_ROOT_MODE (class2.mode); - return class; - default: - break; - } - break; - default: - break; - } - error ("internal error in chill_root_resulting_mode"); - class.kind = CH_VALUE_CLASS; - class.mode = CH_ROOT_MODE (class1.mode); - return class; -} - - -/* - * See Z.200, section 6.3, static conditions. This function - * returns bool_false_node if the condition is not met at compile time, - * bool_true_node if the condition is detectably met at compile time - * an expression if a runtime check would be required or was generated. - * It should only be called with string modes and values. - */ -tree -string_assignment_condition (lhs_mode, rhs_value) - tree lhs_mode, rhs_value; -{ - tree lhs_size, rhs_size, cond; - tree rhs_mode = TREE_TYPE (rhs_value); - int lhs_varying = chill_varying_type_p (lhs_mode); - - if (lhs_varying) - lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode)); - else if (CH_BOOLS_TYPE_P (lhs_mode)) - lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode)); - else - lhs_size = size_in_bytes (lhs_mode); - lhs_size = convert (chill_unsigned_type_node, lhs_size); - - if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE) - rhs_mode = TREE_TYPE (rhs_mode); - if (rhs_mode == NULL_TREE) - { - /* actually, count constructor's length */ - abort (); - } - else if (chill_varying_type_p (rhs_mode)) - rhs_size = build_component_ref (rhs_value, var_length_id); - else if (CH_BOOLS_TYPE_P (rhs_mode)) - rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode)); - else - rhs_size = size_in_bytes (rhs_mode); - rhs_size = convert (chill_unsigned_type_node, rhs_size); - - /* validity condition */ - cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR, - boolean_type_node, lhs_size, rhs_size)); - return cond; -} - -/* - * take a basic CHILL type and wrap it in a VARYING structure. - * Be sure the length field is initialized. Return the wrapper. - */ -tree -build_varying_struct (type) - tree type; -{ - tree decl1, decl2, result; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - - decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node); - decl2 = build_decl (FIELD_DECL, var_data_id, type); - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - result = build_chill_struct_type (decl1); - - /* mark this so we don't complain about missing initializers. - It's fine for a VARYING array to be partially initialized.. */ - C_TYPE_VARIABLE_SIZE(type) = 1; - return result; -} - - -/* - * This is the struct type that forms the runtime initializer - * list. There's at least one of these generated per module. - * It's attached to the global initializer list by the module's - * 'constructor' code. Should only be called in pass 2. - */ -tree -build_init_struct () -{ - tree decl1, decl2, result; - /* We temporarily reset the maximum_field_alignment to zero so the - compiler's init data structures can be compatible with the - run-time system, even when we're compiling with -fpack. */ - unsigned int save_maximum_field_alignment = maximum_field_alignment; - maximum_field_alignment = 0; - - decl1 = build_decl (FIELD_DECL, get_identifier ("__INIT_ENTRY"), - build_chill_pointer_type ( - build_function_type (void_type_node, NULL_TREE))); - - decl2 = build_decl (FIELD_DECL, get_identifier ("__INIT_NEXT"), - build_chill_pointer_type (void_type_node)); - - TREE_CHAIN (decl1) = decl2; - TREE_CHAIN (decl2) = NULL_TREE; - result = build_chill_struct_type (decl1); - maximum_field_alignment = save_maximum_field_alignment; - return result; -} - - -/* - * Return 1 if the given type is a single-bit boolean set, - * in which the domain's min and max values - * are both zero, - * 0 if not. This can become a macro later.. - */ -int -ch_singleton_set (type) - tree type; -{ - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return 0; - if (TREE_CODE (type) != SET_TYPE) - return 0; - if (TREE_TYPE (type) == NULL_TREE - || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE) - return 0; - if (TYPE_DOMAIN (type) == NULL_TREE) - return 0; - if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), - integer_zero_node)) - return 0; - if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), - integer_zero_node)) - return 0; - return 1; -} - -/* return non-zero if TYPE is a compiler-generated VARYING - array of some base type */ -int -chill_varying_type_p (type) - tree type; -{ - if (type == NULL_TREE) - return 0; - if (TREE_CODE (type) != RECORD_TYPE) - return 0; - if (TYPE_FIELDS (type) == NULL_TREE - || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE) - return 0; - if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id) - return 0; - if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id) - return 0; - if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE) - return 0; - return 1; -} - -/* return non-zero if TYPE is a compiler-generated VARYING - string record */ -int -chill_varying_string_type_p (type) - tree type; -{ - tree var_data_type; - - if (!chill_varying_type_p (type)) - return 0; - - var_data_type = CH_VARYING_ARRAY_TYPE (type); - return CH_CHARS_TYPE_P (var_data_type); -} - -/* swiped from c-typeck.c */ -/* Build an assignment expression of lvalue LHS from value RHS. */ - -tree -build_chill_modify_expr (lhs, rhs) - tree lhs, rhs; -{ - register tree result; - - - tree lhstype = TREE_TYPE (lhs); - - /* Avoid duplicate error messages from operands that had errors. */ - if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK) - return error_mark_node; - - /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */ - /* Do not use STRIP_NOPS here. We do not want an enumerator - whose value is 0 to count as a null pointer constant. */ - if (TREE_CODE (rhs) == NON_LVALUE_EXPR) - rhs = TREE_OPERAND (rhs, 0); - -#if 0 - /* Handle a cast used as an "lvalue". - We have already performed any binary operator using the value as cast. - Now convert the result to the cast type of the lhs, - and then true type of the lhs and store it there; - then convert result back to the cast type to be the value - of the assignment. */ - - switch (TREE_CODE (lhs)) - { - case NOP_EXPR: - case CONVERT_EXPR: - case FLOAT_EXPR: - case FIX_TRUNC_EXPR: - case FIX_FLOOR_EXPR: - case FIX_ROUND_EXPR: - case FIX_CEIL_EXPR: - { - tree inner_lhs = TREE_OPERAND (lhs, 0); - tree result; - result = build_chill_modify_expr (inner_lhs, - convert (TREE_TYPE (inner_lhs), - convert (lhstype, rhs))); - pedantic_lvalue_warning (CONVERT_EXPR); - return convert (TREE_TYPE (lhs), result); - } - } - - /* Now we have handled acceptable kinds of LHS that are not truly lvalues. - Reject anything strange now. */ - - if (!lvalue_or_else (lhs, "assignment")) - return error_mark_node; -#endif - /* FIXME: need to generate a RANGEFAIL if the RHS won't - fit into the LHS. */ - - if (TREE_CODE (lhs) != VAR_DECL - && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE && - (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) || - chill_varying_type_p (TREE_TYPE (lhs)) || - chill_varying_type_p (TREE_TYPE (rhs)))) - { - int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs)); - int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs)); - - /* point at actual RHS data's type */ - tree rhs_data_type = rhs_varying ? - CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) : - TREE_TYPE (rhs); - { - /* point at actual LHS data's type */ - tree lhs_data_type = lhs_varying ? - CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) : - TREE_TYPE (lhs); - - int lhs_bytes = int_size_in_bytes (lhs_data_type); - int rhs_bytes = int_size_in_bytes (rhs_data_type); - - /* if both sides not varying, and sizes not dynamically - computed, sizes must *match* */ - if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes - && lhs_bytes > 0 && rhs_bytes > 0) - { - error ("string lengths not equal"); - return error_mark_node; - } - /* Must have enough space on LHS for static size of RHS */ - - if (lhs_bytes > 0 && rhs_bytes > 0 - && lhs_bytes < rhs_bytes) - { - if (rhs_varying) - { - /* FIXME: generate runtime test for room */ - ; - } - else - { - error ("can't do ARRAY assignment - too large"); - return error_mark_node; - } - } - } - - /* now we know the RHS will fit in LHS, build trees for the - emit_block_move parameters */ - - if (lhs_varying) - rhs = convert (TREE_TYPE (lhs), rhs); - else - { - if (rhs_varying) - rhs = build_component_ref (rhs, var_data_id); - - if (! mark_addressable (rhs)) - { - error ("rhs of array assignment is not addressable"); - return error_mark_node; - } - - lhs = force_addr_of (lhs); - rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs); - return - build_chill_function_call (lookup_name (get_identifier ("memmove")), - tree_cons (NULL_TREE, lhs, - tree_cons (NULL_TREE, rhs, - tree_cons (NULL_TREE, size_in_bytes (rhs_data_type), - NULL_TREE)))); - } - } - - result = build (MODIFY_EXPR, lhstype, lhs, rhs); - TREE_SIDE_EFFECTS (result) = 1; - - return result; -} - -/* Constructors for pointer, array and function types. - (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are - constructed by language-dependent code, not here.) */ - -/* Construct, lay out and return the type of pointers to TO_TYPE. - If such a type has already been constructed, reuse it. */ - -static tree -make_chill_pointer_type (to_type, code) - tree to_type; - enum tree_code code; /* POINTER_TYPE or REFERENCE_TYPE */ -{ - extern struct obstack *current_obstack; - extern struct obstack *saveable_obstack; - extern struct obstack permanent_obstack; - tree t; - register struct obstack *ambient_obstack = current_obstack; - register struct obstack *ambient_saveable_obstack = saveable_obstack; - - /* If TO_TYPE is permanent, make this permanent too. */ - if (TREE_PERMANENT (to_type)) - { - current_obstack = &permanent_obstack; - saveable_obstack = &permanent_obstack; - } - - t = make_node (code); - TREE_TYPE (t) = to_type; - - current_obstack = ambient_obstack; - saveable_obstack = ambient_saveable_obstack; - return t; -} - - -tree -build_chill_pointer_type (to_type) - tree to_type; -{ - int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't'; - register tree t = is_type_node ? TYPE_POINTER_TO (to_type) : NULL_TREE; - - /* First, if we already have a type for pointers to TO_TYPE, use it. */ - - if (t) - return t; - - /* We need a new one. */ - t = make_chill_pointer_type (to_type, POINTER_TYPE); - - /* Lay out the type. This function has many callers that are concerned - with expression-construction, and this simplifies them all. - Also, it guarantees the TYPE_SIZE is permanent if the type is. */ - if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE)) - || pass == 2) - { - /* Record this type as the pointer to TO_TYPE. */ - TYPE_POINTER_TO (to_type) = t; - layout_type (t); - } - - return t; -} - -tree -build_chill_reference_type (to_type) - tree to_type; -{ - int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't'; - register tree t = is_type_node ? TYPE_REFERENCE_TO (to_type) : NULL_TREE; - - /* First, if we already have a type for references to TO_TYPE, use it. */ - - if (t) - return t; - - /* We need a new one. */ - t = make_chill_pointer_type (to_type, REFERENCE_TYPE); - - /* Lay out the type. This function has many callers that are concerned - with expression-construction, and this simplifies them all. - Also, it guarantees the TYPE_SIZE is permanent if the type is. */ - if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE)) - || pass == 2) - { - /* Record this type as the reference to TO_TYPE. */ - TYPE_REFERENCE_TO (to_type) = t; - layout_type (t); - CH_NOVELTY (t) = CH_NOVELTY (to_type); - } - - return t; -} - -static tree -make_chill_range_type (type, lowval, highval) - tree type, lowval, highval; -{ - register tree itype = make_node (INTEGER_TYPE); - TREE_TYPE (itype) = type; - TYPE_MIN_VALUE (itype) = lowval; - TYPE_MAX_VALUE (itype) = highval; - return itype; -} - - -/* Return the minimum number of bits needed to represent VALUE in a - signed or unsigned type, UNSIGNEDP says which. */ - -static unsigned int -min_precision (value, unsignedp) - tree value; - int unsignedp; -{ - int log; - - /* If the value is negative, compute its negative minus 1. The latter - adjustment is because the absolute value of the largest negative value - is one larger than the largest positive value. This is equivalent to - a bit-wise negation, so use that operation instead. */ - - if (tree_int_cst_sgn (value) < 0) - value = fold (build1 (BIT_NOT_EXPR, TREE_TYPE (value), value)); - - /* Return the number of bits needed, taking into account the fact - that we need one more bit for a signed than unsigned type. */ - - if (integer_zerop (value)) - log = 0; - else - log = tree_floor_log2 (value); - - return log + 1 + ! unsignedp; -} - -tree -layout_chill_range_type (rangetype, must_be_const) - tree rangetype; - int must_be_const; -{ - tree type = TREE_TYPE (rangetype); - tree lowval = TYPE_MIN_VALUE (rangetype); - tree highval = TYPE_MAX_VALUE (rangetype); - int bad_limits = 0; - - if (TYPE_SIZE (rangetype) != NULL_TREE) - return rangetype; - - /* process BIN */ - if (type == ridpointers[(int) RID_BIN]) - { - int binsize; - - /* Make a range out of it */ - if (TREE_CODE (highval) != INTEGER_CST) - { - error ("non-constant expression for BIN"); - return error_mark_node; - } - else if (tree_int_cst_sgn (highval) < 0) - { - error ("expression for BIN must not be negative"); - return error_mark_node; - } - else if (compare_tree_int (highval, 32) > 0) - { - error ("cannot process BIN (>32)"); - return error_mark_node; - } - - binsize = tree_low_cst (highval, 1); - type = ridpointers [(int) RID_RANGE]; - lowval = integer_zero_node; - highval = build_int_2 ((1 << binsize) - 1, 0); - } - - if (TREE_CODE (lowval) == ERROR_MARK - || TREE_CODE (highval) == ERROR_MARK) - return error_mark_node; - - if (!CH_COMPATIBLE_CLASSES (lowval, highval)) - { - error ("bounds of range are not compatible"); - return error_mark_node; - } - - if (type == string_index_type_dummy) - { - if (TREE_CODE (highval) == INTEGER_CST - && compare_int_csts (LT_EXPR, highval, integer_minus_one_node)) - { - error ("negative string length"); - highval = integer_minus_one_node; - } - if (compare_int_csts (EQ_EXPR, highval, integer_minus_one_node)) - type = integer_type_node; - else - type = sizetype; - TREE_TYPE (rangetype) = type; - } - else if (type == ridpointers[(int) RID_RANGE]) - { - /* This isn't 100% right, since the Blue Book definition - uses Resulting Class, rather than Resulting Mode, - but it's close enough. */ - type = CH_ROOT_RESULTING_CLASS (lowval, highval).mode; - - /* The default TYPE is the type of the constants - - except if the constants are integers, we choose an - integer type that fits. */ - if (TREE_CODE (type) == INTEGER_TYPE - && TREE_CODE (lowval) == INTEGER_CST - && TREE_CODE (highval) == INTEGER_CST) - { - int unsignedp = tree_int_cst_sgn (lowval) >= 0; - unsigned int precision = MAX (min_precision (highval, unsignedp), - min_precision (lowval, unsignedp)); - - type = type_for_size (precision, unsignedp); - - } - - TREE_TYPE (rangetype) = type; - } - else - { - if (!CH_COMPATIBLE (lowval, type)) - { - error ("range's lower bound and parent mode don't match"); - return integer_type_node; /* an innocuous fake */ - } - if (!CH_COMPATIBLE (highval, type)) - { - error ("range's upper bound and parent mode don't match"); - return integer_type_node; /* an innocuous fake */ - } - } - - if (TREE_CODE (type) == ERROR_MARK) - return type; - else if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') - { - error ("making range from non-mode"); - return error_mark_node; - } - - if (TREE_CODE (lowval) == REAL_CST || TREE_CODE (highval) == REAL_CST) - { - sorry ("floating point ranges"); - return integer_type_node; /* another fake */ - } - - if (TREE_CODE (lowval) != INTEGER_CST || TREE_CODE (highval) != INTEGER_CST) - { - if (must_be_const) - { - error ("range mode has non-constant limits"); - bad_limits = 1; - } - } - else if (tree_int_cst_equal (lowval, integer_zero_node) - && tree_int_cst_equal (highval, integer_minus_one_node)) - ; /* do nothing - this is the index type for an empty string */ - else if (compare_int_csts (LT_EXPR, highval, TYPE_MIN_VALUE (type))) - { - error ("range's high bound < mode's low bound"); - bad_limits = 1; - } - else if (compare_int_csts (GT_EXPR, highval, TYPE_MAX_VALUE (type))) - { - error ("range's high bound > mode's high bound"); - bad_limits = 1; - } - else if (compare_int_csts (LT_EXPR, highval, lowval)) - { - error ("range mode high bound < range mode low bound"); - bad_limits = 1; - } - else if (compare_int_csts (LT_EXPR, lowval, TYPE_MIN_VALUE (type))) - { - error ("range's low bound < mode's low bound"); - bad_limits = 1; - } - else if (compare_int_csts (GT_EXPR, lowval, TYPE_MAX_VALUE (type))) - { - error ("range's low bound > mode's high bound"); - bad_limits = 1; - } - - if (bad_limits) - { - lowval = TYPE_MIN_VALUE (type); - highval = lowval; - } - - highval = convert (type, highval); - lowval = convert (type, lowval); - TYPE_MIN_VALUE (rangetype) = lowval; - TYPE_MAX_VALUE (rangetype) = highval; - TYPE_PRECISION (rangetype) = TYPE_PRECISION (type); - TYPE_MODE (rangetype) = TYPE_MODE (type); - TYPE_SIZE (rangetype) = TYPE_SIZE (type); - TYPE_SIZE_UNIT (rangetype) = TYPE_SIZE_UNIT (type); - TYPE_ALIGN (rangetype) = TYPE_ALIGN (type); - TYPE_USER_ALIGN (rangetype) = TYPE_USER_ALIGN (type); - TREE_UNSIGNED (rangetype) = TREE_UNSIGNED (type); - CH_NOVELTY (rangetype) = CH_NOVELTY (type); - return rangetype; -} - -/* Build a _TYPE node that has range bounds associated with its values. - TYPE is the base type for the range type. */ -tree -build_chill_range_type (type, lowval, highval) - tree type, lowval, highval; -{ - tree rangetype; - - if (type == NULL_TREE) - type = ridpointers[(int) RID_RANGE]; - else if (TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - - rangetype = make_chill_range_type (type, lowval, highval); - if (pass != 1) - rangetype = layout_chill_range_type (rangetype, 0); - - return rangetype; -} - -/* Build a CHILL array type, but with minimal checking etc. */ - -tree -build_simple_array_type (type, idx, layout) - tree type, idx, layout; -{ - tree array_type = make_node (ARRAY_TYPE); - TREE_TYPE (array_type) = type; - TYPE_DOMAIN (array_type) = idx; - TYPE_ATTRIBUTES (array_type) = layout; - if (pass != 1) - array_type = layout_chill_array_type (array_type); - return array_type; -} - -static void -apply_chill_array_layout (array_type) - tree array_type; -{ - tree layout, temp, what, element_type; - HOST_WIDE_INT stepsize = 0; - HOST_WIDE_INT word, start_bit = 0, length; - HOST_WIDE_INT natural_length; - int stepsize_specified; - int start_bit_error = 0; - int length_error = 0; - - layout = TYPE_ATTRIBUTES (array_type); - if (layout == NULL_TREE) - return; - - if (layout == integer_zero_node) /* NOPACK */ - { - TYPE_PACKED (array_type) = 0; - return; - } - - /* Allow for the packing of 1 bit discrete modes at the bit level. */ - element_type = TREE_TYPE (array_type); - if (discrete_type_p (element_type) - && get_type_precision (TYPE_MIN_VALUE (element_type), - TYPE_MAX_VALUE (element_type)) == 1) - natural_length = 1; - else if (host_integerp (TYPE_SIZE (element_type), 1)) - natural_length = tree_low_cst (TYPE_SIZE (element_type), 1); - else - natural_length = -1; - - if (layout == integer_one_node) /* PACK */ - { - if (natural_length == 1) - TYPE_PACKED (array_type) = 1; - return; - } - - /* The layout is a STEP (...). - The current implementation restricts STEP specifications to be of the form - STEP(POS(0,0,n),n) where n is the natural size of the element mode. */ - stepsize_specified = 0; - temp = TREE_VALUE (layout); - if (TREE_VALUE (temp) != NULL_TREE) - { - if (! host_integerp (TREE_VALUE (temp), 0)) - error ("Stepsize in STEP must be an integer constant"); - else - { - if (tree_int_cst_sgn (TREE_VALUE (temp)) <= 0) - error ("Stepsize in STEP must be > 0"); - else - stepsize_specified = 1; - - stepsize = tree_low_cst (TREE_VALUE (temp), 1); - if (stepsize != natural_length) - sorry ("Stepsize in STEP must be the natural width of the array element mode"); - } - } - - temp = TREE_PURPOSE (temp); - if (! host_integerp (TREE_PURPOSE (temp), 0)) - error ("Starting word in POS must be an integer constant"); - else - { - if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) - error ("Starting word in POS must be >= 0"); - if (! integer_zerop (TREE_PURPOSE (temp))) - sorry ("Starting word in POS within STEP must be 0"); - - word = tree_low_cst (TREE_PURPOSE (temp), 0); - } - - length = natural_length; - temp = TREE_VALUE (temp); - if (temp != NULL_TREE) - { - int wordsize = TYPE_PRECISION (chill_integer_type_node); - if (! host_integerp (TREE_PURPOSE (temp), 0)) - { - error ("Starting bit in POS must be an integer constant"); - start_bit_error = 1; - } - else - { - if (! integer_zerop (TREE_PURPOSE (temp))) - sorry ("Starting bit in POS within STEP must be 0"); - - if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) - { - error ("Starting bit in POS must be >= 0"); - start_bit = 0; - start_bit_error = 1; - } - - start_bit = tree_low_cst (TREE_PURPOSE (temp), 0); - if (start_bit >= wordsize) - { - error ("Starting bit in POS must be < the width of a word"); - start_bit = 0; - start_bit_error = 1; - } - } - - temp = TREE_VALUE (temp); - if (temp != NULL_TREE) - { - what = TREE_PURPOSE (temp); - if (what == integer_zero_node) - { - if (! host_integerp (TREE_VALUE (temp), 0)) - { - error ("Length in POS must be an integer constant"); - length_error = 1; - } - else - { - length = tree_low_cst (TREE_VALUE (temp), 0); - if (length <= 0) - error ("Length in POS must be > 0"); - } - } - else - { - if (! host_integerp (TREE_VALUE (temp), 0)) - { - error ("End bit in POS must be an integer constant"); - length_error = 1; - } - else - { - HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0); - - if (end_bit < start_bit) - { - error ("End bit in POS must be >= the start bit"); - end_bit = wordsize - 1; - length_error = 1; - } - else if (end_bit >= wordsize) - { - error ("End bit in POS must be < the width of a word"); - end_bit = wordsize - 1; - length_error = 1; - } - else if (start_bit_error) - length_error = 1; - else - length = end_bit - start_bit + 1; - } - } - - if (! length_error && length != natural_length) - sorry ("The length specified on POS within STEP must be the natural length of the array element type"); - } - } - - if (! length_error && stepsize_specified && stepsize < length) - error ("Step size in STEP must be >= the length in POS"); - - if (length == 1) - TYPE_PACKED (array_type) = 1; -} - -tree -layout_chill_array_type (array_type) - tree array_type; -{ - tree itype; - tree element_type = TREE_TYPE (array_type); - - if (TREE_CODE (element_type) == ARRAY_TYPE - && TYPE_SIZE (element_type) == 0) - layout_chill_array_type (element_type); - - itype = TYPE_DOMAIN (array_type); - - if (TREE_CODE (itype) == ERROR_MARK - || TREE_CODE (element_type) == ERROR_MARK) - return error_mark_node; - - /* do a lower/upper bound check. */ - if (TREE_CODE (itype) == INTEGER_CST) - { - error ("array index must be a range, not a single integer"); - return error_mark_node; - } - if (TREE_CODE_CLASS (TREE_CODE (itype)) != 't' - || !discrete_type_p (itype)) - { - error ("array index is not a discrete mode"); - return error_mark_node; - } - - /* apply the array layout, if specified. */ - apply_chill_array_layout (array_type); - TYPE_ATTRIBUTES (array_type) = NULL_TREE; - - /* Make sure TYPE_POINTER_TO (element_type) is filled in. */ - build_pointer_type (element_type); - - if (TYPE_SIZE (array_type) == 0) - layout_type (array_type); - - if (TYPE_READONLY_PROPERTY (element_type)) - TYPE_FIELDS_READONLY (array_type) = 1; - - TYPE_ARRAY_MAX_SIZE (array_type) = size_in_bytes (array_type); - return array_type; -} - -/* Build a CHILL array type. - - TYPE is the element type of the array. - IDXLIST is the list of dimensions of the array. - VARYING_P is non-zero if the array is a varying array. - LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list), - meaning (default, pack, nopack, STEP (...) ). */ -tree -build_chill_array_type (type, idxlist, varying_p, layouts) - tree type, idxlist; - int varying_p; - tree layouts; -{ - tree array_type = type; - - if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) - return error_mark_node; - if (idxlist == NULL_TREE || TREE_CODE (idxlist) == ERROR_MARK) - return error_mark_node; - - /* We have to walk down the list of index decls, building inner - array types as we go. We need to reverse the list of layouts so that the - first layout applies to the last index etc. */ - layouts = nreverse (layouts); - for ( ; idxlist; idxlist = TREE_CHAIN (idxlist)) - { - if (layouts != NULL_TREE) - { - type = build_simple_array_type ( - type, TREE_VALUE (idxlist), TREE_VALUE (layouts)); - layouts = TREE_CHAIN (layouts); - } - else - type = build_simple_array_type (type, TREE_VALUE (idxlist), NULL_TREE); - } - array_type = type; - if (varying_p) - array_type = build_varying_struct (array_type); - return array_type; -} - -/* Function to help qsort sort FIELD_DECLs by name order. */ - -static int -field_decl_cmp (x, y) - tree *x, *y; -{ - return (long)DECL_NAME (*x) - (long)DECL_NAME (*y); -} - -static tree -make_chill_struct_type (fieldlist) - tree fieldlist; -{ - tree t, x; - - t = make_node (TREE_UNION_ELEM (fieldlist) ? UNION_TYPE : RECORD_TYPE); - - /* Install struct as DECL_CONTEXT of each field decl. */ - for (x = fieldlist; x; x = TREE_CHAIN (x)) - DECL_CONTEXT (x) = t; - - /* Delete all duplicate fields from the fieldlist */ - for (x = fieldlist; x && TREE_CHAIN (x);) - /* Anonymous fields aren't duplicates. */ - if (DECL_NAME (TREE_CHAIN (x)) == 0) - x = TREE_CHAIN (x); - else - { - register tree y = fieldlist; - - while (1) - { - if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x))) - break; - if (y == x) - break; - y = TREE_CHAIN (y); - } - if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x))) - { - error_with_decl (TREE_CHAIN (x), "duplicate member `%s'"); - TREE_CHAIN (x) = TREE_CHAIN (TREE_CHAIN (x)); - } - else x = TREE_CHAIN (x); - } - - TYPE_FIELDS (t) = fieldlist; - - return t; -} - -/* DECL is a FIELD_DECL. - DECL_INIT (decl) is - (NULL_TREE, integer_one_node, integer_zero_node, tree_list) - meaning - (default, pack, nopack, POS (...) ). - - The return value is a boolean: 1 if POS specified, 0 if not */ - -static int -apply_chill_field_layout (decl, next_struct_offset) - tree decl; - int *next_struct_offset; -{ - tree layout = DECL_INITIAL (decl); - tree type = TREE_TYPE (decl); - tree temp, what; - HOST_WIDE_INT word = 0; - HOST_WIDE_INT wordsize, start_bit, offset, length, natural_length; - int pos_error = 0; - int is_discrete = discrete_type_p (type); - - if (is_discrete) - natural_length - = get_type_precision (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type)); - else if (host_integerp (TYPE_SIZE (type), 1)) - natural_length = tree_low_cst (TYPE_SIZE (type), 1); - else - natural_length = -1; - - if (layout == integer_zero_node) /* NOPACK */ - { - *next_struct_offset += natural_length; - return 0; /* not POS */ - } - - if (layout == integer_one_node) /* PACK */ - { - if (is_discrete) - { - DECL_BIT_FIELD (decl) = 1; - DECL_SIZE (decl) = bitsize_int (natural_length); - } - else - { - DECL_ALIGN (decl) = BITS_PER_UNIT; - DECL_USER_ALIGN (decl) = 0; - } - - DECL_PACKED (decl) = 1; - *next_struct_offset += natural_length; - return 0; /* not POS */ - } - - /* The layout is a POS (...). The current implementation restricts the use - of POS to monotonically increasing fields whose width must be the - natural width of the underlying type. */ - temp = TREE_PURPOSE (layout); - - if (! host_integerp (TREE_PURPOSE (temp), 0)) - { - error ("Starting word in POS must be an integer constant"); - pos_error = 1; - } - else - { - if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) - { - error ("Starting word in POS must be >= 0"); - word = 0; - pos_error = 1; - } - else - word = tree_low_cst (TREE_PURPOSE (temp), 0); - } - - wordsize = TYPE_PRECISION (chill_integer_type_node); - offset = word * wordsize; - length = natural_length; - - temp = TREE_VALUE (temp); - if (temp != NULL_TREE) - { - if (! host_integerp (TREE_PURPOSE (temp), 0)) - { - error ("Starting bit in POS must be an integer constant"); - start_bit = *next_struct_offset - offset; - pos_error = 1; - } - else - { - if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) - { - error ("Starting bit in POS must be >= 0"); - start_bit = *next_struct_offset - offset; - pos_error = 1; - } - - start_bit = tree_low_cst (TREE_PURPOSE (temp), 0); - if (start_bit >= wordsize) - { - error ("Starting bit in POS must be < the width of a word"); - start_bit = *next_struct_offset - offset; - pos_error = 1; - } - } - - temp = TREE_VALUE (temp); - if (temp != NULL_TREE) - { - what = TREE_PURPOSE (temp); - if (what == integer_zero_node) - { - if (! host_integerp (TREE_VALUE (temp), 0)) - { - error ("Length in POS must be an integer constant"); - pos_error = 1; - } - else - { - if (tree_int_cst_sgn (TREE_VALUE (temp)) < 0) - { - error ("Length in POS must be > 0"); - length = natural_length; - pos_error = 1; - } - else - length = tree_low_cst (TREE_VALUE (temp), 0); - - } - } - else - { - if (! host_integerp (TREE_VALUE (temp), 0)) - { - error ("End bit in POS must be an integer constant"); - pos_error = 1; - } - else - { - HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0); - - if (end_bit < start_bit) - { - error ("End bit in POS must be >= the start bit"); - pos_error = 1; - } - else if (end_bit >= wordsize) - { - error ("End bit in POS must be < the width of a word"); - pos_error = 1; - } - else - length = end_bit - start_bit + 1; - } - } - - if (length != natural_length && ! pos_error) - { - sorry ("The length specified on POS must be the natural length of the field type"); - length = natural_length; - } - } - - offset += start_bit; - } - - if (offset != *next_struct_offset && ! pos_error) - sorry ("STRUCT fields must be layed out in monotonically increasing order"); - - DECL_PACKED (decl) = 1; - DECL_BIT_FIELD (decl) = is_discrete; - - if (is_discrete) - DECL_SIZE (decl) = bitsize_int (length); - - *next_struct_offset += natural_length; - - return 1; /* was POS */ -} - -tree -layout_chill_struct_type (t) - tree t; -{ - tree fieldlist = TYPE_FIELDS (t); - tree x; - int old_momentary; - int was_pos; - int pos_seen = 0; - int pos_error = 0; - int next_struct_offset; - - old_momentary = suspend_momentary (); - - /* Process specified field sizes. */ - next_struct_offset = 0; - for (x = fieldlist; x; x = TREE_CHAIN (x)) - { - /* An EVENT or BUFFER mode is implemented as a RECORD_TYPE - which may contain a CONST_DECL for the maximum queue size. */ - if (TREE_CODE (x) == CONST_DECL) - continue; - - /* If any field is const, the structure type is pseudo-const. */ - /* A field that is pseudo-const makes the structure likewise. */ - if (TREE_READONLY (x) || TYPE_READONLY_PROPERTY (TREE_TYPE (x))) - TYPE_FIELDS_READONLY (t) = 1; - - /* Any field that is volatile means variables of this type must be - treated in some ways as volatile. */ - if (TREE_THIS_VOLATILE (x)) - C_TYPE_FIELDS_VOLATILE (t) = 1; - - if (DECL_INITIAL (x) != NULL_TREE) - { - was_pos = apply_chill_field_layout (x, &next_struct_offset); - DECL_INITIAL (x) = NULL_TREE; - } - else - { - unsigned int min_align = TYPE_ALIGN (TREE_TYPE (x)); - DECL_ALIGN (x) = MAX (DECL_ALIGN (x), min_align); - was_pos = 0; - } - if ((! was_pos && pos_seen) || (was_pos && ! pos_seen && x != fieldlist)) - pos_error = 1; - pos_seen |= was_pos; - } - - if (pos_error) - error ("If one field has a POS layout, then all fields must have a POS layout"); - - /* Now DECL_INITIAL is null on all fields. */ - - layout_type (t); - - /* Now we have the truly final field list. - Store it in this type and in the variants. */ - - TYPE_FIELDS (t) = fieldlist; - - /* If there are lots of fields, sort so we can look through them fast. - We arbitrarily consider 16 or more elts to be "a lot". */ - { - int len = 0; - - for (x = fieldlist; x; x = TREE_CHAIN (x)) - { - if (len > 15) - break; - len += 1; - } - if (len > 15) - { - tree *field_array; - char *space; - - len += list_length (x); - /* Use the same allocation policy here that make_node uses, to - ensure that this lives as long as the rest of the struct decl. - All decls in an inline function need to be saved. */ - if (allocation_temporary_p ()) - space = savealloc (sizeof (struct lang_type) + len * sizeof (tree)); - else - space = oballoc (sizeof (struct lang_type) + len * sizeof (tree)); - - TYPE_LANG_SPECIFIC (t) = (struct lang_type *) space; - TYPE_LANG_SPECIFIC (t)->foo.rec.len = len; - - field_array = &TYPE_LANG_SPECIFIC (t)->foo.rec.elts[0]; - len = 0; - for (x = fieldlist; x; x = TREE_CHAIN (x)) - field_array[len++] = x; - - qsort (field_array, len, sizeof (tree), - (int (*) PARAMS ((const void *, const void *))) field_decl_cmp); - } - } - - for (x = TYPE_MAIN_VARIANT (t); x; x = TYPE_NEXT_VARIANT (x)) - { - TYPE_FIELDS (x) = TYPE_FIELDS (t); - TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (t); - TYPE_ALIGN (x) = TYPE_ALIGN (t); - TYPE_USER_ALIGN (x) = TYPE_USER_ALIGN (t); - } - - resume_momentary (old_momentary); - - return t; -} - -/* Given a list of fields, FIELDLIST, return a structure - type that contains these fields. The returned type is - always a new type. */ -tree -build_chill_struct_type (fieldlist) - tree fieldlist; -{ - register tree t; - - if (fieldlist == NULL_TREE || TREE_CODE (fieldlist) == ERROR_MARK) - return error_mark_node; - - t = make_chill_struct_type (fieldlist); - if (pass != 1) - t = layout_chill_struct_type (t); - -/* pushtag (NULL_TREE, t); */ - - return t; -} - -/* Fix a LANG_TYPE. These are used for three different uses: - - representing a 'READ M' (in which case TYPE_READONLY is set); - - for a NEWMODE or SYNMODE (CH_NOVELTY is set for a NEWMODE); and - - for a parameterised type (TREE_TYPE points to base type, - while TYPE_DOMAIN is the parameter or parameter list). - Called from satisfy. */ -tree -smash_dummy_type (type) - tree type; -{ - /* Save fields that we don't want to copy from ORIGIN. */ - tree origin = TREE_TYPE (type); - tree main_tree = TYPE_MAIN_VARIANT (origin); - int save_uid = TYPE_UID (type); - struct obstack *save_obstack = TYPE_OBSTACK (type); - tree save_name = TYPE_NAME (type); - int save_permanent = TREE_PERMANENT (type); - int save_readonly = TYPE_READONLY (type); - tree save_novelty = CH_NOVELTY (type); - tree save_domain = TYPE_DOMAIN (type); - - if (origin == NULL_TREE) - abort (); - - if (save_domain) - { - if (TREE_CODE (save_domain) == ERROR_MARK) - return error_mark_node; - if (origin == char_type_node) - { /* Old-fashioned CHAR(N) declaration. */ - origin = build_string_type (origin, save_domain); - } - else - { /* Handle parameterised modes. */ - int is_varying = chill_varying_type_p (origin); - tree new_max = save_domain; - tree origin_novelty = CH_NOVELTY (origin); - if (is_varying) - origin = CH_VARYING_ARRAY_TYPE (origin); - if (CH_STRING_TYPE_P (origin)) - { - tree oldindex = TYPE_DOMAIN (origin); - new_max = check_range (new_max, new_max, NULL_TREE, - fold (build (PLUS_EXPR, integer_type_node, - TYPE_MAX_VALUE (oldindex), - integer_one_node))); - origin = build_string_type (TREE_TYPE (origin), new_max); - } - else if (TREE_CODE (origin) == ARRAY_TYPE) - { - tree oldindex = TYPE_DOMAIN (origin); - tree upper = check_range (new_max, new_max, NULL_TREE, - TYPE_MAX_VALUE (oldindex)); - tree newindex - = build_chill_range_type (TREE_TYPE (oldindex), - TYPE_MIN_VALUE (oldindex), upper); - origin = build_simple_array_type (TREE_TYPE (origin), newindex, NULL_TREE); - } - else if (TREE_CODE (origin) == RECORD_TYPE) - { - error ("parameterised structures not implemented"); - return error_mark_node; - } - else - { - error ("invalid parameterised type"); - return error_mark_node; - } - - SET_CH_NOVELTY (origin, origin_novelty); - if (is_varying) - { - origin = build_varying_struct (origin); - SET_CH_NOVELTY (origin, origin_novelty); - } - } - save_domain = NULL_TREE; - } - - if (TREE_CODE (origin) == ERROR_MARK) - return error_mark_node; - - *(struct tree_type*)type = *(struct tree_type*)origin; - /* The following is so that the debug code for - the copy is different from the original type. - The two statements usually duplicate each other - (because they clear fields of the same union), - but the optimizer should catch that. */ - TYPE_SYMTAB_POINTER (type) = 0; - TYPE_SYMTAB_ADDRESS (type) = 0; - - /* Restore fields that we didn't want copied from ORIGIN. */ - TYPE_UID (type) = save_uid; - TYPE_OBSTACK (type) = save_obstack; - TREE_PERMANENT (type) = save_permanent; - TYPE_NAME (type) = save_name; - - TREE_CHAIN (type) = NULL_TREE; - TYPE_VOLATILE (type) = 0; - TYPE_POINTER_TO (type) = 0; - TYPE_REFERENCE_TO (type) = 0; - - if (save_readonly) - { /* TYPE is READ ORIGIN. - Add this type to the chain of variants of TYPE. */ - TYPE_NEXT_VARIANT (type) = TYPE_NEXT_VARIANT (main_tree); - TYPE_NEXT_VARIANT (main_tree) = type; - TYPE_READONLY (type) = save_readonly; - } - else - { - /* TYPE is the copy of the RHS in a NEWMODE or SYNMODE. - We also get here after old-fashioned CHAR(N) declaration (see above). */ - TYPE_MAIN_VARIANT (type) = type; - TYPE_NEXT_VARIANT (type) = NULL_TREE; - if (save_name) - DECL_ORIGINAL_TYPE (save_name) = origin; - - if (save_novelty != NULL_TREE) /* A NEWMODE declaration. */ - { - CH_NOVELTY (type) = save_novelty; - - /* Z.200: "If the DEFINING mode of the NEWMODE name is a range mode, - then the virtual mode &name is introduced as the PARENT mode - of the NEWMODE name. The DEFINING mode of &name is the PARENT - mode of the range mode, and the NOVELTY of &name is that of - the NEWMODE name." */ - - if (TREE_CODE (type) == INTEGER_TYPE && TREE_TYPE (type)) - { - tree parent; - /* PARENT is the virtual mode &name mentioned above. */ - push_obstacks_nochange (); - end_temporary_allocation (); - parent = copy_novelty (save_novelty,TREE_TYPE (type)); - pop_obstacks (); - - TREE_TYPE (type) = parent; - TYPE_MIN_VALUE (type) = convert (parent, TYPE_MIN_VALUE (type)); - TYPE_MAX_VALUE (type) = convert (parent, TYPE_MAX_VALUE (type)); - } - } - } - return type; -} - -/* This generates a LANG_TYPE node that represents 'READ TYPE'. */ - -tree -build_readonly_type (type) - tree type; -{ - tree node = make_node (LANG_TYPE); - TREE_TYPE (node) = type; - TYPE_READONLY (node) = 1; - if (pass != 1) - node = smash_dummy_type (node); - return node; -} - - -/* Return an unsigned type the same as TYPE in other respects. */ - -tree -unsigned_type (type) - tree type; -{ - tree type1 = TYPE_MAIN_VARIANT (type); - if (type1 == signed_char_type_node || type1 == char_type_node) - return unsigned_char_type_node; - if (type1 == integer_type_node) - return unsigned_type_node; - if (type1 == short_integer_type_node) - return short_unsigned_type_node; - if (type1 == long_integer_type_node) - return long_unsigned_type_node; - if (type1 == long_long_integer_type_node) - return long_long_unsigned_type_node; - - return signed_or_unsigned_type (1, type); -} - -/* Return a signed type the same as TYPE in other respects. */ - -tree -signed_type (type) - tree type; -{ - tree type1 = TYPE_MAIN_VARIANT (type); - while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE) - type1 = TREE_TYPE (type1); - if (type1 == unsigned_char_type_node || type1 == char_type_node) - return signed_char_type_node; - if (type1 == unsigned_type_node) - return integer_type_node; - if (type1 == short_unsigned_type_node) - return short_integer_type_node; - if (type1 == long_unsigned_type_node) - return long_integer_type_node; - if (type1 == long_long_unsigned_type_node) - return long_long_integer_type_node; - if (TYPE_PRECISION (type1) == 1) - return signed_boolean_type_node; - - return signed_or_unsigned_type (0, type); -} - -/* Return a type the same as TYPE except unsigned or - signed according to UNSIGNEDP. */ - -tree -signed_or_unsigned_type (unsignedp, type) - int unsignedp; - tree type; -{ - if (! INTEGRAL_TYPE_P (type) - || TREE_UNSIGNED (type) == unsignedp) - return type; - - if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); - return type; -} - -/* Mark EXP saying that we need to be able to take the - address of it; it should not be allocated in a register. - Value is 1 if successful. */ - -int -mark_addressable (exp) - tree exp; -{ - register tree x = exp; - while (1) - switch (TREE_CODE (x)) - { - case ADDR_EXPR: - case COMPONENT_REF: - case ARRAY_REF: - case REALPART_EXPR: - case IMAGPART_EXPR: - x = TREE_OPERAND (x, 0); - break; - - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case COMPOUND_EXPR: - x = TREE_OPERAND (x, 1); - break; - - case COND_EXPR: - return mark_addressable (TREE_OPERAND (x, 1)) - & mark_addressable (TREE_OPERAND (x, 2)); - - case CONSTRUCTOR: - TREE_ADDRESSABLE (x) = 1; - return 1; - - case INDIRECT_REF: - /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode - incompatibility problems. Handle this case by marking FOO. */ - if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR - && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR) - { - x = TREE_OPERAND (TREE_OPERAND (x, 0), 0); - break; - } - if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR) - { - x = TREE_OPERAND (x, 0); - break; - } - return 1; - - case VAR_DECL: - case CONST_DECL: - case PARM_DECL: - case RESULT_DECL: - if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) - && DECL_NONLOCAL (x)) - { - if (TREE_PUBLIC (x)) - { - error ("global register variable `%s' used in nested function", - IDENTIFIER_POINTER (DECL_NAME (x))); - return 0; - } - pedwarn ("register variable `%s' used in nested function", - IDENTIFIER_POINTER (DECL_NAME (x))); - } - else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) - { - if (TREE_PUBLIC (x)) - { - error ("address of global register variable `%s' requested", - IDENTIFIER_POINTER (DECL_NAME (x))); - return 0; - } - - /* If we are making this addressable due to its having - volatile components, give a different error message. Also - handle the case of an unnamed parameter by not trying - to give the name. */ - - else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) - { - error ("cannot put object with volatile field into register"); - return 0; - } - - pedwarn ("address of register variable `%s' requested", - IDENTIFIER_POINTER (DECL_NAME (x))); - } - put_var_into_stack (x); - - /* drops through */ - case FUNCTION_DECL: - TREE_ADDRESSABLE (x) = 1; -#if 0 /* poplevel deals with this now. */ - if (DECL_CONTEXT (x) == 0) - TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; -#endif - /* drops through */ - default: - return 1; - } -} - -/* Return an integer type with BITS bits of precision, - that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ - -tree -type_for_size (bits, unsignedp) - unsigned bits; - int unsignedp; -{ - if (bits == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - - if (bits == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - - if (bits == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - - if (bits == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - - if (bits == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); - - if (bits <= TYPE_PRECISION (intQI_type_node)) - return unsignedp ? unsigned_intQI_type_node : intQI_type_node; - - if (bits <= TYPE_PRECISION (intHI_type_node)) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - - if (bits <= TYPE_PRECISION (intSI_type_node)) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - - if (bits <= TYPE_PRECISION (intDI_type_node)) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - -#if HOST_BITS_PER_WIDE_INT >= 64 - if (bits <= TYPE_PRECISION (intTI_type_node)) - return unsignedp ? unsigned_intTI_type_node : intTI_type_node; -#endif - - return 0; -} - -/* Return a data type that has machine mode MODE. - If the mode is an integer, - then UNSIGNEDP selects between signed and unsigned types. */ - -tree -type_for_mode (mode, unsignedp) - enum machine_mode mode; - int unsignedp; -{ - if ((int)mode == (int)TYPE_MODE (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - - if ((int)mode == (int)TYPE_MODE (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - - if ((int)mode == (int)TYPE_MODE (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - - if ((int)mode == (int)TYPE_MODE (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - - if ((int)mode == (int)TYPE_MODE (long_long_integer_type_node)) - return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; - - if ((int)mode == (int)TYPE_MODE (intQI_type_node)) - return unsignedp ? unsigned_intQI_type_node : intQI_type_node; - - if ((int)mode == (int)TYPE_MODE (intHI_type_node)) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - - if ((int)mode == (int)TYPE_MODE (intSI_type_node)) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - - if ((int)mode == (int)TYPE_MODE (intDI_type_node)) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - -#if HOST_BITS_PER_WIDE_INT >= 64 - if ((int)mode == (int)TYPE_MODE (intTI_type_node)) - return unsignedp ? unsigned_intTI_type_node : intTI_type_node; -#endif - - if ((int)mode == (int)TYPE_MODE (float_type_node)) - return float_type_node; - - if ((int)mode == (int)TYPE_MODE (double_type_node)) - return double_type_node; - - if ((int)mode == (int)TYPE_MODE (long_double_type_node)) - return long_double_type_node; - - if ((int)mode == (int)TYPE_MODE (build_pointer_type (char_type_node))) - return build_pointer_type (char_type_node); - - if ((int)mode == (int)TYPE_MODE (build_pointer_type (integer_type_node))) - return build_pointer_type (integer_type_node); - - return 0; -} diff --git a/gcc/ch/xtypeck.c b/gcc/ch/xtypeck.c deleted file mode 100644 index 2b9b7b867f4..00000000000 --- a/gcc/ch/xtypeck.c +++ /dev/null @@ -1,283 +0,0 @@ -/* Copyright (C) 1992, 1993, 1994, 1998 Free Software Foundation, Inc. - -This file is part of GNU CC. - -GNU CC is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU CC is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU CC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -#if 0 -tree -build_component_ref (datum, field_name) - tree datum, field_name; -{ - return build_chill_component_ref (datum, field_name); -} - -/* Mark EXP saying that we need to be able to take the - address of it; it should not be allocated in a register. - Value is 1 if successful. */ - -int -mark_addressable (exp) - tree exp; -{ - register tree x = exp; - while (1) - switch (TREE_CODE (x)) - { - case ADDR_EXPR: - case COMPONENT_REF: - case ARRAY_REF: - case REALPART_EXPR: - case IMAGPART_EXPR: -/* start-sanitize-chill */ - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case COMPOUND_EXPR: -/* end-sanitize-chill */ - x = TREE_OPERAND (x, 0); - break; -/* start-sanitize-chill */ - - case COND_EXPR: - return mark_addressable (TREE_OPERAND (x, 1)) - & mark_addressable (TREE_OPERAND (x, 2)); -/* end-sanitize-chill */ - - case CONSTRUCTOR: - TREE_ADDRESSABLE (x) = 1; - return 1; - - case VAR_DECL: - case CONST_DECL: - case PARM_DECL: - case RESULT_DECL: - if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) - && DECL_NONLOCAL (x)) - { - if (TREE_PUBLIC (x)) - { - error ("global register variable `%s' used in nested function", - IDENTIFIER_POINTER (DECL_NAME (x))); - return 0; - } - pedwarn ("register variable `%s' used in nested function", - IDENTIFIER_POINTER (DECL_NAME (x))); - } - else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) - { - if (TREE_PUBLIC (x)) - { - error ("address of global register variable `%s' requested", - IDENTIFIER_POINTER (DECL_NAME (x))); - return 0; - } - - /* If we are making this addressable due to its having - volatile components, give a different error message. Also - handle the case of an unnamed parameter by not trying - to give the name. */ - - else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) - { - error ("cannot put object with volatile field into register"); - return 0; - } - - pedwarn ("address of register variable `%s' requested", - IDENTIFIER_POINTER (DECL_NAME (x))); - } - put_var_into_stack (x); - - /* drops in */ - case FUNCTION_DECL: - TREE_ADDRESSABLE (x) = 1; -#if 0 /* poplevel deals with this now. */ - if (DECL_CONTEXT (x) == 0) - TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; -#endif - - default: - return 1; - } -} - -/* Return an unsigned type the same as TYPE in other respects. */ - -tree -unsigned_type (type) - tree type; -{ - tree type1 = TYPE_MAIN_VARIANT (type); - if (type1 == signed_char_type_node || type1 == char_type_node) - return unsigned_char_type_node; - if (type1 == integer_type_node) - return unsigned_type_node; - if (type1 == short_integer_type_node) - return short_unsigned_type_node; - if (type1 == long_integer_type_node) - return long_unsigned_type_node; - if (type1 == long_long_integer_type_node) - return long_long_unsigned_type_node; - return type; -} - -/* Return a signed type the same as TYPE in other respects. */ - -tree -signed_type (type) - tree type; -{ - tree type1 = TYPE_MAIN_VARIANT (type); - if (type1 == unsigned_char_type_node || type1 == char_type_node) - return signed_char_type_node; - if (type1 == unsigned_type_node) - return integer_type_node; - if (type1 == short_unsigned_type_node) - return short_integer_type_node; - if (type1 == long_unsigned_type_node) - return long_integer_type_node; - if (type1 == long_long_unsigned_type_node) - return long_long_integer_type_node; - return type; -} - -/* Return a type the same as TYPE except unsigned or - signed according to UNSIGNEDP. */ - -tree -signed_or_unsigned_type (unsignedp, type) - int unsignedp; - tree type; -{ - if (! INTEGRAL_TYPE_P (type)) - return type; - if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); - return type; -} - -extern tree intHI_type_node; -extern tree intSI_type_node; -extern tree intDI_type_node; - -extern tree unsigned_intHI_type_node; -extern tree unsigned_intSI_type_node; -extern tree unsigned_intDI_type_node; - -/* Return an integer type with BITS bits of precision, - that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ - -tree -type_for_size (bits, unsignedp) - unsigned bits; - int unsignedp; -{ - if (bits == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - - if (bits == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - - if (bits == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - - if (bits == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - - if (bits == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); - - if (bits <= TYPE_PRECISION (intHI_type_node)) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - - if (bits <= TYPE_PRECISION (intSI_type_node)) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - - if (bits <= TYPE_PRECISION (intDI_type_node)) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - - return 0; -} - -/* Return a data type that has machine mode MODE. - If the mode is an integer, - then UNSIGNEDP selects between signed and unsigned types. */ - -tree -type_for_mode (mode, unsignedp) - enum machine_mode mode; - int unsignedp; -{ - if (mode == TYPE_MODE (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - - if (mode == TYPE_MODE (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - - if (mode == TYPE_MODE (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - - if (mode == TYPE_MODE (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - - if (mode == TYPE_MODE (long_long_integer_type_node)) - return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; - - if (mode == TYPE_MODE (intHI_type_node)) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - - if (mode == TYPE_MODE (intSI_type_node)) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - - if (mode == TYPE_MODE (intDI_type_node)) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - - if (mode == TYPE_MODE (float_type_node)) - return float_type_node; - - if (mode == TYPE_MODE (double_type_node)) - return double_type_node; - - if (mode == TYPE_MODE (long_double_type_node)) - return long_double_type_node; - - if (mode == TYPE_MODE (build_pointer_type (char_type_node))) - return build_pointer_type (char_type_node); - - if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) - return build_pointer_type (integer_type_node); - - return 0; -} - -tree -truthvalue_conversion (expr) - tree expr; -{ - return chill_truthvalue_conversion (expr); -} -#endif |