-
+2002-04-15 Mark Mitchell <mark@codesourcery.com>
+
+ * MAINTAINERS: Remove chill maintainers.
+ * Makefile.in (CHILLFLAGS): Remove.
+ (CHILL_LIB): Remove.
+ (TARGET_CONFIGDIRS): Remove libchill.
+ (CHILL_FOR_TARGET): Remove.
+ (BASE_FLAGS_TO_PASS): Don't pass CHILLFLAGS, CHILL_FOR_TARGET, or
+ CHILL_LIB.
+ (CONFIGURE_TARGET_MODULES): Remove configure-target-libchill.
+ (CHECK_TARGET_MODULES): Likewise.
+ (INSTALL_TARGET_MODULES): Likewise.
+ (CLEAN_TARGET_MODULES): Likewise.
+ (configure-target-libchill): Remove.
+ (all-target-libchill): Remove.
+ * configure.in (target_libs): Remove target-libchill.
+ Do not compute CHILL_FOR_TARGET.
+ * libchill: Remove directory.
+
2002-04-11 DJ Delorie <dj@redhat.com>
* Makefile.in, configure.in: Sync with binutils, entries
fortran Toon Moene toon@moene.indiv.nluug.nl
c++ Jason Merrill jason@redhat.com
c++ Mark Mitchell mark@codesourcery.com
-chill Dave Brolley brolley@redhat.com
-chill Per Bothner per@bothner.com
cpplib Dave Brolley brolley@redhat.com
cpplib Per Bothner per@bothner.com
cpplib Zack Weinberg zack@codesourcery.com
PICFLAG =
PICFLAG_FOR_TARGET =
-CHILLFLAGS = $(CFLAGS)
-CHILL_LIB = -lchill
CXX = c++
# Use -O2 to stress test the compiler.
# This is set by the configure script to the list of directories which
# should be built using the target tools.
-TARGET_CONFIGDIRS = libiberty libgloss $(SPECIAL_LIBS) newlib librx winsup opcodes bsp libstub cygmon libf2c libchill libobjc
+TARGET_CONFIGDIRS = libiberty libgloss $(SPECIAL_LIBS) newlib librx winsup opcodes bsp libstub cygmon libf2c libobjc
# Target libraries are put under this directory:
# Changed by configure to $(target_alias) if cross.
# Should be substed by configure.in
FLAGS_FOR_TARGET =
CC_FOR_TARGET =
-CHILL_FOR_TARGET =
CXX_FOR_TARGET =
CXX_FOR_TARGET_FOR_RECURSIVE_MAKE =
GCJ_FOR_TARGET =
"CC_FOR_TARGET=$(CC_FOR_TARGET)" \
"CFLAGS=$(CFLAGS)" \
"CFLAGS_FOR_TARGET=$(CFLAGS_FOR_TARGET)" \
- "CHILLFLAGS=$(CHILLFLAGS)" \
- "CHILL_FOR_TARGET=$(CHILL_FOR_TARGET)" \
- "CHILL_LIB=$(CHILL_LIB)" \
"GCJ_FOR_TARGET=$(GCJ_FOR_TARGET)" \
"CXX_FOR_BUILD=$(CXX_FOR_BUILD)" \
"CXXFLAGS=$(CXXFLAGS)" \
all-target-librx \
all-target-newlib \
all-target-libf2c \
- all-target-libchill \
all-target-libobjc \
all-target-libtermcap \
all-target-winsup \
configure-target-librx \
configure-target-newlib \
configure-target-libf2c \
- configure-target-libchill \
configure-target-libobjc \
configure-target-libtermcap \
configure-target-winsup \
check-target-libstdc++-v3 \
check-target-newlib \
check-target-libf2c \
- check-target-libchill \
check-target-libobjc \
check-target-winsup \
check-target-libiberty \
install-target-libstdc++-v3 \
install-target-newlib \
install-target-libf2c \
- install-target-libchill \
install-target-libobjc \
install-target-libtermcap \
install-target-winsup \
clean-target-librx \
clean-target-newlib \
clean-target-libf2c \
- clean-target-libchill \
clean-target-libobjc \
clean-target-winsup \
clean-target-libgloss \
all-libtool:
configure-target-libf2c: $(ALL_GCC_C)
all-target-libf2c: configure-target-libf2c all-target-libiberty
-configure-target-libchill: $(ALL_GCC_C)
-all-target-libchill: configure-target-libchill all-target-libiberty
configure-target-libobjc: $(ALL_GCC_C)
all-target-libobjc: configure-target-libobjc all-target-libiberty
all-m4: all-libiberty all-texinfo
target-librx \
${libstdcxx_version} \
target-libf2c \
- target-libchill \
${libgcj}
target-libobjc"
*) CC_FOR_TARGET=$CC_FOR_TARGET' $(FLAGS_FOR_TARGET)' ;;
esac
-if test "x${CHILL_FOR_TARGET+set}" = xset; then
- :
-elif test -d ${topsrcdir}/gcc; then
- CHILL_FOR_TARGET='$$r/gcc/xgcc -B$$r/gcc/ -L$$r/gcc/ch/runtime/'
-elif test "$host" = "$target"; then
- CHILL_FOR_TARGET='$(CC)'
-else
- CHILL_FOR_TARGET=`echo gcc | sed -e 's/x/x/' ${program_transform_name}`
-fi
-case $CHILL_FOR_TARGET in
-*' $(FLAGS_FOR_TARGET)') ;;
-*) CHILL_FOR_TARGET=$CHILL_FOR_TARGET' $(FLAGS_FOR_TARGET)' ;;
-esac
-
if test "x${GCJ_FOR_TARGET+set}" = xset; then
:
elif test -d ${topsrcdir}/gcc; then
s%^TARGET_CONFIGARGS[ ]*=.*$%TARGET_CONFIGARGS = ${targargs}%
s%^FLAGS_FOR_TARGET[ ]*=.*$%FLAGS_FOR_TARGET = ${FLAGS_FOR_TARGET}%
s%^CC_FOR_TARGET[ ]*=.*$%CC_FOR_TARGET = ${CC_FOR_TARGET}%
-s%^CHILL_FOR_TARGET[ ]*=.*$%CHILL_FOR_TARGET = ${CHILL_FOR_TARGET}%
s%^GCJ_FOR_TARGET[ ]*=.*$%GCJ_FOR_TARGET = ${GCJ_FOR_TARGET}%
s%^CXX_FOR_TARGET[ ]*=.*$%CXX_FOR_TARGET = ${qCXX_FOR_TARGET}%
s%^CXX_FOR_TARGET_FOR_RECURSIVE_MAKE[ ]*=.*$%CXX_FOR_TARGET_FOR_RECURSIVE_MAKE = ${qqCXX_FOR_TARGET}%
+2002-04-15 Mark Mitchell <mark@codesourcery.com>
+
+ Remove Chill front end.
+ * gcc.c (default_compilers): Remove Chill entries.
+ * ch: Remove directory.
+ * doc/frontends.texi: Remove information about Chill.
+ * doc/sourcebuild.texi: Likewise.
+ * doc/standards.texi: Likewise.
+
2002-04-15 Douglas B Rupp <rupp@gnat.com>
* config/alpha/vms.h (INCLUDE_DEFAULTS): Add /gnu/lib/gcc-lib/include.
+++ /dev/null
-2002-03-22 Zack Weinberg <zack@codesourcery.com>
-
- * grant.c: Always use REAL_VALUE_TO_DECIMAL; don't test
- REAL_IS_NOT_DOUBLE.
-
-2002-03-12 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * decl.c (chill_tree_code_type, chill_tree_code_length,
- chill_tree_code_name): Delete.
- (tree_code_type, tree_code_length, tree_code_name): Define.
- (init_decl_processing): Don't try to copy into the various
- tree_code arrays.
-
-2002-02-27 Zack Weinberg <zack@codesourcery.com>
-
- * ch-tree.h, decl.c: Delete traditional-mode-related code
- copied from the C front end but not used, or used only to
- permit the compiler to link.
-
-2002-01-11 Craig Rodrigues <rodrigc@gcc.gnu.org>
-
- PR other/5299
- * decl.c (layout_enum): Fix spelling mistake of "than".
- * inout.c (check_text_length): Same.
-
-2001-12-20 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * config-lang.in (diff_excludes): Remove.
-
-2001-12-15 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * expr.c: Use "built-in" spelling in messages.
-
-2001-12-15 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * decl.c, parse.c, typeck.c: Use American spelling in messages.
-
-2001-12-10 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * chill.texi: Don't condition menus on @ifinfo.
-
-2001-12-04 Zack Weinberg <zack@codesourcery.com>
-
- * Makefile.in: Don't set ALL. Delete @cross_defines@,
- @cross_overrides@, @build_overrides@ stanzas. INTERNAL_CFLAGS
- is now @CROSS@ -DIN_GCC; update comment.
-
-2001-12-03 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * actions.c: Remove leading capital from diagnostic messages, as
- per GNU coding standards.
- * decl.c: Similarly.
- * expr.c: Similarly.
- * inout.c: Similarly.
- * lang.c: Similarly.
- * loop.c: Similarly.
- * nloop.c: Similarly.
- * parse.c: Similarly.
- * satisfy.c: Similarly.
- * tasking.c: Similarly.
- * tree.c: Similarly.
- * typeck.c: Similarly.
-
-2001-11-29 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (CHILL.generated-manpages): New dummy target.
-
-2001-10-31 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * ChangeLog, actions.c, ch-tree.def, decl.c, except.c, inout.c,
- tasking.c, typeck.c: Fix spelling errors.
-
-2001-10-29 Zack Weinberg <zack@codesourcery.com>
-
- * convert.c, inout.c, loop.c, nloop.c, tasking.c, timing.c,
- typeck.c: Use /* */ for all commentary, not #if 0 ... #endif.
- Change the nested comments this creates to // notation.
- Un-double apostrophes.
-
-Sat Sep 22 09:15:08 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * Make-lang.in (cc1chill): Add attribs.o.
-
-2001-08-18 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
-
- * tree.c (TYPE_HASH): Moved to ../tree.h.
-
-2001-08-11 Zack Weinberg <zackw@panix.com>
-
- * lex.c: Don't include setjmp.h.
-
-2001-08-09 Richard Henderson <rth@redhat.com>
-
- * grant.c (chill_finish_compile): Use target hooks instead of
- assemble_constructor.
-
-2001-08-06 Richard Henderson <rth@redhat.com>
-
- * grant.c (chill_finish_compile): Pass a symbol_ref and priority
- to assemble_constructor.
-
-2001-07-19 Neil Booth <neil@daikokuya.demon.co.uk>
-
- * Makefile.in (lex.o): No dependence on dwarfout.h.
- * lex.c: Don't include dwarfout.h.
-
-2001-07-10 Jan van Male <jan.vanmale@fenk.wau.nl>
-
- * ch-tree.h: Remove prototype for combine_parm_decls, unused
- function.
-
-2001-06-28 Gabriel Dos Reis <gdr@merlin.codesourcery.com>
-
- * lang.c: #include diagnostic.h
- (chill_print_error_function): Add a dummy `diagnostic_context *'.
- * Makefile.in (lang.o): Depend on diagnostic.h
-
-2001-06-10 Gabriel Dos Reis <gdr@codesourcery.com>
-
- * decl.c: #include diagnostic.h
- * actions.c: #include diagnostic.h
- * Makefile.in (actions.o): Depend on diagnostic.h
- (decl.o): Depend on diagnostic.h
-
-2001-06-02 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * chill.texi: Move contents to just after title page.
-
-2001-05-23 Theodore Papadopoulo <Theodore.Papadopoulo@sophia.inria.fr>
-
- * Make-lang.in (dvi): Use ch/chill.dvi not chill.dvi.
- (ch/chill.dvi): Use TEXI2DVI instead of custom tex calls. Create
- the dvi file in the ch directory.
-
-2001-05-26 Zack Weinberg <zackw@stanford.edu>
-
- * configure: Remove obsolete file.
-
-2001-05-25 Sam TH <sam@uchicago.edu>
-
- * ch-tree.h tasking.h: Fix header include guards.
-
-2001-05-20 Joseph S. Myers <jsm28@cam.ac.uk>
-
- * Make-lang.in (chill.dvi): Remove bogus dependencies. Don't cd
- to ch; include both $(srcdir)/ch and $(srcdir) in TEXINPUTS.
- Don't move chill.dvi after creating it. Fixes PR other/567 and
- PR other/1018.
-
-Fri Feb 23 15:28:39 2001 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
-
- * decl.c (set_block): Set NAMES and BLOCKS from BLOCK.
-
-2001-02-15 Jim Meyering <meyering@lucent.com>
-
- * Make-lang.in (CHILL.install-common): Depend on `installdirs'.
- (CHILL.install-info): Likewise.
-
-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 occurrences 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 dependencies 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 dependency.
-
-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): Don't 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
- necessary 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.
- However, 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
- statements 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 uninitialized 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.
+++ /dev/null
-# 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.
-#\f
-# 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)"
-#\f
-# 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 \
- attribs.o 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)
-
-#\f
-# Build hooks:
-
-CHILL.all.build: chill
-CHILL.all.cross: chill-cross
-CHILL.start.encap: chill
-CHILL.rest.encap:
-CHILL.dvi: ch/chill.dvi
-CHILL.generated-manpages:
-
-CHILL.info: $(srcdir)/ch/chill.info
-
-$(srcdir)/ch/chill.info: $(srcdir)/ch/chill.texi
- cd $(srcdir)/ch && $(MAKEINFO) -o chill.info chill.texi
-
-ch/chill.dvi: $(srcdir)/ch/chill.texi
- s=`cd $(srcdir); pwd`; export s; \
- cd ch && $(TEXI2DVI) $$s/ch/chill.texi
-
-#\f
-# Install hooks:
-# cc1chill is installed elsewhere as part of $(COMPILERS).
-
-CHILL.install-normal:
-
-# Install the driver program
-CHILL.install-common: installdirs
- -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: installdirs
- -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)
-#\f
-# 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
-#\f
-# 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
+++ /dev/null
-# 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=
-
-# 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@
-#\f
-# Now figure out from those variables how to compile and link.
-
-all.indirect: Makefile ../chill ../cc1chill$(exeext)
-
-# IN_GCC distinguishes between code compiled into GCC itself and other
-# programs built during a bootstrap.
-# autoconf inserts -DCROSS_COMPILE if we are building a cross compiler.
-INTERNAL_CFLAGS = -DIN_GCC @CROSS@
-
-# 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:
-#\f
-# 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
-
-#\f
-Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure
- cd ..; $(SHELL) config.status
-
-native: config.status ../cc1chill$(exeext) ../chill
-#\f
-# 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 diagnostic.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 diagnostic.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) \
- $(srcdir)/../diagnostic.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 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 :
-
-#\f
-# These exist for maintenance purposes.
-
-# Update the tags table.
-TAGS: force
- cd $(srcdir); \
- etags *.y *.h *.c *.l ../*.h ../*.c; \
-
-.PHONY: TAGS
-
-force:
+++ /dev/null
-This directory contains the GNU front-end for the Chill language,
-contributed by Cygnus Solutions.
-
-Chill is the "CCITT High-Level Language", where CCITT is the old
-name for what is now ITU, the International Telecommunications Union.
-It is is language in the Modula2 family, and targets many of the
-same applications as Ada (especially large embedded systems).
-Chill was never used much in the United States, but is still
-being used in Europe, Brazil, Korea, and other places.
-
-Chill has been standardized by a series of reports/standards.
-The GNU implementation mostly follows the 1988 version of
-the language, with some backwards compatibility options for
-the 1984 version, and some other extensions. However, it
-does not implement all of the features of any standard.
-The most recent standard is 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.
+++ /dev/null
-/* 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"
-#include "diagnostic.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;
-\f
-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");
- }
-}
-\f
-/* Comparison function for sorting identifiers in RAISES lists.
- Note that because IDENTIFIER_NODEs are unique, we can sort
- them by address, saving an indirection. */
-static int
-id_cmp (p1, p2)
- tree *p1, *p2;
-{
- 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
-\f
-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;
-}
-\f
-/* There are four conditions to generate a runtime check:
- 1) assigning a longer INT to a shorter (signs irrelevant)
- 2) assigning a signed to an unsigned
- 3) assigning an unsigned to a signed of the same size.
- 4) TYPE is a discrete subrange */
-
-tree
-chill_convert_for_assignment (type, expr, place)
- tree type, expr;
- 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;
-}
-\f
-/* Check that EXPR has valid type for a RETURN or RESULT expression,
- converting to the right type. ACTION is "RESULT" or "RETURN". */
-
-static tree
-adjust_return_value (expr, action)
- tree expr;
- 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);
-}
-\f
-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));
-}
-\f
-/*
- * error if EXPR not NULL and procedure doesn't
- * have a return type;
- * warning if EXPR NULL,
- * procedure *has* a return type, and a previous
- * RESULT actions hasn't saved a return value.
- */
-void
-chill_expand_return (expr, implicit)
- tree expr;
- int implicit; /* 1 if an implicit return at end of function. */
-{
- tree valtype;
-
- if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
- return;
- if (chill_at_module_level || global_bindings_p ())
- {
- error ("RETURN not allowed outside PROC");
- return;
- }
-
- if (pass == 1)
- return;
-
- result_never_set = 0;
-
- valtype = TREE_TYPE (TREE_TYPE (current_function_decl));
- if (TREE_CODE (valtype) == VOID_TYPE)
- {
- if (expr != NULL_TREE)
- error ("RETURN with a value, in PROC returning void");
- expand_null_return ();
- }
- else if (TREE_CODE (valtype) != ERROR_MARK)
- {
- if (expr == NULL_TREE)
- {
- if (!CH_FUNCTION_SETS_RESULT (current_function_decl)
- && !implicit)
- warning ("RETURN with no value and no RESULT action in procedure");
- expr = chill_result_decl;
- }
- else
- expr = adjust_return_value (expr, "RETURN");
- expr = build (MODIFY_EXPR, valtype,
- DECL_RESULT (current_function_decl),
- expr);
- TREE_SIDE_EFFECTS (expr) = 1;
- expand_return (expr);
- }
-}
-
-void
-lookup_and_expand_goto (name)
- tree name;
-{
- if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
- return;
- if (!ignoring)
- {
- tree decl = lookup_name (name);
- if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
- error ("no label named `%s'", IDENTIFIER_POINTER (name));
- else if (DECL_CONTEXT (decl) != current_function_decl)
- error ("cannot GOTO label `%s' outside current function",
- IDENTIFIER_POINTER (name));
- else
- {
- TREE_USED (decl) = 1;
- expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
- expand_goto (decl);
- }
- }
-}
-
-void
-lookup_and_handle_exit (name)
- tree name;
-{
- if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
- return;
- if (!ignoring)
- {
- tree label = munge_exit_label (name);
- tree decl = lookup_name (label);
- if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
- error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name));
- else if (DECL_CONTEXT (decl) != current_function_decl)
- error ("cannot EXIT label `%s' outside current function",
- IDENTIFIER_POINTER (name));
- else
- {
- TREE_USED (decl) = 1;
- expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
- expand_goto (decl);
- }
- }
-}
-\f
-/* ELSE-range handling: The else-range is a chain of trees which collectively
- represent the ranges to be tested for the (ELSE) case label. Each element in
- the chain represents a range to be tested. The boundaries of the range are
- represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */
-
-/* This function updates the else-range by removing the given integer constant. */
-static tree
-update_else_range_for_int_const (else_range, label)
- tree else_range, label;
-{
- int lowval = 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
-}
-\f
-/* Handle cases label such as (I:J): or (modename): */
-
-static void
-chill_handle_case_label_range (min_value, max_value, selector)
- tree min_value, max_value, selector;
-{
- register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
- min_value = check_case_value (min_value, selector);
- max_value = check_case_value (max_value, selector);
- if (TREE_CODE (min_value) != ERROR_MARK
- && TREE_CODE (max_value) != ERROR_MARK)
- {
- tree duplicate;
- int success = pushcase_range (min_value, max_value,
- convert, label, &duplicate);
- if (success == 1)
- error ("label found outside of CASE statement");
- else if (success == 2)
- {
- error ("duplicate CASE value");
- error_with_decl (duplicate, "this is the first entry for that value");
- }
- else if (success == 3)
- error ("CASE value out of range");
- else if (success == 4)
- error ("empty range");
- else if (success == 5)
- error ("label within scope of cleanup or variable array");
- }
-}
-
-void
-chill_handle_case_label (label_value, selector)
- tree label_value, selector;
-{
- if (label_value == NULL_TREE
- || TREE_CODE (label_value) == ERROR_MARK)
- return;
- if (TREE_CODE (label_value) == RANGE_EXPR)
- {
- if (TREE_OPERAND (label_value, 0) == NULL_TREE)
- chill_handle_case_default (); /* i.e. (ELSE): or (*): */
- else
- chill_handle_case_label_range (TREE_OPERAND (label_value, 0),
- TREE_OPERAND (label_value, 1),
- selector);
- }
- else if (TREE_CODE (label_value) == TYPE_DECL)
- {
- tree type = TREE_TYPE (label_value);
- if (! discrete_type_p (type))
- error ("mode in label is not discrete");
- else
- chill_handle_case_label_range (TYPE_MIN_VALUE (type),
- TYPE_MAX_VALUE (type),
- selector);
- }
- else
- {
- register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
-
- label_value = check_case_value (label_value, selector);
-
- if (TREE_CODE (label_value) != ERROR_MARK)
- {
- tree duplicate;
- int success = pushcase (label_value, convert, label, &duplicate);
- if (success == 1)
- error ("label not within a CASE statement");
- else if (success == 2)
- {
- error ("duplicate case value");
- error_with_decl (duplicate,
- "this is the first entry for that value");
- }
- else if (success == 3)
- error ("CASE value out of range");
- else if (success == 4)
- error ("empty range");
- else if (success == 5)
- error ("label within scope of cleanup or variable array");
- }
- }
-}
-
-int
-chill_handle_single_dimension_case_label (
- selector, label_spec, expand_exit_needed, caseaction_flag
-)
- tree selector, label_spec;
- int *expand_exit_needed, *caseaction_flag;
-{
- tree labels, one_label;
- int no_completeness_check = 0;
-
- if (*expand_exit_needed || *caseaction_flag == 1)
- {
- expand_exit_something ();
- *expand_exit_needed = 0;
- }
-
- for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels))
- for (one_label = TREE_VALUE (labels); one_label != NULL_TREE;
- one_label = TREE_CHAIN (one_label))
- {
- if (TREE_VALUE (one_label) == case_else_node)
- no_completeness_check = 1;
-
- chill_handle_case_label (TREE_VALUE (one_label), selector);
- }
-
- *caseaction_flag = 1;
-
- return no_completeness_check;
-}
-
-static tree
-chill_handle_multi_case_label_range (low, high, selector)
- tree low, high, selector;
-{
- tree low_expr, high_expr, and_expr;
- tree selector_type;
- int low_target_val, high_target_val;
- int low_type_val, high_type_val;
-
- /* we can eliminate some tests is the low and/or high value in the given range
- are outside the range of the selector type. */
- low_target_val = TREE_INT_CST_LOW (low);
- high_target_val = TREE_INT_CST_LOW (high);
- selector_type = TREE_TYPE (selector);
- low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
- high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
-
- if (low_target_val > high_type_val || high_target_val < low_type_val)
- return boolean_false_node; /* selector never in range */
-
- if (low_type_val >= low_target_val)
- {
- if (high_type_val <= high_target_val)
- return boolean_true_node; /* always in the range */
- return build_compare_expr (LE_EXPR, selector, high);
- }
-
- if (high_type_val <= high_target_val)
- return build_compare_expr (GE_EXPR, selector, low);
-
- /* The target range in completely within the range of the selector, but we
- might be able to save a test if the upper bound is the same as the lower
- bound. */
- if (low_target_val == high_target_val)
- return build_compare_expr (EQ_EXPR, selector, low);
-
- /* No optimizations possible. Just generate tests against the upper and lower
- bound of the target */
- low_expr = build_compare_expr (GE_EXPR, selector, low);
- high_expr = build_compare_expr (LE_EXPR, selector, high);
- and_expr = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr);
-
- return and_expr;
-}
-
-static tree
-chill_handle_multi_case_else_label (selector)
- tree selector;
-{
- tree else_range, selector_value, selector_type;
- tree low, high, larg;
-
- else_range = TREE_PURPOSE (selector);
- if (else_range == NULL_TREE)
- return boolean_false_node; /* no values in ELSE range */
-
- /* Test each of the ranges in the else-range chain */
- selector_value = TREE_VALUE (selector);
- selector_type = TREE_TYPE (selector_value);
- low = convert (selector_type, TREE_PURPOSE (else_range));
- high = convert (selector_type, TREE_VALUE (else_range));
- larg = chill_handle_multi_case_label_range (low, high, selector_value);
-
- for (else_range = TREE_CHAIN (else_range);
- else_range != NULL_TREE;
- else_range = TREE_CHAIN (else_range))
- {
- tree rarg;
- low = convert (selector_type, TREE_PURPOSE (else_range));
- high = convert (selector_type, TREE_VALUE (else_range));
- rarg = chill_handle_multi_case_label_range (low, high, selector_value);
- larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
- }
-
- return larg;
-}
-
-static tree
-chill_handle_multi_case_label (selector, label)
- tree selector, label;
-{
- tree expr = 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 ("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 ("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;
-}
-
-\f
-/* This is called with the assumption that RHS has been stabilized.
- It has one purpose: to iterate through the CHILL list of LHS's */
-void
-expand_assignment_action (loclist, modifycode, rhs)
- tree loclist;
- enum chill_tree_code modifycode;
- tree rhs;
-{
- if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK
- || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
- return;
-
- if (TREE_CHAIN (loclist) != NULL_TREE)
- { /* Multiple assignment */
- tree target;
- if (TREE_TYPE (rhs) != NULL_TREE)
- rhs = save_expr (rhs);
- else if (TREE_CODE (rhs) == CONSTRUCTOR)
- error ("type of tuple cannot be implicit in multiple assignent");
- else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR)
- error ("conditional expression cannot be used in multiple assignent");
- else
- error ("internal error - unknown type in multiple assignment");
-
- if (modifycode != NOP_EXPR)
- {
- error ("no operator allowed in multiple assignment,");
- modifycode = NOP_EXPR;
- }
-
- for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target))
- {
- if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)),
- TREE_TYPE (TREE_VALUE (loclist))))
- {
- error
- ("location modes in multiple assignment are not equivalent");
- break;
- }
- }
- }
- for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist))
- chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs);
-}
-
-void
-chill_expand_assignment (lhs, modifycode, rhs)
- tree lhs;
- enum chill_tree_code modifycode;
- tree rhs;
-{
- tree loc;
-
- while (TREE_CODE (lhs) == COMPOUND_EXPR)
- {
- expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0);
- emit_queue ();
- lhs = TREE_OPERAND (lhs, 1);
- }
-
- if (TREE_CODE (lhs) == ERROR_MARK)
- return;
-
- /* errors for assignment to BUFFER, EVENT locations.
- what about SIGNALs? FIXME: Need similar test in
- build_chill_function_call. */
- if (TREE_CODE (lhs) == IDENTIFIER_NODE)
- {
- tree decl = lookup_name (lhs);
- if (decl)
- {
- tree type = TREE_TYPE (decl);
- if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
- {
- error ("you may not assign a value to a BUFFER or EVENT location");
- return;
- }
- }
- }
-
- if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs))
- {
- error ("can't assign value to READonly location");
- return;
- }
- if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs)))
- {
- error ("cannot assign to location with non-value property");
- return;
- }
-
- if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE)
- lhs = convert_from_reference (lhs);
-
- /* check for lhs is a location */
- loc = lhs;
- while (1)
- {
- if (TREE_CODE (loc) == SLICE_EXPR)
- loc = TREE_OPERAND (loc, 0);
- else if (TREE_CODE (loc) == SET_IN_EXPR)
- loc = TREE_OPERAND (loc, 1);
- else
- break;
- }
- if (! CH_LOCATION_P (loc))
- {
- error ("lefthand side of assignment is not a location");
- return;
- }
-
- /* If a binary op has been requested, combine the old LHS value with
- the RHS producing the value we should actually store into the LHS. */
-
- if (modifycode != NOP_EXPR)
- {
- lhs = stabilize_reference (lhs);
- /* This is to handle border-line cases such
- as: LHS OR := [I]. This seems to be permitted
- by the letter of Z.200, though it violates
- its spirit, since LHS:=LHS OR [I] is
- *not* legal. */
- if (TREE_TYPE (rhs) == NULL_TREE)
- rhs = convert (TREE_TYPE (lhs), rhs);
- rhs = build_chill_binary_op (modifycode, lhs, rhs);
- }
-
- rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment");
-
- /* handle the LENGTH (vary_array) := expr action */
- loc = lhs;
- if (TREE_CODE (loc) == NOP_EXPR)
- loc = TREE_OPERAND (loc, 0);
- if (TREE_CODE (loc) == COMPONENT_REF
- && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0)))
- && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id)
- {
- expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs);
- }
- else if (TREE_CODE (lhs) == SLICE_EXPR)
- {
- tree func = lookup_name (get_identifier ("__pscpy"));
- tree dst = TREE_OPERAND (lhs, 0);
- tree dst_offset = TREE_OPERAND (lhs, 1);
- tree length = TREE_OPERAND (lhs, 2);
- tree src, src_offset;
- if (TREE_CODE (rhs) == SLICE_EXPR)
- {
- src = TREE_OPERAND (rhs, 0);
- /* Should check that the TREE_OPERAND (src, 0) is
- the same as length and powerserlen (src). FIXME */
- src_offset = TREE_OPERAND (rhs, 1);
- }
- else
- {
- src = rhs;
- src_offset = integer_zero_node;
- }
- expand_expr_stmt (build_chill_function_call (func,
- tree_cons (NULL_TREE, force_addr_of (dst),
- tree_cons (NULL_TREE, powersetlen (dst),
- tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset),
- tree_cons (NULL_TREE, force_addr_of (src),
- tree_cons (NULL_TREE, powersetlen (src),
- tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset),
- tree_cons (NULL_TREE, convert (long_unsigned_type_node, length),
- NULL_TREE)))))))));
- }
-
- else if (TREE_CODE (lhs) == SET_IN_EXPR)
- {
- tree from_pos = save_expr (TREE_OPERAND (lhs, 0));
- tree set = TREE_OPERAND (lhs, 1);
- tree domain = TYPE_DOMAIN (TREE_TYPE (set));
- tree set_length
- = 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 superseded 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));
-}
-\f
-/* Also assumes that rhs has been stabilized */
-void
-expand_varying_length_assignment (lhs, rhs)
- tree lhs, rhs;
-{
- tree base_array, min_domain_val;
-
- pedwarn ("LENGTH on left-hand-side is non-portable");
-
- if (! CH_LOCATION_P (lhs))
- {
- error ("can only set LENGTH of array location");
- return;
- }
-
- /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
- rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1);
-
- base_array = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs));
- min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array));
-
- lhs = build_component_ref (lhs, var_length_id);
- rhs = fold (build (MINUS_EXPR, TREE_TYPE (rhs), rhs, min_domain_val));
-
- expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
-}
-\f
-void
-push_action ()
-{
- push_handler ();
- if (ignoring)
- return;
- emit_line_note (input_filename, lineno);
-}
+++ /dev/null
-/* 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));
+++ /dev/null
-/* 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, respectively.
- 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. */
+++ /dev/null
-/* Definitions for CHILL parsing and type checking.
- 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. */
-
-#ifndef GCC_CH_TREE_H
-#define GCC_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)
-\f
-/* 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)
-\f
-/* 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 *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 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,
-};
-\f
-/* 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 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 /* ! GCC_CH_TREE_H */
+++ /dev/null
-#!/bin/sh
-# Compile GNU Chill programs.
-: || exec /bin/sh -f $0 $argv:q
-
-# The compiler name might be different when doing cross-compilation
-# (this should be configured)
-gcc_name=gcc
-whatgcc=gcc
-speclang=-xnone
-startfile=chillrt0
-gnuchill_script_flags=
-gnuchill_version=unknown
-extraflags=
-
-# replace the command name by the name of the new command
-progname=`basename $0`
-case "$0" in
- */*)
- gcc=`echo $0 | sed -e "s;/[^/]*$;;"`/$gcc_name
- ;;
- *)
- gcc=$gcc_name
- ;;
-esac
-
-# $first is yes for first arg, no afterwards.
-first=yes
-# If next arg is the argument of an option, $quote is non-empty.
-# More precisely, it is the option that wants an argument.
-quote=
-# $library is made empty to disable use of libchill.
-library="-lchill"
-libpath=chillrt
-numargs=$#
-
-for arg
-do
- if [ $first = yes ]
- then
- # Need some 1st arg to `set' which does not begin with `-'.
- # We get rid of it after the loop ends.
- set gcc
- first=no
- fi
- # If you have to ask what this does, you should not edit this file. :-)
- # The ``S'' at the start is so that echo -nostdinc does not eat the
- # -nostdinc.
- arg=`echo "S$arg" | sed "s/^S//; s/'/'\\\\\\\\''/g"`
- if [ x$quote != x ]
- then
- quote=
- else
- quote=
- case $arg in
- -nostdlib)
- # Inhibit linking with -lchill.
- library=
- libpath=
- startfile=
- ;;
- -B*)
- gcc=`echo $arg | sed -e "s/^-B//"`$gcc_name
- ;;
- -[bBVDUoeTuIYmLiA] | -Tdata | -Xlinker)
- # these switches take following word as argument,
- # so don't treat it as a file name.
- quote=$arg
- ;;
- -[cSEM] | -MM)
- # Don't specify libraries if we won't link,
- # since that would cause a warning.
- library=
- libpath=
- startfile=
- ;;
- -x*)
- speclang=$arg
- ;;
- -v)
- # catch `chill -v'
- if [ $numargs = 1 ] ; then
- library=
- libpath=
- startfile=
- fi
- echo "GNUCHILL version $gnuchill_version"
- ;;
- -fgrant-only | -fchill-grant-only)
- #inhibit production of an object file
- extraflags="-S -o /dev/null"
- library=
- libpath=
- startfile=
- ;;
- -*)
- # Pass other options through; they don't need -x and aren't inputs.
- ;;
- *)
- # If file ends in .i, put options around it.
- # But not if a specified -x option is currently active.
- case "$speclang $arg" in -xnone\ *.[i])
- set "$@" -xchill "'$arg'" -xnone
- continue
- esac
- ;;
- esac
- fi
- set "$@" "'$arg'"
-done
-
-# Get rid of that initial 1st arg
-if [ $first = no ]; then
- shift
-else
- echo "$0: No input files specified."
- exit 1
-fi
-
-if [ x$quote != x ]
-then
- echo "$0: argument to \`$quote' missing"
- exit 1
-fi
-
-# The '-ansi' flag prevents cpp from changing this:
-# NEWMODE x = SET (sun, mon, thu, wed, thu, fri, sat);
-#to this:
-# NEWMODE x = SET (1, mon, thu, wed, thu, fri, sat);
-#which is a CHILL syntax error.
-eval $whatgcc -ansi $gnuchill_script_flags $startfile "$@" $libpath $library $extraflags
+++ /dev/null
-@\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
-@contents
-
-@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
-
-@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.
-
-@bye
+++ /dev/null
-# Top level configure fragment for GNU CHILL.
-# Copyright (C) 1994, 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. */
-
-# 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)
-
-language="CHILL"
-
-compilers="cc1chill\$(exeext)"
-
-stagestuff="chill chill-cross\$(exeext) cc1chill\$(exeext)"
-
-outputs=ch/Makefile
-
-target_libs=target-libchill
-
-build_by_default=no
+++ /dev/null
-/* 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));
-\f
-static tree
-convert_to_reference (reftype, expr)
- tree reftype, expr;
-{
- while (TREE_CODE (expr) == NOP_EXPR) /* RETYPE_EXPR */
- expr = TREE_OPERAND (expr, 0);
-
- if (! CH_LOCATION_P (expr))
- error("internal error: trying to make loc-identity with non-location");
- else
- {
- mark_addressable (expr);
- return fold (build1 (ADDR_EXPR, reftype, expr));
- }
-
- return error_mark_node;
-}
-
-tree
-convert_from_reference (expr)
- tree expr;
-{
- tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
- TREE_READONLY (e) = TREE_READONLY (expr);
- return e;
-}
-
-/* Convert EXPR to a boolean type. */
-
-static tree
-convert_to_boolean (type, expr)
- tree type, expr;
-{
- register tree intype = TREE_TYPE (expr);
-
- if (integer_zerop (expr))
- return boolean_false_node;
- if (integer_onep (expr))
- return boolean_true_node;
-
- /* Convert a singleton bitstring to a Boolean.
- Needed if flag_old_strings. */
- if (CH_BOOLS_ONE_P (intype))
- {
- if (TREE_CODE (expr) == CONSTRUCTOR)
- {
- tree valuelist = TREE_OPERAND (expr, 1);
- if (valuelist == NULL_TREE)
- return boolean_false_node;
- if (TREE_CHAIN (valuelist) == NULL_TREE
- && TREE_PURPOSE (valuelist) == NULL_TREE
- && integer_zerop (TREE_VALUE (valuelist)))
- return boolean_true_node;
- }
- return build_chill_bitref (expr,
- build_tree_list (NULL_TREE,
- integer_zero_node));
- }
-
- if (INTEGRAL_TYPE_P (intype))
- return build1 (CONVERT_EXPR, type, expr);
-
- error ("cannot convert to a boolean mode");
- return boolean_false_node;
-}
-
-/* Convert EXPR to a char type. */
-
-static tree
-convert_to_char (type, expr)
- tree type, expr;
-{
- register tree intype = TREE_TYPE (expr);
- register enum chill_tree_code form = TREE_CODE (intype);
-
- if (form == CHAR_TYPE)
- return build1 (NOP_EXPR, type, expr);
-
- /* Convert a singleton string to a char.
- Needed if flag_old_strings. */
- if (CH_CHARS_ONE_P (intype))
- {
- if (TREE_CODE (expr) == STRING_CST)
- {
- expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
- TREE_TYPE (expr) = char_type_node;
- return expr;
- }
- else
- return build (ARRAY_REF, char_type_node, expr, integer_zero_node);
-
- }
-
- /* For now, assume it will always fit */
- if (form == INTEGER_TYPE)
- return build1 (CONVERT_EXPR, type, expr);
-
- error ("cannot convert to a char mode");
-
- {
- register tree tem = build_int_2 (0, 0);
- TREE_TYPE (tem) = type;
- return tem;
- }
-}
-\f
-#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);
-
-}
-\f
-#if 0
-static tree
-unreferenced_type_of (type)
- tree type;
-{
- if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
- return error_mark_node;
- while (TREE_CODE (type) == REFERENCE_TYPE)
- type = TREE_TYPE (type);
- return type;
-}
-#endif
-
-
-/* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
- Return the TREE_LIST node, or NULL_TREE on failure. */
-
-static tree
-remove_tree_element (key, listp)
- tree *listp;
- tree key;
-{
- tree node = *listp;
- for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
- {
- if (TREE_PURPOSE (node) == key)
- {
- *listp = TREE_CHAIN (node);
- TREE_CHAIN (node) = NULL_TREE;
- return node;
- }
- }
- return NULL_TREE;
-}
-
-/* This is quite the same as check_range in actions.c, but with
- different error message. */
-
-static tree
-check_ps_range (value, lo_limit, hi_limit)
- tree value;
- tree lo_limit;
- tree hi_limit;
-{
- tree check = test_range (value, lo_limit, hi_limit);
-
- if (!integer_zerop (check))
- {
- if (TREE_CODE (check) == INTEGER_CST)
- {
- error ("powerset tuple element out of range");
- return error_mark_node;
- }
- else
- value = check_expression (value, check,
- ridpointers[(int) RID_RANGEFAIL]);
- }
- return value;
-}
-
-static tree
-digest_powerset_tuple (type, inits)
- tree type;
- tree inits;
-{
- tree list;
- tree result;
- tree domain = TYPE_DOMAIN (type);
- int i = 0;
- int is_erroneous = 0, is_constant = 1, is_simple = 1;
- if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK)
- return error_mark_node;
- for (list = TREE_OPERAND (inits, 1); list; list = TREE_CHAIN (list), i++)
- {
- tree val = TREE_VALUE (list);
- if (TREE_CODE (val) == ERROR_MARK)
- {
- is_erroneous = 1;
- continue;
- }
- if (!TREE_CONSTANT (val))
- is_constant = 0;
- else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
- is_simple = 0;
- if (! CH_COMPATIBLE (val, domain))
- {
- error ("incompatible member of powerset tuple (at position #%d)", i);
- is_erroneous = 1;
- continue;
- }
- /* check range of value */
- val = check_ps_range (val, TYPE_MIN_VALUE (domain),
- TYPE_MAX_VALUE (domain));
- if (TREE_CODE (val) == ERROR_MARK)
- {
- is_erroneous = 1;
- continue;
- }
-
- /* Updating the list in place is in principle questionable,
- but I can't think how it could hurt. */
- TREE_VALUE (list) = convert (domain, val);
-
- val = TREE_PURPOSE (list);
- if (val == NULL_TREE)
- continue;
-
- if (TREE_CODE (val) == ERROR_MARK)
- {
- is_erroneous = 1;
- continue;
- }
- if (! CH_COMPATIBLE (val, domain))
- {
- error ("incompatible member of powerset tuple (at position #%d)", i);
- is_erroneous = 1;
- continue;
- }
- val = check_ps_range (val, TYPE_MIN_VALUE (domain),
- TYPE_MAX_VALUE (domain));
- if (TREE_CODE (val) == ERROR_MARK)
- {
- is_erroneous = 1;
- continue;
- }
- TREE_PURPOSE (list) = convert (domain, val);
- if (!TREE_CONSTANT (val))
- is_constant = 0;
- else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
- is_simple = 0;
- }
- result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
- if (is_erroneous)
- return error_mark_node;
- if (is_constant)
- TREE_CONSTANT (result) = 1;
- if (is_constant && is_simple)
- TREE_STATIC (result) = 1;
- return result;
-}
-
-static tree
-digest_structure_tuple (type, inits)
- tree type;
- tree inits;
-{
- tree elements = CONSTRUCTOR_ELTS (inits);
- tree values = NULL_TREE;
- int is_constant = 1;
- int is_simple = 1;
- int is_erroneous = 0;
- tree field;
- int labelled_elements = 0;
- int unlabelled_elements = 0;
- for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
- {
- if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
- { /* Regular fixed field. */
- tree value = remove_tree_element (DECL_NAME (field), &elements);
-
- if (value)
- labelled_elements++;
- else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
- {
- value = elements;
- elements = TREE_CHAIN (elements);
- unlabelled_elements++;
- }
-
- if (value)
- {
- tree val;
- char msg[120];
- sprintf (msg, "initializer for field `%.80s'",
- IDENTIFIER_POINTER (DECL_NAME (field)));
- val = chill_convert_for_assignment (TREE_TYPE (field),
- TREE_VALUE (value), msg);
- if (TREE_CODE (val) == ERROR_MARK)
- is_erroneous = 1;
- else
- {
- TREE_VALUE (value) = val;
- TREE_CHAIN (value) = values;
- TREE_PURPOSE (value) = field;
- values = value;
- if (TREE_CODE (val) == ERROR_MARK)
- is_erroneous = 1;
- else if (!TREE_CONSTANT (val))
- is_constant = 0;
- else if (!initializer_constant_valid_p (val,
- TREE_TYPE (val)))
- is_simple = 0;
- }
- }
- else
- {
- pedwarn ("no initializer value for fixed field `%s'",
- IDENTIFIER_POINTER (DECL_NAME (field)));
- }
- }
- else
- {
- tree variant;
- tree selected_variant = NULL_TREE;
- tree variant_values = NULL_TREE;
-
- /* In a tagged variant structure mode, try to figure out
- (from the fixed fields), which is the selected variant. */
- if (TYPE_TAGFIELDS (TREE_TYPE (field)))
- {
- for (variant = TYPE_FIELDS (TREE_TYPE (field));
- variant; variant = TREE_CHAIN (variant))
- {
- tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant));
- tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field));
- if (DECL_NAME (variant) == ELSE_VARIANT_NAME)
- {
- selected_variant = variant;
- break;
- }
- for (; tag_labels && tag_fields;
- tag_labels = TREE_CHAIN (tag_labels),
- tag_fields = TREE_CHAIN (tag_fields))
- {
- tree tag_value = values;
- int found = 0;
- tree tag_decl = TREE_VALUE (tag_fields);
- tree tag_value_set = TREE_VALUE (tag_labels);
- for ( ; tag_value; tag_value = TREE_CHAIN (tag_value))
- {
- if (TREE_PURPOSE (tag_value) == tag_decl)
- {
- tag_value = TREE_VALUE (tag_value);
- break;
- }
- }
- if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST)
- {
- pedwarn ("non-constant value for tag field `%s'",
- IDENTIFIER_POINTER (DECL_NAME (tag_decl)));
- goto get_values;
- }
-
- /* Check if the value of the tag (as given in a
- previous field) matches the case label list. */
- for (; tag_value_set;
- tag_value_set = TREE_CHAIN (tag_value_set))
- {
- if (tree_int_cst_equal (TREE_VALUE (tag_value_set),
- tag_value))
- {
- found = 1;
- break;
- }
- }
- if (!found)
- break;
- }
- if (!tag_fields)
- {
- selected_variant = variant;
- break;
- }
- }
- }
- get_values:
- for (variant = TYPE_FIELDS (TREE_TYPE (field));
- variant; variant = TREE_CHAIN (variant))
- {
- tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant));
- tree vfield;
- for (vfield = vfield0; vfield; vfield = TREE_CHAIN (vfield))
- {
- tree value = remove_tree_element (DECL_NAME (vfield),
- &elements);
-
- if (value)
- labelled_elements++;
- else if (variant == selected_variant
- && elements && TREE_PURPOSE (elements) == NULL_TREE)
- {
- value = elements;
- elements = TREE_CHAIN (elements);
- unlabelled_elements++;
- }
-
- if (value)
- {
- if (selected_variant && selected_variant != variant)
- {
- error ("field `%s' in wrong variant",
- IDENTIFIER_POINTER (DECL_NAME (vfield)));
- is_erroneous = 1;
- }
- else
- {
- if (!selected_variant && vfield != vfield0)
- pedwarn ("missing variant fields (at least `%s')",
- IDENTIFIER_POINTER (DECL_NAME (vfield0)));
- selected_variant = variant;
- if (CH_COMPATIBLE (TREE_VALUE (value),
- TREE_TYPE (vfield)))
- {
- tree val = convert (TREE_TYPE (vfield),
- TREE_VALUE (value));
- TREE_PURPOSE (value) = vfield;
- TREE_VALUE (value) = val;
- TREE_CHAIN (value) = variant_values;
- variant_values = value;
- if (TREE_CODE (val) == ERROR_MARK)
- is_erroneous = 1;
- else if (!TREE_CONSTANT (val))
- is_constant = 0;
- else if (!initializer_constant_valid_p
- (val, TREE_TYPE (val)))
- is_simple = 0;
- }
- else
- {
- is_erroneous = 1;
- error ("bad initializer for field `%s'",
- IDENTIFIER_POINTER (DECL_NAME (vfield)));
- }
- }
- }
- else if (variant == selected_variant)
- {
- pedwarn ("no initializer value for variant field `%s'",
- IDENTIFIER_POINTER (DECL_NAME (field)));
- }
- }
- }
- if (selected_variant == NULL_TREE)
- pedwarn ("no selected variant");
- else
- {
- variant_values = build (CONSTRUCTOR,
- TREE_TYPE (selected_variant),
- NULL_TREE, nreverse (variant_values));
- variant_values
- = build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE,
- build_tree_list (selected_variant, variant_values));
- values = tree_cons (field, variant_values, values);
- }
- }
- }
-
- if (labelled_elements && unlabelled_elements)
- pedwarn ("mixture of labelled and unlabelled tuple elements");
-
- /* Check for unused initializer elements. */
- unlabelled_elements = 0;
- for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements))
- {
- if (TREE_PURPOSE (elements) == NULL_TREE)
- unlabelled_elements++;
- else
- {
- if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0)
- error ("probably not a structure tuple");
- else
- error ("excess initializer for field `%s'",
- IDENTIFIER_POINTER (TREE_PURPOSE (elements)));
- is_erroneous = 1;
- }
- }
- if (unlabelled_elements)
- {
- error ("excess unnamed initializers");
- is_erroneous = 1;
- }
-
- CONSTRUCTOR_ELTS (inits) = nreverse (values);
- TREE_TYPE (inits) = type;
- if (is_erroneous)
- return error_mark_node;
- if (is_constant)
- TREE_CONSTANT (inits) = 1;
- if (is_constant && is_simple)
- TREE_STATIC (inits) = 1;
- return inits;
-}
-
-/* Return a Chill representation of the INTEGER_CST VAL.
- The result may be in a static buffer, */
-
-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;
-}
-\f
-/* This function is needed because no-op CHILL conversions are not fully
- understood by the initialization machinery. This function should only
- be called when a conversion truly is a no-op. */
-
-static tree
-convert1 (type, expr)
- tree type, expr;
-{
- int was_constant = TREE_CONSTANT (expr);
- STRIP_NOPS (expr);
- was_constant |= TREE_CONSTANT (expr);
- expr = copy_node (expr);
- TREE_TYPE (expr) = type;
- if (TREE_CONSTANT (expr) != was_constant) abort ();
- TREE_CONSTANT (expr) = was_constant;
- return expr;
-}
-
-/* Create an expression whose value is that of EXPR,
- converted to type TYPE. The TREE_TYPE of the value
- is always TYPE. This function implements all reasonable
- conversions; callers should filter out those that are
- not permitted by the language being compiled.
-
- In CHILL, we assume that the type is Compatible with the
- Class of expr, and generally complain otherwise.
- However, convert is more general (e.g. allows enum<->int
- conversion), so there should probably be at least two routines.
- Maybe add something like convert_for_assignment. FIXME. */
-
-tree
-convert (type, expr)
- tree type, expr;
-{
- register tree e = expr;
- register enum chill_tree_code code;
- 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;
- }
- /* FIXME check that nentries will fit in type; */
- 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;
-}
+++ /dev/null
-/* 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"
-#include "diagnostic.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;
-\f
-/* Lots of declarations copied from c-decl.c. */
-/* ??? not all decl nodes are given the most useful possible
- line numbers. For example, the CONST_DECLs for enum values. */
-
-
-/* We let tm.h override the types used here, to handle trivial differences
- such as the choice of unsigned int or long unsigned int for size_t.
- When machines start needing nontrivial differences in the size type,
- it would be best to do something here to figure out automatically
- from other information what type to use. */
-
-#ifndef PTRDIFF_TYPE
-#define PTRDIFF_TYPE "long int"
-#endif
-
-#ifndef WCHAR_TYPE
-#define WCHAR_TYPE "int"
-#endif
-\f
-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;
-\f
-/* For each binding contour we allocate a scope structure
- * which records the names defined in that contour.
- * Contours include:
- * 0) the global one
- * 1) one for each function definition,
- * where internal declarations of the parameters appear.
- * 2) one for each compound statement,
- * to record its declarations.
- *
- * The current meaning of a name can be found by searching the levels from
- * the current one out to the global one.
- */
-
-/* To communicate between pass 1 and 2, we maintain a list of "scopes".
- Each scope corrresponds to a nested source scope/block that contain
- that can contain declarations. The TREE_VALUE of the scope points
- to the list of declarations declared in that scope.
- The TREE_PURPOSE of the scope points to the surrounding scope.
- (We may need to handle nested modules later. FIXME)
- The TREE_CHAIN field contains a list of scope as they are seen
- in chronological order. (Reverse order during first pass,
- but it is reverse before pass 2.) */
-
-struct scope
-{
- /* The enclosing scope. */
- struct scope *enclosing;
-
- /* The next scope, in chronlogical order. */
- struct scope *next;
-
- /* A chain of DECLs constructed using save_decl during pass 1. */
- tree remembered_decls;
-
- /* A chain of _DECL nodes for all variables, constants, functions,
- and typedef types belong to this scope. */
- tree decls;
-
- /* List of declarations that have been granted into this scope. */
- tree granted_decls;
-
- /* List of implied (weak) names. */
- tree weak_decls;
-
- /* For each level, a list of shadowed outer-level local definitions
- to be restored when this level is popped.
- Each link is a TREE_LIST whose TREE_PURPOSE is an identifier and
- whose TREE_VALUE is its old definition (a kind of ..._DECL node). */
- tree shadowed;
-
- /* For each level (except not the global one),
- a chain of BLOCK nodes for all the levels
- that were entered and exited one level down. */
- tree blocks;
-
- /* The BLOCK node for this level, if one has been preallocated.
- If 0, the BLOCK is allocated (if needed) when the level is popped. */
- tree this_block;
-
- /* The binding level which this one is contained in (inherits from). */
- struct scope *level_chain;
-
- /* Nonzero for a level that corresponds to a module. */
- char module_flag;
-
- /* Zero means called from backend code. */
- char two_pass;
-
- /* The modules that are directly enclosed by this scope
- are chained together. */
- struct scope* first_child_module;
- struct scope** tail_child_module;
- struct scope* next_sibling_module;
-};
-
-/* The outermost binding level, for pre-defined (builtin) names. */
-
-static struct scope builtin_scope = {
- NULL, NULL, NULL_TREE, 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;
-\f
-/* C-specific option variables. */
-
-/* Nonzero means allow type mismatches in conditional expressions;
- just make their values `void'. */
-
-int flag_cond_mismatch;
-
-/* Nonzero means give `double' the same size as `float'. */
-
-int flag_short_double;
-
-/* Nonzero means don't recognize the keyword `asm'. */
-
-int flag_no_asm;
-
-/* Nonzero means don't recognize any builtin functions. */
-
-int flag_no_builtin;
-
-/* Nonzero means don't recognize the non-ANSI builtin functions.
- -ansi sets this. */
-
-int flag_no_nonansi_builtin;
-
-/* Nonzero means 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 tree_code_type[] = {
-#include "tree.def"
- '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,
-
-const unsigned char tree_code_length[] = {
-#include "tree.def"
- 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 *const tree_code_name[] = {
-#include "tree.def"
- "@@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;
-\f
-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);
-}
-\f
-/* Decode the string P as a language-specific option for C.
- Return the number of strings consumed for a valid option.
- Return 0 for an invalid option. */
-
-int
-c_decode_option (argc, argv)
- int argc ATTRIBUTE_UNUSED;
- char **argv;
-{
- char *p = argv[0];
-
- 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 ");
-}
-\f
-/* initialise non-value struct */
-
-static int
-init_nonvalue_struct (expr)
- tree expr;
-{
- tree type = TREE_TYPE (expr);
- tree field;
- int res = 0;
-
- if (CH_IS_BUFFER_MODE (type))
- {
- expand_expr_stmt (
- build_chill_modify_expr (
- build_component_ref (expr, get_identifier ("__buffer_data")),
- null_pointer_node));
- return 1;
- }
- else if (CH_IS_EVENT_MODE (type))
- {
- expand_expr_stmt (
- build_chill_modify_expr (
- build_component_ref (expr, get_identifier ("__event_data")),
- null_pointer_node));
- return 1;
- }
- else if (CH_IS_ASSOCIATION_MODE (type))
- {
- expand_expr_stmt (
- build_chill_modify_expr (expr,
- chill_convert_for_assignment (type, association_init_value,
- "association")));
- return 1;
- }
- else if (CH_IS_ACCESS_MODE (type))
- {
- init_access_location (expr, type);
- return 1;
- }
- else if (CH_IS_TEXT_MODE (type))
- {
- init_text_location (expr, type);
- return 1;
- }
-
- for (field = TYPE_FIELDS (type); field != NULL_TREE; field = TREE_CHAIN (field))
- {
- type = TREE_TYPE (field);
- if (CH_TYPE_NONVALUE_P (type))
- {
- tree exp = build_component_ref (expr, DECL_NAME (field));
- if (TREE_CODE (type) == RECORD_TYPE)
- res |= init_nonvalue_struct (exp);
- else if (TREE_CODE (type) == ARRAY_TYPE)
- res |= init_nonvalue_array (exp);
- }
- }
- return res;
-}
-
-/* initialize non-value array */
-/* do it with DO FOR unique-id IN expr; ... OD; */
-static int
-init_nonvalue_array (expr)
- tree expr;
-{
- tree tmpvar = get_unique_identifier ("NONVALINIT");
- tree type;
- int res = 0;
-
- push_loop_block ();
- build_loop_iterator (tmpvar, expr, NULL_TREE, NULL_TREE, 0, 1, 0);
- nonvalue_begin_loop_scope ();
- build_loop_start (NULL_TREE);
- tmpvar = lookup_name (tmpvar);
- type = TREE_TYPE (tmpvar);
- if (CH_TYPE_NONVALUE_P (type))
- {
- if (TREE_CODE (type) == RECORD_TYPE)
- res |= init_nonvalue_struct (tmpvar);
- else if (TREE_CODE (type) == ARRAY_TYPE)
- res |= init_nonvalue_array (tmpvar);
- }
- build_loop_end ();
- nonvalue_end_loop_scope ();
- pop_loop_block ();
- return res;
-}
-\f
-/* This excessive piece of code sets DECL_NESTING_LEVEL (DECL) to LEVEL. */
-
-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];
- }
-}
-\f
-/* OPT_EXTERNAL is non-zero when the declaration is at module level.
- * OPT_EXTERNAL == 2 means implicitly grant it.
- */
-void
-do_decls (names, type, opt_static, lifetime_bound, opt_init, opt_external)
- tree names;
- tree type;
- int opt_static;
- int lifetime_bound;
- tree opt_init;
- int opt_external;
-{
- if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
- {
- for (; names != NULL_TREE; names = TREE_CHAIN (names))
- do_decl (TREE_VALUE (names), type, opt_static, lifetime_bound,
- opt_init, opt_external);
- }
- else if (TREE_CODE (names) != ERROR_MARK)
- do_decl (names, type, opt_static, lifetime_bound, opt_init, opt_external);
-}
-
-tree
-do_decl (name, type, is_static, lifetime_bound, opt_init, opt_external)
- tree name, type;
- int is_static;
- int lifetime_bound;
- tree opt_init;
- int opt_external;
-{
- tree decl;
-
- if (current_function_decl == global_function_decl
- && ! lifetime_bound /*&& opt_init != NULL_TREE*/)
- seen_action = 1;
-
- if (pass < 2)
- {
- push_obstacks (&permanent_obstack, &permanent_obstack);
- decl = make_node (VAR_DECL);
- DECL_NAME (decl) = name;
- TREE_TYPE (decl) = type;
- DECL_ASSEMBLER_NAME (decl) = name;
-
- /* Try to put things in common when possible.
- Tasking variables must go into common. */
- DECL_COMMON (decl) = 1;
- DECL_EXTERNAL (decl) = opt_external > 0;
- TREE_PUBLIC (decl) = opt_external > 0;
- TREE_STATIC (decl) = is_static;
-
- if (pass == 0)
- {
- /* We have to set this here, since we build the decl w/o
- calling `build_decl'. */
- DECL_INITIAL (decl) = opt_init;
- pushdecl (decl);
- finish_decl (decl);
- }
- else
- {
- save_decl (decl);
- pop_obstacks ();
- }
- DECL_INITIAL (decl) = opt_init;
- if (opt_external > 1 || in_pseudo_module)
- push_granted (DECL_NAME (decl), decl);
- }
- else /* pass == 2 */
- {
- tree temp = NULL_TREE;
- int init_it = 0;
-
- decl = get_next_decl ();
-
- if (name != DECL_NAME (decl))
- abort ();
-
- type = TREE_TYPE (decl);
-
- push_obstacks_nochange ();
- if (TYPE_READONLY_PROPERTY (type))
- {
- if (CH_TYPE_NONVALUE_P (type))
- {
- error_with_decl (decl, "`%s' must not be declared readonly");
- opt_init = NULL_TREE; /* prevent subsequent errors */
- }
- else if (opt_init == NULL_TREE && !opt_external)
- error("declaration of readonly variable without initialization");
- }
- TREE_READONLY (decl) = TYPE_READONLY (type);
-
- if (!opt_init && chill_varying_type_p (type))
- {
- tree fixed_part_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
- if (fixed_part_type != NULL_TREE && TREE_CODE (fixed_part_type) != ERROR_MARK)
- {
- if (CH_CHARS_TYPE_P (fixed_part_type))
- opt_init = build_chill_string (0, "");
- else
- opt_init = build_nt (CONSTRUCTOR, NULL_TREE, NULL_TREE);
- lifetime_bound = 1;
- }
- }
-
- if (opt_init)
- {
- if (CH_TYPE_NONVALUE_P (type))
- {
- error_with_decl (decl,
- "no initialization allowed for `%s'");
- temp = NULL_TREE;
- }
- else if (TREE_CODE (type) == REFERENCE_TYPE)
- { /* A loc-identity declaration */
- if (! CH_LOCATION_P (opt_init))
- {
- error_with_decl (decl,
- "value for loc-identity `%s' is not a location");
- temp = NULL_TREE;
- }
- else if (! CH_READ_COMPATIBLE (TREE_TYPE (type),
- TREE_TYPE (opt_init)))
- {
- error_with_decl (decl,
- "location for `%s' not read-compatible");
- temp = NULL_TREE;
- }
- else
- temp = convert (type, opt_init);
- }
- else
- { /* Normal location declaration */
- char place[80];
- sprintf (place, "`%.60s' initializer",
- IDENTIFIER_POINTER (DECL_NAME (decl)));
- temp = chill_convert_for_assignment (type, opt_init, place);
- }
- }
- else if (CH_TYPE_NONVALUE_P (type))
- {
- temp = NULL_TREE;
- init_it = 1;
- }
- DECL_INITIAL (decl) = NULL_TREE;
-
- if (temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK)
- {
- /* The same for stack variables (assuming no nested modules). */
- if (lifetime_bound || !is_static)
- {
- if (is_static && ! TREE_CONSTANT (temp))
- error_with_decl (decl, "nonconstant initializer for `%s'");
- else
- DECL_INITIAL (decl) = temp;
- }
- }
- finish_decl (decl);
- /* Initialize the variable unless initialized statically. */
- if ((!is_static || ! lifetime_bound) &&
- temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK)
- {
- int was_used = TREE_USED (decl);
- emit_line_note (input_filename, lineno);
- expand_expr_stmt (build_chill_modify_expr (decl, temp));
- /* Don't let the initialization count as "using" the variable. */
- TREE_USED (decl) = was_used;
- if (current_function_decl == global_function_decl)
- build_constructor = 1;
- }
- else if (init_it && TREE_CODE (type) != ERROR_MARK)
- {
- /* Initialize variables with non-value type */
- int was_used = TREE_USED (decl);
- int something_initialised = 0;
-
- emit_line_note (input_filename, lineno);
- if (TREE_CODE (type) == RECORD_TYPE)
- something_initialised = init_nonvalue_struct (decl);
- else if (TREE_CODE (type) == ARRAY_TYPE)
- something_initialised = init_nonvalue_array (decl);
- if (! something_initialised)
- {
- error ("do_decl: internal error: don't know what to initialize");
- abort ();
- }
- /* Don't let the initialization count as "using" the variable. */
- TREE_USED (decl) = was_used;
- if (current_function_decl == global_function_decl)
- build_constructor = 1;
- }
- }
- return decl;
-}
-\f
-/*
- * ARGTYPES is a tree_list of formal argument types. TREE_VALUE
- * is the type tree for each argument, while the attribute is in
- * TREE_PURPOSE.
- */
-tree
-build_chill_function_type (return_type, argtypes, exceptions, recurse_p)
- tree return_type, argtypes, exceptions, recurse_p;
-{
- tree ftype, arg;
-
- if (exceptions != NULL_TREE)
- {
- /* if we have exceptions we add 2 arguments, callers filename
- and linenumber. These arguments will be added automatically
- when calling a function which may raise exceptions. */
- argtypes = chainon (argtypes,
- build_tree_list (NULL_TREE, ridpointers[(int) RID_PTR]));
- argtypes = chainon (argtypes,
- build_tree_list (NULL_TREE, ridpointers[(int) RID_LONG]));
-}
-
- /* Indicate the argument list is complete. */
- argtypes = chainon (argtypes,
- build_tree_list (NULL_TREE, void_type_node));
-
- /* INOUT and OUT parameters must be a REFERENCE_TYPE since
- we'll be passing a temporary's address at call time. */
- for (arg = argtypes; arg; arg = TREE_CHAIN (arg))
- if (TREE_PURPOSE (arg) == ridpointers[(int) RID_LOC]
- || TREE_PURPOSE (arg) == ridpointers[(int) RID_OUT]
- || TREE_PURPOSE (arg) == ridpointers[(int) RID_INOUT]
- )
- TREE_VALUE (arg) =
- build_chill_reference_type (TREE_VALUE (arg));
-
- /* Cannot use build_function_type, because if does hash-canonlicalization. */
- ftype = make_node (FUNCTION_TYPE);
- TREE_TYPE (ftype) = return_type ? return_type : void_type_node ;
- TYPE_ARG_TYPES (ftype) = argtypes;
-
- if (exceptions)
- ftype = build_exception_variant (ftype, exceptions);
-
- if (recurse_p)
- sorry ("RECURSIVE PROCs");
-
- return ftype;
-}
-\f
-/*
- * ARGTYPES is a tree_list of formal argument types.
- */
-tree
-push_extern_function (name, typespec, argtypes, exceptions, granting)
- tree name, typespec, argtypes, exceptions;
- int granting 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;
-}
-
-
-\f
-void
-push_extern_process (name, argtypes, exceptions, granting)
- tree name, argtypes, exceptions;
- int granting;
-{
- tree decl, func, arglist;
-
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
- if (pass < 2)
- {
- tree proc_struct = make_process_struct (name, argtypes);
- arglist = (argtypes == NULL_TREE) ? NULL_TREE :
- tree_cons (NULL_TREE,
- build_chill_pointer_type (proc_struct), NULL_TREE);
- }
- else
- arglist = NULL_TREE;
-
- func = push_extern_function (name, NULL_TREE, arglist,
- exceptions, granting);
-
- /* declare the code variable */
- decl = generate_tasking_code_variable (name, &process_type, 1);
- CH_DECL_PROCESS (func) = 1;
- /* remember the code variable in the function decl */
- DECL_TASKING_CODE_DECL (func) = (struct lang_decl *)decl;
-
- add_taskstuff_to_list (decl, "_TT_Process", NULL_TREE, func, NULL_TREE);
-}
-\f
-void
-push_extern_signal (signame, sigmodelist, optsigdest)
- tree signame, sigmodelist, optsigdest;
-{
- tree decl, sigtype;
-
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
- sigtype =
- build_signal_struct_type (signame, sigmodelist, optsigdest);
-
- /* declare the code variable outside the process */
- decl = generate_tasking_code_variable (signame, &signal_code, 1);
- add_taskstuff_to_list (decl, "_TT_Signal", NULL_TREE, sigtype, NULL_TREE);
-}
-\f
-void
-print_mode (mode)
- tree mode;
-{
- while (mode != NULL_TREE)
- {
- switch (TREE_CODE (mode))
- {
- case POINTER_TYPE:
- printf (" REF ");
- mode = TREE_TYPE (mode);
- break;
- case INTEGER_TYPE:
- case REAL_TYPE:
- printf (" %s ", IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (mode))));
- mode = NULL_TREE;
- break;
- case ARRAY_TYPE:
- {
- tree itype = TYPE_DOMAIN (mode);
- if (CH_STRING_TYPE_P (mode))
- {
- 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 ();
- }
- }
-}
-\f
-tree
-chill_munge_params (nodes, type, attr)
- tree nodes, type, attr;
-{
- tree node;
- if (pass == 1)
- {
- /* Convert the list of identifiers to a list of types. */
- for (node = nodes; node != NULL_TREE; node = TREE_CHAIN (node))
- {
- TREE_VALUE (node) = type; /* this was the identifier node */
- TREE_PURPOSE (node) = attr;
- }
- }
- return nodes;
-}
-
-/* Push the declarations described by SYN_DEFS into the current scope. */
-void
-push_syndecl (name, mode, value)
- tree name, mode, value;
-{
- if (pass == 1)
- {
- tree decl = make_node (CONST_DECL);
- DECL_NAME (decl) = name;
- DECL_ASSEMBLER_NAME (decl) = name;
- TREE_TYPE (decl) = mode;
- DECL_INITIAL (decl) = value;
- TREE_READONLY (decl) = 1;
- save_decl (decl);
- if (in_pseudo_module)
- push_granted (DECL_NAME (decl), decl);
- }
- else /* pass == 2 */
- get_next_decl ();
-}
-
-
-\f
-/* Push the declarations described by (MODENAME,MODE) into the current scope.
- MAKE_NEWMODE is 1 for NEWMODE, 0 for SYNMODE, and
- -1 for internal use (in which case the mode does not need to be copied). */
-
-tree
-push_modedef (modename, mode, make_newmode)
- tree modename;
- tree mode; /* ignored if pass==2. */
- int make_newmode;
-{
- tree newdecl, newmode;
-
- if (pass == 1)
- {
- /* FIXME: need to check here for SYNMODE fred fred; */
- push_obstacks (&permanent_obstack, &permanent_obstack);
-
- newdecl = build_lang_decl (TYPE_DECL, modename, mode);
-
- if (make_newmode >= 0)
- {
- newmode = make_node (LANG_TYPE);
- TREE_TYPE (newmode) = mode;
- TREE_TYPE (newdecl) = newmode;
- TYPE_NAME (newmode) = newdecl;
- if (make_newmode > 0)
- CH_NOVELTY (newmode) = newdecl;
- }
-
- save_decl (newdecl);
- pop_obstacks ();
-
- }
- else /* pass == 2 */
- {
- /* FIXME: need to check here for SYNMODE fred fred; */
- newdecl = get_next_decl ();
- if (DECL_NAME (newdecl) != modename)
- abort ();
- if (TREE_CODE (TREE_TYPE (newdecl)) != ERROR_MARK)
- {
- /* ASSOCIATION, ACCESS, TEXT, BUFFER, and EVENT must not be READOnly */
- if (TREE_READONLY (TREE_TYPE (newdecl)) &&
- (CH_IS_ASSOCIATION_MODE (TREE_TYPE (newdecl)) ||
- CH_IS_ACCESS_MODE (TREE_TYPE (newdecl)) ||
- CH_IS_TEXT_MODE (TREE_TYPE (newdecl)) ||
- CH_IS_BUFFER_MODE (TREE_TYPE (newdecl)) ||
- CH_IS_EVENT_MODE (TREE_TYPE (newdecl))))
- error_with_decl (newdecl, "`%s' must not be READonly");
- rest_of_decl_compilation (newdecl, NULL_PTR,
- global_bindings_p (), 0);
- }
- }
- return newdecl;
-}
-\f
-/* Return a chain of FIELD_DECLs for the names in NAMELIST. All of
- of type TYPE. When NAMELIST is passed in from the parser, it is
- in reverse order.
- LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
- meaning (default, pack, nopack, POS (...) ). */
-
-tree
-grok_chill_fixedfields (namelist, type, layout)
- tree namelist, type;
- tree layout;
-{
- tree decls = NULL_TREE;
-
- if (layout != NULL_TREE && TREE_CHAIN (namelist) != NULL_TREE)
- {
- if (layout != integer_one_node && layout != integer_zero_node)
- {
- layout = NULL_TREE;
- error ("POS may not be specified for a list of field declarations");
- }
- }
-
- /* we build the chain of FIELD_DECLs backwards, effectively
- unreversing the reversed names in NAMELIST. */
- for (; namelist; namelist = TREE_CHAIN (namelist))
- {
- tree decl = build_decl (FIELD_DECL,
- TREE_VALUE (namelist), type);
- DECL_INITIAL (decl) = layout;
- TREE_CHAIN (decl) = decls;
- decls = decl;
- }
-
- return decls;
-}
-\f
-struct tree_pair
-{
- tree value;
- tree decl;
-};
-
-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);
-}
-\f
-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;
-}
-\f
-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;
-}
-\f
-/* Convert a TREE_LIST of tag field names into a list of
- field decls, found from FIXED_FIELDS, re-using the input list. */
-
-tree
-lookup_tag_fields (tag_field_names, fixed_fields)
- tree tag_field_names;
- tree fixed_fields;
-{
- tree list;
- for (list = tag_field_names; list != NULL_TREE; list = TREE_CHAIN (list))
- {
- tree decl = fixed_fields;
- for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl))
- {
- if (DECL_NAME (decl) == TREE_VALUE (list))
- {
- TREE_VALUE (list) = decl;
- break;
- }
- }
- if (decl == NULL_TREE)
- {
- error ("no field (yet) for tag %s",
- IDENTIFIER_POINTER (TREE_VALUE (list)));
- TREE_VALUE (list) = error_mark_node;
- }
- }
- return tag_field_names;
-}
-
-/* If non-NULL, TAGFIELDS is the tag fields for this variant record.
- BODY is a TREE_LIST of (optlabels, fixed fields).
- If non-null, VARIANTELSE is a fixed field for the else part of the
- variant record. */
-
-tree
-grok_chill_variantdefs (tagfields, body, variantelse)
- tree tagfields, body, variantelse;
-{
- tree t;
-
- t = make_chill_variants (tagfields, body, variantelse);
- if (pass != 1)
- t = layout_chill_variants (t);
- return build_decl (FIELD_DECL, NULL_TREE, t);
-}
-\f
-/*
- In pass 1, PARMS is a list of types (with attributes).
- In pass 2, PARMS is a chain of PARM_DECLs.
- */
-
-int
-start_chill_function (label, rtype, parms, exceptlist, attrs)
- tree label, rtype, parms, exceptlist, attrs;
-{
- tree decl, fndecl, type, result_type, func_type;
- int nested = current_function_decl != 0;
- if (pass == 1)
- {
- func_type
- = build_chill_function_type (rtype, parms, exceptlist, 0);
- fndecl = build_decl (FUNCTION_DECL, label, func_type);
-
- save_decl (fndecl);
-
- /* Make the init_value nonzero so pushdecl knows this is not tentative.
- error_mark_node is replaced below (in poplevel) with the BLOCK. */
- DECL_INITIAL (fndecl) = error_mark_node;
-
- DECL_EXTERNAL (fndecl) = 0;
-
- /* This function exists in static storage.
- (This does not mean `static' in the C sense!) */
- TREE_STATIC (fndecl) = 1;
-
- for (; attrs != NULL_TREE; attrs = TREE_CHAIN (attrs))
- {
- if (TREE_VALUE (attrs) == ridpointers[RID_GENERAL])
- CH_DECL_GENERAL (fndecl) = 1;
- else if (TREE_VALUE (attrs) == ridpointers[RID_SIMPLE])
- CH_DECL_SIMPLE (fndecl) = 1;
- else if (TREE_VALUE (attrs) == ridpointers[RID_RECURSIVE])
- CH_DECL_RECURSIVE (fndecl) = 1;
- else if (TREE_VALUE (attrs) == ridpointers[RID_INLINE])
- DECL_INLINE (fndecl) = 1;
- else
- abort ();
- }
- }
- else /* pass == 2 */
- {
- fndecl = get_next_decl ();
- if (DECL_NAME (fndecl) != label)
- abort (); /* outta sync - got wrong decl */
- func_type = TREE_TYPE (fndecl);
- if (TYPE_RAISES_EXCEPTIONS (func_type) != NULL_TREE)
- {
- /* In this case we have to add 2 parameters.
- See build_chill_function_type (pass == 1). */
- tree arg;
-
- arg = make_node (PARM_DECL);
- DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_FILE);
- DECL_IGNORED_P (arg) = 1;
- parms = chainon (parms, arg);
-
- arg = make_node (PARM_DECL);
- DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_LINE);
- DECL_IGNORED_P (arg) = 1;
- parms = chainon (parms, arg);
- }
- }
-
- current_function_decl = fndecl;
- result_type = TREE_TYPE (func_type);
- if (CH_TYPE_NONVALUE_P (result_type))
- error ("non-value mode may only returned by LOC");
-
- pushlevel (1); /* Push parameters. */
-
- if (pass == 2)
- {
- DECL_ARGUMENTS (fndecl) = parms;
- for (decl = DECL_ARGUMENTS (fndecl), type = TYPE_ARG_TYPES (func_type);
- decl != NULL_TREE;
- decl = TREE_CHAIN (decl), type = TREE_CHAIN (type))
- {
- /* check here that modes with the non-value property (like
- BUFFER's, EVENT's, ASSOCIATION's, ACCESS's, or TEXT's) only
- gets passed by LOC */
- tree argtype = TREE_VALUE (type);
- tree argattr = TREE_PURPOSE (type);
-
- if (TREE_CODE (argtype) == REFERENCE_TYPE)
- argtype = TREE_TYPE (argtype);
-
- if (TREE_CODE (argtype) != ERROR_MARK &&
- TREE_CODE_CLASS (TREE_CODE (argtype)) != 't')
- {
- error_with_decl (decl, "mode of `%s' is not a mode");
- TREE_VALUE (type) = error_mark_node;
- }
-
- if (CH_TYPE_NONVALUE_P (argtype) &&
- argattr != ridpointers[(int) RID_LOC])
- error_with_decl (decl, "`%s' may only be passed by LOC");
- TREE_TYPE (decl) = TREE_VALUE (type);
- DECL_ARG_TYPE (decl) = TREE_TYPE (decl);
- DECL_CONTEXT (decl) = fndecl;
- TREE_READONLY (decl) = TYPE_READONLY (argtype);
- layout_decl (decl, 0);
- }
-
- pushdecllist (DECL_ARGUMENTS (fndecl), 0);
-
- DECL_RESULT (current_function_decl)
- = build_decl (RESULT_DECL, NULL_TREE, result_type);
-
-#if 0
- /* Write a record describing this function definition to the prototypes
- file (if requested). */
- gen_aux_info_record (fndecl, 1, 0, prototype);
-#endif
-
- if (fndecl != global_function_decl || seen_action)
- {
- /* Initialize the RTL code for the function. */
- init_function_start (fndecl, input_filename, lineno);
-
- /* Set up parameters and prepare for return, for the function. */
- expand_function_start (fndecl, 0);
- }
-
- if (!nested)
- /* Allocate further tree nodes temporarily during compilation
- of this function only. */
- temporary_allocation ();
-
- /* If this fcn was already referenced via a block-scope `extern' decl (or
- an implicit decl), propagate certain information about the usage. */
- if (TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (current_function_decl)))
- TREE_ADDRESSABLE (current_function_decl) = 1;
- }
-
- /* Z.200 requires that formal parameter names be defined in
- the same block as the procedure body.
- We could do this by keeping boths sets of DECLs in the same
- scope, but we would have to be careful to not merge the
- two chains (e.g. DECL_ARGUEMENTS musr not contains locals).
- Instead, we just make sure they have the same nesting_level. */
- current_nesting_level--;
- pushlevel (1); /* Push local variables. */
-
- if (pass == 2 && (fndecl != global_function_decl || seen_action))
- {
- /* generate label for possible 'exit' */
- expand_start_bindings (1);
-
- result_never_set = 1;
- }
-
- if (TREE_CODE (result_type) == VOID_TYPE)
- chill_result_decl = NULL_TREE;
- else
- {
- /* We use the same name as the keyword.
- This makes it easy to print and change the RESULT from gdb. */
- 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;
-}
-\f
-/* For checking purpose added pname as new argument
- MW Wed Oct 14 14:22:10 1992 */
-void
-finish_chill_function ()
-{
- register tree fndecl = current_function_decl;
- tree outer_function = decl_function_context (fndecl);
- int nested;
- if (outer_function == NULL_TREE && fndecl != global_function_decl)
- outer_function = global_function_decl;
- nested = current_function_decl != global_function_decl;
- if (pass == 2 && (fndecl != global_function_decl || seen_action))
- expand_end_bindings (getdecls (), 1, 0);
-
- /* pop out of function */
- poplevel (1, 1, 0);
- current_nesting_level++;
- /* pop out of its parameters */
- poplevel (1, 0, 1);
-
- if (pass == 2)
- {
- /* TREE_READONLY (fndecl) = 1;
- This caused &foo to be of type ptr-to-const-function which
- then got a warning when stored in a ptr-to-function variable. */
-
- BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
-
- /* Must mark the RESULT_DECL as being in this function. */
-
- DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
-
- if (fndecl != global_function_decl || seen_action)
- {
- /* Generate rtl for function exit. */
- expand_function_end (input_filename, lineno, 0);
-
- /* Run the optimizers and output assembler code for this function. */
- rest_of_compilation (fndecl);
- }
-
- if (DECL_SAVED_INSNS (fndecl) == 0 && ! nested)
- {
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this
- was an actual function definition. */
- /* For a nested function, this is done in pop_chill_function_context. */
- DECL_INITIAL (fndecl) = error_mark_node;
- DECL_ARGUMENTS (fndecl) = 0;
- }
- }
- current_function_decl = outer_function;
-}
-\f
-/* process SEIZE */
-
-/* Points to the head of the _DECLs read from seize files. */
-#if 0
-static tree seized_decls;
-
-static tree processed_seize_files = 0;
-#endif
-
-void
-chill_seize (old_prefix, new_prefix, postfix)
- tree old_prefix, new_prefix, postfix;
-{
- if (pass == 1)
- {
- tree decl = build_alias_decl (old_prefix, new_prefix, postfix);
- DECL_SEIZEFILE(decl) = use_seizefile_name;
- save_decl (decl);
- }
- else /* pass == 2 */
- {
- /* Do nothing - get_next_decl automatically ignores ALIAS_DECLs */
- }
-}
-#if 0
-\f
-/*
- * output a debug dump of a scope structure
- */
-void
-debug_scope (sp)
- struct scope *sp;
-{
- if (sp == (struct scope *)NULL)
- {
- fprintf (stderr, "null scope ptr\n");
- return;
- }
- fprintf (stderr, "enclosing 0x%x ", sp->enclosing);
- fprintf (stderr, "next 0x%x ", sp->next);
- fprintf (stderr, "remembered_decls 0x%x ", sp->remembered_decls);
- fprintf (stderr, "decls 0x%x\n", sp->decls);
- fprintf (stderr, "shadowed 0x%x ", sp->shadowed);
- fprintf (stderr, "blocks 0x%x ", sp->blocks);
- fprintf (stderr, "this_block 0x%x ", sp->this_block);
- fprintf (stderr, "level_chain 0x%x\n", sp->level_chain);
- fprintf (stderr, "module_flag %c ", sp->module_flag ? 'T' : 'F');
- fprintf (stderr, "first_child_module 0x%x ", sp->first_child_module);
- fprintf (stderr, "next_sibling_module 0x%x\n", sp->next_sibling_module);
- if (sp->remembered_decls != NULL_TREE)
- {
- tree temp;
- fprintf (stderr, "remembered_decl chain:\n");
- for (temp = sp->remembered_decls; temp; temp = TREE_CHAIN (temp))
- debug_tree (temp);
- }
-}
-#endif
-\f
-static void
-save_decl (decl)
- tree decl;
-{
- if (current_function_decl != global_function_decl)
- DECL_CONTEXT (decl) = current_function_decl;
-
- TREE_CHAIN (decl) = current_scope->remembered_decls;
- current_scope->remembered_decls = decl;
-#if 0
- fprintf (stderr, "\n\nsave_decl 0x%x\n", decl);
- debug_scope (current_scope); /* ************* */
-#endif
- set_nesting_level (decl, current_nesting_level);
-}
-
-static tree
-get_next_decl ()
-{
- tree decl;
- do
- {
- decl = current_scope->remembered_decls;
- current_scope->remembered_decls = TREE_CHAIN (decl);
- /* We ignore ALIAS_DECLs, because push_scope_decls
- can convert a single ALIAS_DECL representing 'SEIZE ALL'
- into one ALIAS_DECL for each seizeable name.
- This means we lose the nice one-to-one mapping
- between pass 1 decls and pass 2 decls.
- (Perhaps ALIAS_DECLs should not be on the remembered_decls list.) */
- } while (decl && TREE_CODE (decl) == ALIAS_DECL);
- return decl;
-}
-
-/* At the end of pass 1, we reverse the chronological chain of scopes. */
-
-void
-switch_to_pass_2 ()
-{
-#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;
-}
-\f
-/*
- * Called during pass 2, when we're processing actions, to
- * generate a temporary variable. These don't need satisfying
- * because they're compiler-generated and always declared
- * before they're used.
- */
-tree
-decl_temp1 (name, type, opt_static, opt_init,
- opt_external, opt_public)
- tree name, type;
- int opt_static;
- tree opt_init;
- int opt_external, opt_public;
-{
- int orig_pass = pass; /* be cautious */
- tree mydecl;
-
- pass = 1;
- mydecl = do_decl (name, type, opt_static, opt_static,
- opt_init, opt_external);
-
- if (opt_public)
- TREE_PUBLIC (mydecl) = 1;
- pass = 2;
- do_decl (name, type, opt_static, opt_static, opt_init, opt_external);
-
- pass = orig_pass;
- return mydecl;
-}
-\f
-/* True if we're reading a seizefile, but we haven't seen a SPEC MODULE yet.
- For backwards compatibility, we treat declarations in such a context
- as implicity granted. */
-
-tree
-set_module_name (name)
- tree name;
-{
- module_number++;
- if (name == NULL_TREE)
- {
- /* NOTE: build_prefix_clause assumes a generated
- module starts with a '_'. */
- char buf[20];
- sprintf (buf, "_MODULE_%d", module_number);
- name = get_identifier (buf);
- }
- return name;
-}
-
-tree
-push_module (name, is_spec_module)
- tree name;
- int is_spec_module;
-{
- struct module *new_module;
- if (pass == 1)
- {
- new_module = (struct module*) permalloc (sizeof (struct module));
- new_module->prev_module = current_module;
-
- *next_module = new_module;
- }
- else
- {
- new_module = *next_module;
- }
- next_module = &new_module->next_module;
-
- new_module->procedure_seen = 0;
- new_module->is_spec_module = is_spec_module;
- new_module->name = name;
- if (current_module)
- new_module->prefix_name
- = get_identifier3 (IDENTIFIER_POINTER (current_module->prefix_name),
- "__", IDENTIFIER_POINTER (name));
- else
- new_module->prefix_name = name;
-
- new_module->granted_decls = NULL_TREE;
- new_module->nesting_level = current_nesting_level + 1;
-
- current_module = new_module;
- current_module_nesting_level = new_module->nesting_level;
- in_pseudo_module = name ? 0 : 1;
-
- pushlevel (1);
-
- current_scope->module_flag = 1;
-
- *current_scope->enclosing->tail_child_module = current_scope;
- current_scope->enclosing->tail_child_module
- = ¤t_scope->next_sibling_module;
-
- /* Rename the global function to have the same name as
- the first named non-spec module. */
- if (!is_spec_module
- && IDENTIFIER_POINTER (name)[0] != '_'
- && IDENTIFIER_POINTER (DECL_NAME (global_function_decl))[0] == '_')
- {
- tree fname = get_identifier3 ("", IDENTIFIER_POINTER (name), "_");
- DECL_NAME (global_function_decl) = fname;
- DECL_ASSEMBLER_NAME (global_function_decl) = fname;
- }
-
- return name; /* may have generated a name */
-}
-/* Make a copy of the identifier NAME, replacing each '!' by '__'. */
-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;
-}
-\f
-void
-find_granted_decls ()
-{
- if (pass == 1)
- {
- /* Match each granted name to a granted decl. */
-
- tree alias = current_module->granted_decls;
- tree next_alias, decl;
- /* This is an O(M*N) algorithm. FIXME! */
- for (; alias; alias = next_alias)
- {
- int found = 0;
- next_alias = TREE_CHAIN (alias);
- for (decl = current_scope->remembered_decls;
- decl; decl = TREE_CHAIN (decl))
- {
- tree new_name = (! DECL_NAME (decl)) ? NULL_TREE :
- decl_check_rename (alias,
- DECL_NAME (decl));
-
- if (!new_name)
- continue;
- /* A Seized declaration is not grantable. */
- if (TREE_CODE (decl) == ALIAS_DECL && !CH_DECL_GRANTED (decl))
- continue;
- found = 1;
- if (global_bindings_p ())
- TREE_PUBLIC (decl) = 1;
- if (DECL_ASSEMBLER_NAME (decl) == NULL_TREE)
- DECL_ASSEMBLER_NAME (decl) = fix_identifier (new_name);
- if (DECL_POSTFIX_ALL (alias))
- {
- tree new_alias
- = build_alias_decl (NULL_TREE, NULL_TREE, new_name);
- TREE_CHAIN (new_alias) = TREE_CHAIN (alias);
- TREE_CHAIN (alias) = new_alias;
- DECL_ABSTRACT_ORIGIN (new_alias) = decl;
- DECL_SOURCE_LINE (new_alias) = 0;
- DECL_SEIZEFILE (new_alias) = DECL_SEIZEFILE (alias);
- }
- else
- {
- DECL_ABSTRACT_ORIGIN (alias) = decl;
- break;
- }
- }
- if (!found)
- {
- error_with_decl (alias, "nothing named `%s' to grant");
- DECL_ABSTRACT_ORIGIN (alias) = error_mark_node;
- }
- }
- }
-}
-
-void
-pop_module ()
-{
- tree decl;
- struct scope *module_scope = current_scope;
-
- poplevel (0, 0, 0);
-
- if (pass == 1)
- {
- /* Write out the grant file. */
- if (!current_module->is_spec_module)
- {
- /* After reversal, TREE_CHAIN (last_old_decl) is the oldest
- decl of the current module. */
- write_spec_module (module_scope->remembered_decls,
- current_module->granted_decls);
- }
-
- /* Move the granted decls into the enclosing scope. */
- if (current_scope == global_scope)
- {
- tree next_decl;
- for (decl = current_module->granted_decls; decl; decl = next_decl)
- {
- tree name = DECL_NAME (decl);
- next_decl = TREE_CHAIN (decl);
- if (name != NULL_TREE)
- {
- tree old_decl = IDENTIFIER_OUTER_VALUE (name);
- set_nesting_level (decl, current_nesting_level);
- if (old_decl != NULL_TREE)
- {
- pedwarn_with_decl (decl, "duplicate grant for `%s'");
- pedwarn_with_decl (old_decl, "previous grant for `%s'");
- TREE_CHAIN (decl) = TREE_CHAIN (old_decl);
- TREE_CHAIN (old_decl) = decl;
- }
- else
- {
- TREE_CHAIN (decl) = outer_decls;
- outer_decls = decl;
- IDENTIFIER_OUTER_VALUE (name) = decl;
- }
- }
- }
- }
- else
- current_scope->granted_decls = chainon (current_module->granted_decls,
- current_scope->granted_decls);
- }
-
- chill_check_no_handlers (); /* Sanity test */
- current_module = current_module->prev_module;
- current_module_nesting_level = current_module ?
- current_module->nesting_level : 0;
- in_pseudo_module = 0;
-}
-\f
-/* Nonzero if we are currently in the global binding level. */
-
-int
-global_bindings_p ()
-{
- /* We return -1 here for the sake of variable_size() in ../stor-layout.c. */
- return (current_function_decl == NULL_TREE
- || current_function_decl == global_function_decl) ? -1 : 0;
-}
-
-/* Nonzero if the current level needs to have a BLOCK made. */
-
-int
-kept_level_p ()
-{
- return current_scope->decls != 0;
-}
-
-/* Make DECL visible.
- Save any existing definition.
- Check redefinitions at the same level.
- Suppress error messages if QUIET is true. */
-
-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));
-\f
-/* Look for implied types (enumeral types) implied by TYPE (a decl or type).
- Add these to list.
- Use old_path to guard against cycles. */
-
-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;
- }
-}
-\f
-/* Make declarations in current scope visible.
- Also, expand SEIZEs, and make correspondong ALIAS_DECLs visible. */
-
-static void
-push_scope_decls (quiet)
- int quiet; /* If 1, we're pre-scanning, so suppress errors. */
-{
- tree decl;
-
- /* First make everything except 'SEIZE ALL' names visible, before
- handling 'SEIZE ALL'. (This makes it easier to check 'seizable'). */
- for (decl = current_scope->remembered_decls; decl; decl = TREE_CHAIN (decl))
- {
- if (TREE_CODE (decl) == ALIAS_DECL)
- {
- if (DECL_POSTFIX_ALL (decl))
- continue;
- if (DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE)
- {
- tree val = lookup_name_for_seizing (decl);
- if (val == NULL_TREE)
- {
- error_with_file_and_line
- (DECL_SOURCE_FILE (decl), DECL_SOURCE_LINE (decl),
- "cannot SEIZE `%s'",
- IDENTIFIER_POINTER (DECL_OLD_NAME (decl)));
- val = error_mark_node;
- }
- DECL_ABSTRACT_ORIGIN (decl) = val;
- }
- }
- proclaim_decl (decl, quiet);
- }
-
- pushdecllist (current_scope->granted_decls, quiet);
-
- /* Now handle SEIZE ALLs. */
- for (decl = current_scope->remembered_decls; decl; )
- {
- tree next_decl = TREE_CHAIN (decl);
- if (TREE_CODE (decl) == ALIAS_DECL
- && DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE
- && DECL_POSTFIX_ALL (decl))
- {
- /* We saw a "SEIZE ALL". Replace it be a SEIZE for each
- declaration visible in the surrounding scope.
- Note that this complicates get_next_decl(). */
- tree candidate;
- tree last_new_alias = decl;
- DECL_ABSTRACT_ORIGIN (decl) = error_mark_node;
- if (current_scope->enclosing == global_scope)
- candidate = outer_decls;
- else
- candidate = current_scope->enclosing->decls;
- for ( ; candidate; candidate = TREE_CHAIN (candidate))
- {
- tree seizename = DECL_NAME (candidate);
- tree new_name;
- tree new_alias;
- if (!seizename)
- continue;
- new_name = decl_check_rename (decl, seizename);
- if (!new_name)
- continue;
-
- /* Check if candidate is seizable. */
- if (lookup_name (new_name) != NULL_TREE)
- continue;
-
- new_alias = build_alias_decl (NULL_TREE,NULL_TREE, new_name);
- TREE_CHAIN (new_alias) = TREE_CHAIN (last_new_alias);
- TREE_CHAIN (last_new_alias) = new_alias;
- last_new_alias = new_alias;
- DECL_ABSTRACT_ORIGIN (new_alias) = candidate;
- DECL_SOURCE_LINE (new_alias) = 0;
-
- proclaim_decl (new_alias, quiet);
- }
- }
- decl = next_decl;
- }
-
- /* Link current_scope->remembered_decls at the head of the
- current_scope->decls list (just like pushdecllist, but
- without calling proclaim_decl, since we've already done that). */
- if ((decl = current_scope->remembered_decls) != NULL_TREE)
- {
- while (TREE_CHAIN (decl) != NULL_TREE)
- decl = TREE_CHAIN (decl);
- TREE_CHAIN (decl) = current_scope->decls;
- current_scope->decls = current_scope->remembered_decls;
- }
-}
-
-static void
-pop_scope_decls (decls_limit, shadowed_limit)
- tree decls_limit, shadowed_limit;
-{
- /* Remove the temporary bindings we made. */
- tree link = current_scope->shadowed;
- tree decl = current_scope->decls;
- if (decl != decls_limit)
- {
- while (decl != decls_limit)
- {
- tree next = TREE_CHAIN (decl);
- if (DECL_NAME (decl))
- {
- /* If the ident. was used or addressed via a local extern decl,
- don't forget that fact. */
- if (DECL_EXTERNAL (decl))
- {
- if (TREE_USED (decl))
- TREE_USED (DECL_NAME (decl)) = 1;
- if (TREE_ADDRESSABLE (decl))
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (decl)) = 1;
- }
- IDENTIFIER_LOCAL_VALUE (DECL_NAME (decl)) = 0;
- }
- if (next == decls_limit)
- {
- TREE_CHAIN (decl) = NULL_TREE;
- break;
- }
- decl = next;
- }
- current_scope->decls = decls_limit;
- }
-
- /* Restore all name-meanings of the outer levels
- that were shadowed by this level. */
- for ( ; link != shadowed_limit; link = TREE_CHAIN (link))
- IDENTIFIER_LOCAL_VALUE (TREE_PURPOSE (link)) = TREE_VALUE (link);
- current_scope->shadowed = shadowed_limit;
-}
-
-/* Return list of weak names (as ALIAS_DECLs) implied by IMPLIED_TYPES. */
-
-static tree
-build_implied_names (implied_types)
- tree implied_types;
-{
- tree aliases = NULL_TREE;
-
- for ( ; implied_types; implied_types = TREE_CHAIN (implied_types))
- {
- tree enum_type = TREE_VALUE (implied_types);
- tree link = TYPE_VALUES (enum_type);
- if (TREE_CODE (enum_type) != ENUMERAL_TYPE)
- abort ();
-
- for ( ; link; link = TREE_CHAIN (link))
- {
- /* We don't handle renaming/prefixes (Blue Book p 163) FIXME */
- /* Note that before enum_type is laid out, TREE_VALUE (link)
- is a CONST_DECL, while after it is laid out,
- TREE_VALUE (link) is an INTEGER_CST. Either works. */
- tree alias
- = build_alias_decl (NULL_TREE, NULL_TREE, TREE_PURPOSE (link));
- DECL_ABSTRACT_ORIGIN (alias) = TREE_VALUE (link);
- DECL_WEAK_NAME (alias) = 1;
- TREE_CHAIN (alias) = aliases;
- aliases = alias;
- /* Strictlt speaking, we should have a pointer from the alias
- to the decl, so we can make sure that the alias is only
- visible when the decl is. FIXME */
- }
- }
- return aliases;
-}
-
-static void
-bind_sub_modules (do_weak)
- int do_weak;
-{
- tree decl;
- int save_module_nesting_level = current_module_nesting_level;
- struct scope *saved_scope = current_scope;
- struct scope *nested_module = current_scope->first_child_module;
-
- while (nested_module != NULL)
- {
- tree saved_shadowed = nested_module->shadowed;
- tree saved_decls = nested_module->decls;
- current_nesting_level++;
- current_scope = nested_module;
- current_module_nesting_level = current_nesting_level;
- if (do_weak == 0)
- push_scope_decls (1);
- else
- {
- tree implied_types = NULL_TREE;
- /* Push weak names implied by decls in current_scope. */
- for (decl = current_scope->remembered_decls;
- decl; decl = TREE_CHAIN (decl))
- if (TREE_CODE (decl) == ALIAS_DECL)
- implied_types = find_implied_types (decl, NULL, implied_types);
- for (decl = current_scope->granted_decls;
- decl; decl = TREE_CHAIN (decl))
- implied_types = find_implied_types (decl, NULL, implied_types);
- current_scope->weak_decls = build_implied_names (implied_types);
- pushdecllist (current_scope->weak_decls, 1);
- }
-
- bind_sub_modules (do_weak);
- for (decl = current_scope->remembered_decls;
- decl; decl = TREE_CHAIN (decl))
- satisfy_decl (decl, 1);
- pop_scope_decls (saved_decls, saved_shadowed);
- current_nesting_level--;
- nested_module = nested_module->next_sibling_module;
- }
-
- current_scope = saved_scope;
- current_module_nesting_level = save_module_nesting_level;
-}
-\f
-/* Enter a new binding level.
- If two_pass==0, assume we are called from non-Chill-specific parts
- of the compiler. These parts assume a single pass.
- If two_pass==1, we're called from Chill parts of the compiler.
-*/
-
-void
-pushlevel (two_pass)
- int two_pass;
-{
- register struct scope *newlevel;
-
- current_nesting_level++;
- if (!two_pass)
- {
- newlevel = (struct scope *)xmalloc (sizeof(struct scope));
- *newlevel = clear_scope;
- newlevel->enclosing = current_scope;
- current_scope = newlevel;
- }
- else if (pass < 2)
- {
- newlevel = (struct scope *)permalloc (sizeof(struct scope));
- *newlevel = clear_scope;
- newlevel->tail_child_module = &newlevel->first_child_module;
- newlevel->enclosing = current_scope;
- current_scope = newlevel;
- last_scope->next = newlevel;
- last_scope = newlevel;
- }
- else /* pass == 2 */
- {
- tree decl;
- newlevel = current_scope = last_scope = last_scope->next;
-
- push_scope_decls (0);
- pushdecllist (current_scope->weak_decls, 0);
-
- /* If this is not a module scope, scan ahead for locally nested
- modules. (If this is a module, that's already done.) */
- if (!current_scope->module_flag)
- {
- bind_sub_modules (0);
- bind_sub_modules (1);
- }
-
- for (decl = current_scope->remembered_decls;
- decl; decl = TREE_CHAIN (decl))
- satisfy_decl (decl, 0);
- }
-
- /* Add this level to the front of the chain (stack) of levels that
- are active. */
-
- newlevel->level_chain = current_scope;
- current_scope = newlevel;
-
- newlevel->two_pass = two_pass;
-}
-\f
-/* Exit a binding level.
- Pop the level off, and restore the state of the identifier-decl mappings
- that were in effect when this level was entered.
-
- If KEEP is nonzero, this level had explicit declarations, so
- and create a "block" (a BLOCK node) for the level
- to record its declarations and subblocks for symbol table output.
-
- If FUNCTIONBODY is nonzero, this level is the body of a function,
- so create a block as if KEEP were set and also clear out all
- label names.
-
- If REVERSE is nonzero, reverse the order of decls before putting
- them into the BLOCK. */
-
-tree
-poplevel (keep, reverse, functionbody)
- int keep;
- int reverse;
- int functionbody;
-{
- register tree link;
- /* The chain of decls was accumulated in reverse order.
- Put it into forward order, just for cleanliness. */
- tree decls;
- tree subblocks;
- tree block = 0;
- tree decl;
- int block_previously_created = 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;
-}
-\f
-/* Delete the node BLOCK from the current binding level.
- This is used for the block inside a stmt expr ({...})
- so that the block can be reinserted where appropriate. */
-
-void
-delete_block (block)
- tree block;
-{
- tree t;
- if (current_scope->blocks == block)
- current_scope->blocks = TREE_CHAIN (block);
- for (t = current_scope->blocks; t;)
- {
- if (TREE_CHAIN (t) == block)
- TREE_CHAIN (t) = TREE_CHAIN (block);
- else
- t = TREE_CHAIN (t);
- }
- TREE_CHAIN (block) = NULL;
- /* Clear TREE_USED which is always set by poplevel.
- The flag is set again if insert_block is called. */
- TREE_USED (block) = 0;
-}
-
-/* Insert BLOCK at the end of the list of subblocks of the
- current binding level. This is used when a BIND_EXPR is expanded,
- to handle the BLOCK node inside teh BIND_EXPR. */
-
-void
-insert_block (block)
- tree block;
-{
- TREE_USED (block) = 1;
- current_scope->blocks
- = chainon (current_scope->blocks, block);
-}
-
-/* Set the BLOCK node for the innermost scope
- (the one we are currently in). */
-
-void
-set_block (block)
- register tree block;
-{
- current_scope->this_block = block;
- current_scope->decls = chainon (current_scope->decls, BLOCK_VARS (block));
- current_scope->blocks = chainon (current_scope->blocks,
- BLOCK_SUBBLOCKS (block));
-}
-\f
-/* Record a decl-node X as belonging to the current lexical scope.
- Check for errors (such as an incompatible declaration for the same
- name already seen in the same scope).
-
- Returns either X or an old decl for the same name.
- If an old decl is returned, it may have been smashed
- to agree with what X says. */
-
-tree
-pushdecl (x)
- tree x;
-{
- register tree name = DECL_NAME (x);
- register struct scope *b = current_scope;
-
- DECL_CONTEXT (x) = current_function_decl;
- /* A local extern declaration for a function doesn't constitute nesting.
- A local auto declaration does, since it's a forward decl
- for a nested function coming later. */
- if (TREE_CODE (x) == FUNCTION_DECL && DECL_INITIAL (x) == 0
- && DECL_EXTERNAL (x))
- DECL_CONTEXT (x) = 0;
-
- if (name)
- proclaim_decl (x, 0);
-
- if (TREE_CODE (x) == TYPE_DECL && DECL_SOURCE_LINE (x) == 0
- && TYPE_NAME (TREE_TYPE (x)) == 0)
- TYPE_NAME (TREE_TYPE (x)) = x;
-
- /* Put decls on list in reverse order.
- We will reverse them later if necessary. */
- TREE_CHAIN (x) = b->decls;
- b->decls = x;
-
- return x;
-}
-\f
-/* Make DECLS (a chain of decls) visible in the current_scope. */
-
-static void
-pushdecllist (decls, quiet)
- tree decls;
- int quiet;
-{
- tree last = NULL_TREE, decl;
-
- for (decl = decls; decl != NULL_TREE;
- last = decl, decl = TREE_CHAIN (decl))
- {
- proclaim_decl (decl, quiet);
- }
-
- if (last)
- {
- TREE_CHAIN (last) = current_scope->decls;
- current_scope->decls = decls;
- }
-}
-
-/* Like pushdecl, only it places X in GLOBAL_SCOPE, if appropriate. */
-
-tree
-pushdecl_top_level (x)
- tree x;
-{
- register tree t;
- register struct scope *b = current_scope;
-
- current_scope = global_scope;
- t = pushdecl (x);
- current_scope = b;
- return t;
-}
-\f
-/* Define a label, specifying the location in the source file.
- Return the LABEL_DECL node for the label, if the definition is valid.
- Otherwise return 0. */
-
-tree
-define_label (filename, line, name)
- 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;
-}
-\f
-/* Return the list of declarations of the current level.
- Note that this list is in reverse order unless/until
- you nreverse it; and when you do nreverse it, you must
- store the result back using `storedecls' or you will lose. */
-
-tree
-getdecls ()
-{
- /* This is a kludge, so that dbxout_init can get the predefined types,
- which are in the builtin_scope, though when it is called,
- the current_scope is the global_scope.. */
- if (current_scope == global_scope)
- return builtin_scope.decls;
- return current_scope->decls;
-}
-
-#if 0
-/* Store the list of declarations of the current level.
- This is done for the parameter declarations of a function being defined,
- after they are modified in the light of any missing parameters. */
-
-static void
-storedecls (decls)
- tree decls;
-{
- current_scope->decls = decls;
-}
-#endif
-\f
-/* Look up NAME in the current binding level and its superiors
- in the namespace of variables, functions and typedefs.
- Return a ..._DECL node of some kind representing its definition,
- or return 0 if it is undefined. */
-
-tree
-lookup_name (name)
- tree name;
-{
- register tree val = IDENTIFIER_LOCAL_VALUE (name);
-
- if (val == NULL_TREE)
- return NULL_TREE;
- if (TREE_CODE_CLASS (TREE_CODE (val)) == 'c')
- return val;
- if (DECL_NESTING_LEVEL (val) > BUILTIN_NESTING_LEVEL
- && DECL_NESTING_LEVEL (val) < current_module_nesting_level)
- {
- return NULL_TREE;
- }
- while (TREE_CODE (val) == ALIAS_DECL)
- {
- val = DECL_ABSTRACT_ORIGIN (val);
- if (TREE_CODE (val) == ERROR_MARK)
- return NULL_TREE;
- }
- if (TREE_CODE (val) == BASED_DECL)
- {
- return build_chill_indirect_ref (DECL_ABSTRACT_ORIGIN (val),
- TREE_TYPE (val), 1);
- }
- if (TREE_CODE (val) == WITH_DECL)
- return build_component_ref (DECL_ABSTRACT_ORIGIN (val), DECL_NAME (val));
- return val;
-}
-
-#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;
-}
-\f
-/* Create the predefined scalar types of C,
- and some nodes representing standard constants (0, 1, (void *)0).
- Initialize the global binding level.
- Make definitions for built-in primitive functions. */
-
-void
-init_decl_processing ()
-{
- int wchar_type_size;
- tree bool_ftype_int_ptr_int;
- tree bool_ftype_int_ptr_int_int;
- tree bool_ftype_luns_ptr_luns_long;
- tree bool_ftype_luns_ptr_luns_long_ptr_int;
- tree bool_ftype_ptr_int_ptr_int;
- tree bool_ftype_ptr_int_ptr_int_int;
- tree find_bit_ftype;
- tree bool_ftype_ptr_ptr_int;
- tree bool_ftype_ptr_ptr_luns;
- tree bool_ftype_ptr_ptr_ptr_luns;
- tree endlink;
- tree int_ftype_int;
- tree int_ftype_int_int;
- tree int_ftype_int_ptr_int;
- tree int_ftype_ptr;
- tree int_ftype_ptr_int;
- tree int_ftype_ptr_int_int_ptr_int;
- tree int_ftype_ptr_luns_long_ptr_int;
- tree int_ftype_ptr_ptr_int;
- tree int_ftype_ptr_ptr_luns;
- tree long_ftype_ptr_luns;
- tree memcpy_ftype;
- tree memcmp_ftype;
- tree ptr_ftype_ptr_int_int;
- tree ptr_ftype_ptr_ptr_int;
- tree ptr_ftype_ptr_ptr_int_ptr_int;
- tree real_ftype_real;
- tree temp;
- tree void_ftype_cptr_cptr_int;
- tree void_ftype_long_int_ptr_int_ptr_int;
- tree void_ftype_ptr;
- tree void_ftype_ptr_int_int_int_int;
- tree void_ftype_ptr_int_ptr_int_int_int;
- tree void_ftype_ptr_int_ptr_int_ptr_int;
- tree void_ftype_ptr_luns_long_long_bool_ptr_int;
- tree void_ftype_ptr_luns_ptr_luns_luns_luns;
- tree void_ftype_ptr_ptr_ptr_int;
- tree void_ftype_ptr_ptr_ptr_luns;
- tree void_ftype_refptr_int_ptr_int;
- tree void_ftype_void;
- tree void_ftype_ptr_ptr_int;
- tree void_ftype_ptr_luns_luns_cptr_luns_luns_luns;
- tree ptr_ftype_luns_ptr_int;
- tree double_ftype_double;
-
- /* 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);
-
- 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;
-}
-\f
-/* Return a definition for a builtin function named NAME and whose data type
- is TYPE. TYPE should be a function type with argument types.
- FUNCTION_CODE tells later passes how to compile calls to this function.
- See tree.h for its possible values.
-
- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
- the name to be called if we can't opencode the function. */
-
-tree
-builtin_function (name, type, function_code, 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 (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;
-}
-\f
-/* Print a warning if a constant expression had overflow in folding.
- Invoke this function on every expression that the language
- requires to be a constant expression. */
-
-void
-constant_expression_warning (value)
- tree value;
-{
- if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
- || TREE_CODE (value) == COMPLEX_CST)
- && TREE_CONSTANT_OVERFLOW (value) && pedantic)
- pedwarn ("overflow in constant expression");
-}
-
-\f
-/* Finish processing of a declaration;
- If the length of an array type is not known before,
- it must be determined now, from the initial value, or it is an error. */
-
-void
-finish_decl (decl)
- tree decl;
-{
- 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;
-}
-\f
-/* Make TYPE a complete type based on INITIAL_VALUE.
- Return 0 if successful, 1 if INITIAL_VALUE can't be deciphered,
- 2 if there was no information (in which case assume 1 if DO_DEFAULT). */
-
-int
-complete_array_type (type, initial_value, do_default)
- tree type ATTRIBUTE_UNUSED, initial_value ATTRIBUTE_UNUSED;
- int do_default ATTRIBUTE_UNUSED;
-{
- /* Only needed so we can link with ../c-typeck.c. */
- abort ();
-}
-\f
-/* Make sure that the tag NAME is defined *in the current binding level*
- at least as a forward reference.
- CODE says which kind of tag NAME ought to be.
-
- We also do a push_obstacks_nochange
- whose matching pop is in finish_struct. */
-
-tree
-start_struct (code, name)
- enum chill_tree_code code;
- tree name 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;
-}
-\f
-#if 0
-/* Function to help qsort sort FIELD_DECLs by name order. */
-
-static int
-field_decl_cmp (x, y)
- tree *x, *y;
-{
- return (long)DECL_NAME (*x) - (long)DECL_NAME (*y);
-}
-#endif
-/* Fill in the fields of a RECORD_TYPE or UNION_TYPE node, T.
- FIELDLIST is a chain of FIELD_DECL nodes for the fields.
-
- We also do a pop_obstacks to match the push in start_struct. */
-
-tree
-finish_struct (t, fieldlist)
- register tree t, fieldlist;
-{
- register tree x;
-
- /* Install struct as DECL_CONTEXT of each field decl. */
- 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);
-}
-\f
-/* Begin compiling the definition of an enumeration type.
- NAME is its name (or null if anonymous).
- Returns the type object, as yet incomplete.
- Also records info about it so that build_enumerator
- may be used to declare the individual values as they are read. */
-
-tree
-start_enum (name)
- tree name 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;
-}
-\f
-/* Determine the precision this type needs. */
-unsigned
-get_type_precision (minnode, maxnode)
- tree minnode, maxnode;
-{
- unsigned precision = 0;
-
- if (TREE_INT_CST_HIGH (minnode) >= 0
- ? tree_int_cst_lt (TYPE_MAX_VALUE (unsigned_type_node), maxnode)
- : (tree_int_cst_lt (minnode, TYPE_MIN_VALUE (integer_type_node))
- || tree_int_cst_lt (TYPE_MAX_VALUE (integer_type_node), maxnode)))
- precision = TYPE_PRECISION (long_long_integer_type_node);
- else
- {
- HOST_WIDE_INT maxvalue = TREE_INT_CST_LOW (maxnode);
- HOST_WIDE_INT minvalue = TREE_INT_CST_LOW (minnode);
-
- if (maxvalue > 0)
- precision = floor_log2 (maxvalue) + 1;
- if (minvalue < 0)
- {
- /* Compute number of bits to represent magnitude of a negative value.
- Add one to MINVALUE since range of negative numbers
- includes the power of two. */
- unsigned negprecision = floor_log2 (-minvalue - 1) + 1;
- if (negprecision > precision)
- precision = negprecision;
- precision += 1; /* room for sign bit */
- }
-
- if (!precision)
- precision = 1;
- }
- return precision;
-}
-\f
-void
-layout_enum (enumtype)
- tree enumtype;
-{
- register tree pair, tem;
- tree minnode = 0, maxnode = 0;
- unsigned precision = 0;
-
- /* Do arithmetic using double integers, but don't use fold/build. */
- union tree_node enum_next_node;
- /* This is 1 plus the last enumerator constant value. */
- tree enum_next_value = &enum_next_node;
-
- /* Nonzero means that there was overflow computing enum_next_value. */
- int enum_overflow = 0;
-
- tree values = TYPE_VALUES (enumtype);
-
- if (TYPE_SIZE (enumtype) != NULL_TREE)
- return;
-
- /* Initialize enum_next_value to zero. */
- TREE_TYPE (enum_next_value) = integer_type_node;
- TREE_INT_CST_LOW (enum_next_value) = TREE_INT_CST_LOW (integer_zero_node);
- TREE_INT_CST_HIGH (enum_next_value) = TREE_INT_CST_HIGH (integer_zero_node);
-
- /* After processing and defining all the values of an enumeration type,
- install their decls in the enumeration type and finish it off.
-
- TYPE_VALUES currently contains a list of (purpose: NAME, value: DECL).
- This gets converted to a list of (purpose: NAME, value: VALUE). */
-
-
- /* For each enumerator, calculate values, if defaulted.
- Convert to correct type (the enumtype).
- Also, calculate the minimum and maximum values. */
-
- for (pair = values; pair; pair = TREE_CHAIN (pair))
- {
- tree decl = TREE_VALUE (pair);
- tree value = DECL_INITIAL (decl);
-
- /* Remove no-op casts from the value. */
- if (value != NULL_TREE)
- STRIP_TYPE_NOPS (value);
-
- if (value != NULL_TREE)
- {
- if (TREE_CODE (value) == INTEGER_CST)
- {
- constant_expression_warning (value);
- if (tree_int_cst_lt (value, integer_zero_node))
- {
- error ("enumerator value for `%s' is less than 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 necessary 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
-}
-\f
-tree
-finish_enum (enumtype, values)
- register tree enumtype, values;
-{
- TYPE_VALUES (enumtype) = values = nreverse (values);
-
- /* If satisfy_decl is called on one of the enum CONST_DECLs,
- this will make sure that the enumtype gets laid out then. */
- for ( ; values; values = TREE_CHAIN (values))
- TREE_TYPE (TREE_VALUE (values)) = enumtype;
-
- return enumtype;
-}
-
-
-/* Build and install a CONST_DECL for one value of the
- current enumeration type (one that was begun with start_enum).
- Return a tree-list containing the CONST_DECL and its value.
- Assignment of sequential values by default is handled here. */
-
-tree
-build_enumerator (name, value)
- tree name, value;
-{
- register tree decl;
- int named = name != NULL_TREE;
-
- if (pass == 2)
- {
- if (name)
- (void) get_next_decl ();
- return NULL_TREE;
- }
-
- if (name == NULL_TREE)
- {
- static int unnamed_value_warned = 0;
- static int next_dummy_enum_value = 0;
- char buf[20];
- if (!unnamed_value_warned)
- {
- unnamed_value_warned = 1;
- warning ("undefined value in SET mode is obsolete and deprecated");
- }
- sprintf (buf, "__star_%d", next_dummy_enum_value++);
- name = get_identifier (buf);
- }
-
- decl = build_decl (CONST_DECL, name, integer_type_node);
- CH_DECL_ENUM (decl) = 1;
- DECL_INITIAL (decl) = value;
- if (named)
- {
- if (pass == 0)
- {
- push_obstacks_nochange ();
- pushdecl (decl);
- finish_decl (decl);
- }
- else
- save_decl (decl);
- }
- return build_tree_list (name, decl);
-
-#if 0
- tree old_value = lookup_name_current_level (name);
-
- if (old_value != NULL_TREE
- && TREE_CODE (old_value)=!= CONST_DECL
- && (value == NULL_TREE || operand_equal_p (value, old_value, 1)))
- {
- if (value == NULL_TREE)
- {
- if (TREE_CODE (old_value) == CONST_DECL)
- value = DECL_INITIAL (old_value);
- else
- abort ();
- }
- return saveable_tree_cons (old_value, value, NULL_TREE);
- }
-#endif
-}
-\f
-/* Record that this function is going to be a varargs function.
- This is called before store_parm_decls, which is too early
- to call mark_varargs directly. */
-
-void
-c_mark_varargs ()
-{
- c_function_varargs = 1;
-}
-\f
-/* Function needed for CHILL interface. */
-tree
-get_parm_decls ()
-{
- return current_function_parms;
-}
-\f
-/* Save and restore the variables in this file and elsewhere
- that keep track of the progress of compilation of the current function.
- Used for nested functions. */
-
-struct c_function
-{
- struct c_function *next;
- struct scope *scope;
- tree chill_result_decl;
- int result_never_set;
-};
-
-struct c_function *c_function_chain;
-
-/* Save and reinitialize the variables
- used during compilation of a C function. */
-
-void
-push_chill_function_context ()
-{
- struct c_function *p
- = (struct c_function *) xmalloc (sizeof (struct c_function));
-
- push_function_context ();
-
- p->next = c_function_chain;
- c_function_chain = p;
-
- p->scope = current_scope;
- p->chill_result_decl = chill_result_decl;
- p->result_never_set = result_never_set;
-}
-
-/* Restore the variables used during compilation of a C function. */
-
-void
-pop_chill_function_context ()
-{
- struct c_function *p = c_function_chain;
-#if 0
- tree link;
- /* Bring back all the labels that were shadowed. */
- for (link = shadowed_labels; link; link = TREE_CHAIN (link))
- if (DECL_NAME (TREE_VALUE (link)) != 0)
- IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
- = TREE_VALUE (link);
-#endif
-
- pop_function_context ();
-
- c_function_chain = p->next;
-
- current_scope = p->scope;
- chill_result_decl = p->chill_result_decl;
- result_never_set = p->result_never_set;
-
- free (p);
-}
-\f
-/* Following from Jukka Virtanen's GNU Pascal */
-/* To implement WITH statement:
-
- 1) Call shadow_record_fields for each record_type element in the WITH
- element list. Each call creates a new binding level.
-
- 2) construct a component_ref for EACH field in the record,
- and store it to the IDENTIFIER_LOCAL_VALUE after adding
- the old value to the shadow list
-
- 3) let lookup_name do the rest
-
- 4) pop all of the binding levels after the WITH statement ends.
- (restoring old local values) You have to keep track of the number
- of times you called it.
-*/
-\f
-/*
- * Save an arbitrary tree-expression as the IDENTIFIER_LOCAL_VALUE
- * of a name. Save the name's previous value. Check for name
- * collisions with another value under the same name at the same
- * nesting level. This is used to implement the DO WITH construct
- * and the temporary for the location iteration loop.
- */
-void
-save_expr_under_name (name, expr)
- tree name, expr;
-{
- tree alias = build_alias_decl (NULL_TREE, NULL_TREE, name);
-
- DECL_ABSTRACT_ORIGIN (alias) = expr;
- TREE_CHAIN (alias) = NULL_TREE;
- pushdecllist (alias, 0);
-}
-
-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");
- }
-}
-\f
-/*
- * For each FIELD_DECL node in a RECORD_TYPE, we have to declare
- * a name so that lookup_name will find a COMPONENT_REF node
- * when the name is referenced. This happens in Pascal WITH statement.
- */
-void
-shadow_record_fields (struct_val)
- tree struct_val;
-{
- if (pass == 1 || struct_val == NULL_TREE)
- return;
-
- handle_one_level (struct_val, TYPE_FIELDS (TREE_TYPE (struct_val)));
-}
-\f
-static char exception_prefix [] = "__Ex_";
-
-tree
-build_chill_exception_decl (name)
- 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;
-}
-\f
-/* This function finishes the global_function_decl, and if it is non-empty
- * (as indiacted by seen_action), adds it to module_init_list.
- */
-void
-finish_outer_function ()
-{
- /* If there was module-level code in this module (not just function
- declarations), we allocate space for this module's init list entry,
- and fill in the module's function's address. */
-
- extern tree initializer_type;
- 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);
-}
+++ /dev/null
-/* 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 associated 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;
-\f
-#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);
-}
+++ /dev/null
-/* 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;
-
-\f
-/* called from ch-lex.l */
-void
-init_chill_expand ()
-{
- lang_expand_expr = chill_expand_expr;
-}
-
-/* Take the address of something that needs to be passed by reference. */
-tree
-force_addr_of (value)
- tree value;
-{
- /* FIXME. Move to memory, if needed. */
- if (TREE_CODE (value) == INDIRECT_REF)
- return convert_to_pointer (ptr_type_node, TREE_OPERAND (value, 0));
- mark_addressable (value);
- return build1 (ADDR_EXPR, ptr_type_node, value);
-}
-
-/* Check that EXP has a known type. */
-
-tree
-check_have_mode (exp, context)
- tree exp;
- 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;
-}
-\f
-/* 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;
- }
-\f
- /* FIXME: the set_length computed below is a compile-time constant;
- you'll need to re-write that part for VARYING bit arrays, and
- possibly the set pointer will need to be adjusted to point past
- the word containing its dynamic length. */
-
- /* void __notpowerset (char *out, char *src,
- unsigned long bitlength) */
- case SET_NOT_EXPR:
- {
-
- tree expr = TREE_OPERAND (exp, 0);
- tree tsize = powersetlen (expr);
- rtx targetx;
-
- if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE)
- tsize = fold (build (MULT_EXPR, sizetype, tsize,
- size_int (BITS_PER_UNIT)));
-
- /* expand 1st operand to a pointer to the set */
- op0 = expand_expr (force_addr_of (expr),
- NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
-
- /* build a temp for the result, target is its address */
- if (target == NULL_RTX)
- {
- target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)),
- int_size_in_bytes (TREE_TYPE (exp)),
- 0);
- preserve_temp_slots (target);
- }
- if (GET_CODE (target) == MEM)
- targetx = target;
- else
- targetx = assign_stack_temp (GET_MODE (target),
- GET_MODE_SIZE (GET_MODE (target)),
- 0);
- emit_library_call (gen_rtx(SYMBOL_REF, Pmode, "__notpowerset"),
- 0, VOIDmode, 3, XEXP (targetx, 0), Pmode,
- op0, GET_MODE (op0),
- expand_expr (tsize, NULL_RTX, MEM,
- EXPAND_CONST_ADDRESS),
- TYPE_MODE (long_unsigned_type_node));
- if (targetx != target)
- emit_move_insn (target, targetx);
- return target;
- }
-
- case SET_DIFF_EXPR:
- lib_func = "__diffpowerset";
- goto format_2;
-
- case SET_IOR_EXPR:
- lib_func = "__orpowerset";
- goto format_2;
-
- case SET_XOR_EXPR:
- lib_func = "__xorpowerset";
- goto format_2;
-
- /* void __diffpowerset (char *out, char *left, char *right,
- unsigned bitlength) */
- case SET_AND_EXPR:
- lib_func = "__andpowerset";
- format_2:
- {
- tree expr = TREE_OPERAND (exp, 0);
- tree tsize = powersetlen (expr);
- rtx targetx;
-
- if (TREE_CODE (TREE_TYPE (expr)) != SET_TYPE)
- tsize = fold (build (MULT_EXPR, long_unsigned_type_node,
- tsize,
- size_int (BITS_PER_UNIT)));
-
- /* expand 1st operand to a pointer to the set */
- op0 = expand_expr (force_addr_of (expr),
- NULL_RTX, MEM, EXPAND_CONST_ADDRESS);
-
- /* expand 2nd operand to a pointer to the set */
- op1 = expand_expr (force_addr_of (TREE_OPERAND (exp, 1)),
- NULL_RTX, MEM,
- EXPAND_CONST_ADDRESS);
-
-/* FIXME: re-examine this code - the unary operator code above has recently
- (93/03/12) been changed a lot. Should this code also change? */
- /* build a temp for the result, target is its address */
- if (target == NULL_RTX)
- {
- target = assign_stack_temp (TYPE_MODE (TREE_TYPE (exp)),
- int_size_in_bytes (TREE_TYPE (exp)),
- 0);
- preserve_temp_slots (target);
- }
- if (GET_CODE (target) == MEM)
- targetx = target;
- else
- targetx = assign_stack_temp (GET_MODE (target),
- GET_MODE_SIZE (GET_MODE (target)), 0);
- emit_library_call (gen_rtx(SYMBOL_REF, Pmode, lib_func),
- 0, VOIDmode, 4, XEXP (targetx, 0), Pmode,
- op0, GET_MODE (op0), op1, GET_MODE (op1),
- expand_expr (tsize, NULL_RTX, MEM,
- EXPAND_CONST_ADDRESS),
- TYPE_MODE (long_unsigned_type_node));
- if (target != targetx)
- emit_move_insn (target, targetx);
- return target;
- }
-
- case SET_IN_EXPR:
- {
- 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;
-}
-\f
-/* Check that the argument list has a length in [min_length .. max_length].
- (max_length == -1 means "infinite".)
- If so return the actual length.
- Otherwise, return an error message and return -1. */
-
-static int
-check_arglist_length (args, min_length, max_length, name)
- tree args;
- int min_length;
- int max_length;
- tree name;
-{
- int length = list_length (args);
- if (length < min_length)
- error ("too few arguments in call to `%s'", IDENTIFIER_POINTER (name));
- else if (max_length != -1 && length > max_length)
- error ("too many arguments in call to `%s'", IDENTIFIER_POINTER (name));
- else
- return length;
- return -1;
-}
-\f
-/*
- * This is the code from c-typeck.c, with the C-specific cruft
- * removed (possibly I just didn't understand it, but it was
- * apparently simply discarding part of my LIST).
- */
-static tree
-internal_build_compound_expr (list, first_p)
- tree list;
- int first_p 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);
-}
-\f
-/* Given an expression PTR for a pointer, return an expression
- for the value pointed to.
- do_empty_check is 0, don't perform a NULL pointer check,
- else do it. */
-
-tree
-build_chill_indirect_ref (ptr, mode, do_empty_check)
- tree ptr;
- tree mode;
- int do_empty_check;
-{
- register tree type;
-
- if (ptr == NULL_TREE || TREE_CODE (ptr) == ERROR_MARK)
- return ptr;
- if (mode != NULL_TREE && TREE_CODE (mode) == ERROR_MARK)
- return error_mark_node;
-
- type = TREE_TYPE (ptr);
-
- if (TREE_CODE (type) == REFERENCE_TYPE)
- {
- type = TREE_TYPE (type);
- ptr = convert (type, ptr);
- }
-
- /* check for ptr is really a POINTER */
- if (TREE_CODE (type) != POINTER_TYPE)
- {
- error ("cannot dereference, not a pointer");
- return error_mark_node;
- }
-
- if (mode && TREE_CODE (mode) == IDENTIFIER_NODE)
- {
- tree decl = lookup_name (mode);
- if (decl == NULL_TREE || TREE_CODE (decl) != TYPE_DECL)
- {
- if (pass == 2)
- error ("missing '.' operator or undefined mode name `%s'",
- IDENTIFIER_POINTER (mode));
-#if 0
- error ("you have forgotten the '.' operator which must");
- error (" precede a STRUCT field reference, or `%s' is an undefined mode",
- IDENTIFIER_POINTER (mode));
-#endif
- return error_mark_node;
- }
- }
-
- if (mode)
- {
- mode = get_type_of (mode);
- ptr = convert (build_pointer_type (mode), ptr);
- }
- else if (type == ptr_type_node)
- {
- error ("can't dereference PTR value using unary `->'");
- return error_mark_node;
- }
-
- if (do_empty_check)
- ptr = check_non_null (ptr);
-
- type = TREE_TYPE (ptr);
-
- if (TREE_CODE (type) == POINTER_TYPE)
- {
- if (TREE_CODE (ptr) == ADDR_EXPR
- && !flag_volatile
- && (TREE_TYPE (TREE_OPERAND (ptr, 0))
- == TREE_TYPE (type)))
- return TREE_OPERAND (ptr, 0);
- else
- {
- tree t = TREE_TYPE (type);
- register tree ref = build1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (t), ptr);
-
- if (TYPE_SIZE (t) == 0 && TREE_CODE (t) != ARRAY_TYPE)
- {
- error ("dereferencing pointer to incomplete type");
- return error_mark_node;
- }
- if (TREE_CODE (t) == VOID_TYPE)
- warning ("dereferencing `void *' pointer");
-
- /* We *must* set TREE_READONLY when dereferencing a pointer to const,
- so that we get the proper error message if the result is used
- to assign to. Also, &* is supposed to be a no-op.
- And ANSI C seems to specify that the type of the result
- should be the const type. */
- /* A de-reference of a pointer to const is not a const. It is valid
- to change it via some other pointer. */
- TREE_READONLY (ref) = TYPE_READONLY (t);
- TREE_SIDE_EFFECTS (ref)
- = TYPE_VOLATILE (t) || TREE_SIDE_EFFECTS (ptr) || flag_volatile;
- TREE_THIS_VOLATILE (ref) = TYPE_VOLATILE (t) || flag_volatile;
- return ref;
- }
- }
- else if (TREE_CODE (ptr) != ERROR_MARK)
- error ("invalid type argument of `->'");
- return error_mark_node;
-}
-
-/* NODE is a COMPONENT_REF whose mode is an IDENTIFIER,
- which is replaced by the proper FIELD_DECL.
- Also do the right thing for variant records. */
-
-tree
-resolve_component_ref (node)
- tree node;
-{
- tree datum = TREE_OPERAND (node, 0);
- tree field_name = TREE_OPERAND (node, 1);
- tree type = TREE_TYPE (datum);
- tree field;
- if (TREE_CODE (datum) == ERROR_MARK)
- return error_mark_node;
- if (TREE_CODE (type) == REFERENCE_TYPE)
- {
- type = TREE_TYPE (type);
- TREE_OPERAND (node, 0) = datum = convert (type, datum);
- }
- if (TREE_CODE (type) != RECORD_TYPE)
- {
- error ("operand of '.' is not a STRUCT");
- return error_mark_node;
- }
-
- TREE_READONLY (node) = TREE_READONLY (datum);
- TREE_SIDE_EFFECTS (node) = TREE_SIDE_EFFECTS (datum);
-
- for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
- {
- if (TREE_CODE (TREE_TYPE (field)) == UNION_TYPE)
- {
- tree variant;
- for (variant = TYPE_FIELDS (TREE_TYPE (field));
- variant; variant = TREE_CHAIN (variant))
- {
- tree vfield;
- for (vfield = TYPE_FIELDS (TREE_TYPE (variant));
- vfield; vfield = TREE_CHAIN (vfield))
- {
- if (DECL_NAME (vfield) == field_name)
- { /* Found a variant field */
- datum = build (COMPONENT_REF, TREE_TYPE (field),
- datum, field);
- datum = build (COMPONENT_REF, TREE_TYPE (variant),
- datum, variant);
- TREE_OPERAND (node, 0) = datum;
- TREE_OPERAND (node, 1) = vfield;
- TREE_TYPE (node) = TREE_TYPE (vfield);
- TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node));
-#if 0
- if (flag_testing_tags)
- {
- tree tagtest = NOT IMPLEMENTED;
- tree tagf = ridpointers[(int) RID_RANGEFAIL];
- node = check_expression (node, tagtest,
- tagf);
- }
-#endif
- return node;
- }
- }
- }
- }
-
- if (DECL_NAME (field) == field_name)
- { /* Found a fixed field */
- TREE_OPERAND (node, 1) = field;
- TREE_TYPE (node) = TREE_TYPE (field);
- TREE_READONLY (node) |= TYPE_READONLY (TREE_TYPE (node));
- return fold (node);
- }
- }
-
- error ("no field named `%s'", IDENTIFIER_POINTER (field_name));
- return error_mark_node;
-}
-
-tree
-build_component_ref (datum, field_name)
- tree datum, field_name;
-{
- tree node = build_nt (COMPONENT_REF, datum, field_name);
- if (pass != 1)
- node = resolve_component_ref (node);
- return node;
-}
-
-/*
- function checks (for build_chill_component_ref) if a given
- type is really an instance type. CH_IS_INSTANCE_MODE is not
- strict enough in this case, i.e. SYNMODE foo = STRUCT (a, b UINT)
- is compatible to INSTANCE. */
-
-static int
-is_really_instance (type)
- tree type;
-{
- tree decl = TYPE_NAME (type);
-
- if (decl == NULL_TREE)
- /* this is not an instance */
- return 0;
-
- if (DECL_NAME (decl) == ridpointers[(int)RID_INSTANCE])
- /* this is an instance */
- return 1;
-
- if (TYPE_FIELDS (type) == TYPE_FIELDS (instance_type_node))
- /* we have a NEWMODE'd instance */
- return 1;
-
- return 0;
-}
-
-/* This function is called by the parse.
- Here we check if the user tries to access a field in a type which is
- layouted as a structure but isn't like INSTANCE, BUFFER, EVENT, ASSOCIATION,
- ACCESS, TEXT, or VARYING array or character string.
- We don't do this in build_component_ref cause this function gets
- called from the compiler to access fields in one of the above mentioned
- modes. */
-tree
-build_chill_component_ref (datum, field_name)
- tree datum, field_name;
-{
- tree type = TREE_TYPE (datum);
- if ((type != NULL_TREE && TREE_CODE (type) == RECORD_TYPE) &&
- ((CH_IS_INSTANCE_MODE (type) && is_really_instance (type)) ||
- CH_IS_BUFFER_MODE (type) ||
- CH_IS_EVENT_MODE (type) || CH_IS_ASSOCIATION_MODE (type) ||
- CH_IS_ACCESS_MODE (type) || CH_IS_TEXT_MODE (type) ||
- chill_varying_type_p (type)))
- {
- error ("operand of '.' is not a STRUCT");
- return error_mark_node;
- }
- return build_component_ref (datum, field_name);
-}
-\f
-/*
- * Check for invalid binary operands & unary operands
- * RIGHT is 1 if checking right operand or unary operand;
- * it is 0 if checking left operand.
- *
- * return 1 if the given operand is NOT compatible as the
- * operand of the given operator
- *
- * return 0 if they might be compatible
- */
-static int
-invalid_operand (code, type, right)
- enum chill_tree_code code;
- tree type;
- int right; /* 1 if right operand */
-{
- switch ((int)code)
- {
- case ADDR_EXPR:
- break;
- case BIT_AND_EXPR:
- case BIT_IOR_EXPR:
- case BIT_NOT_EXPR:
- case BIT_XOR_EXPR:
- goto relationals;
- case CASE_EXPR:
- break;
- case CEIL_MOD_EXPR:
- goto numerics;
- case CONCAT_EXPR: /* must be static or varying char array */
- if (TREE_CODE (type) == CHAR_TYPE)
- return 0;
- if (TREE_CODE (type) == ARRAY_TYPE
- && TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
- return 0;
- if (!chill_varying_type_p (type))
- return 1;
- if (TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type)))
- == CHAR_TYPE)
- return 0;
- else
- return 1;
- /* note: CHILL conditional expressions (COND_EXPR) won't come
- * through here; they're routed straight to C-specific code */
- case EQ_EXPR:
- return 0; /* ANYTHING can be compared equal */
- case FLOOR_MOD_EXPR:
- if (TREE_CODE (type) == REAL_TYPE)
- return 1;
- goto numerics;
- case GE_EXPR:
- case GT_EXPR:
- goto relatables;
- case SET_IN_EXPR:
- if (TREE_CODE (type) == SET_TYPE)
- return 0;
- else
- return 1;
- case PACKED_ARRAY_REF:
- if (TREE_CODE (type) == ARRAY_TYPE)
- return 0;
- else
- return 1;
- case LE_EXPR:
- case LT_EXPR:
- relatables:
- switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */
- {
- case ARRAY_TYPE:
- if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
- return 0;
- else
- return 1;
- case BOOLEAN_TYPE:
- case CHAR_TYPE:
- case COMPLEX_TYPE:
- case ENUMERAL_TYPE:
- case INTEGER_TYPE:
- case OFFSET_TYPE:
- case POINTER_TYPE:
- case REAL_TYPE:
- case SET_TYPE:
- return 0;
- case FILE_TYPE:
- case FUNCTION_TYPE:
- case GRANT_TYPE:
- case LANG_TYPE:
- case METHOD_TYPE:
- return 1;
- case RECORD_TYPE:
- if (chill_varying_type_p (type)
- && TREE_CODE (TREE_TYPE (CH_VARYING_ARRAY_TYPE (type))) == CHAR_TYPE)
- return 0;
- else
- return 1;
- case REFERENCE_TYPE:
- case SEIZE_TYPE:
- case UNION_TYPE:
- case VOID_TYPE:
- return 1;
- }
- break;
- case MINUS_EXPR:
- case MULT_EXPR:
- goto numerics;
- case NEGATE_EXPR:
- if (TREE_CODE (type) == BOOLEAN_TYPE)
- return 0;
- else
- goto numerics;
- case NE_EXPR:
- return 0; /* ANYTHING can be compared unequal */
- case NOP_EXPR:
- return 0; /* ANYTHING can be converted */
- case PLUS_EXPR:
- numerics:
- switch ((int)TREE_CODE(type)) /* left operand must be discrete type */
- {
- case ARRAY_TYPE:
- if (right || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE)
- return 1;
- else
- return 0;
- case CHAR_TYPE:
- return right;
- case BOOLEAN_TYPE:
- case COMPLEX_TYPE:
- case FILE_TYPE:
- case FUNCTION_TYPE:
- case GRANT_TYPE:
- case LANG_TYPE:
- case METHOD_TYPE:
- case RECORD_TYPE:
- case REFERENCE_TYPE:
- case SEIZE_TYPE:
- case UNION_TYPE:
- case VOID_TYPE:
- return 1;
- case ENUMERAL_TYPE:
- case INTEGER_TYPE:
- case OFFSET_TYPE:
- case POINTER_TYPE:
- case REAL_TYPE:
- case SET_TYPE:
- return 0;
- }
- break;
- case RANGE_EXPR:
- break;
-
- case REPLICATE_EXPR:
- switch ((int)TREE_CODE(type)) /* right operand must be set/bitarray type */
- {
- case COMPLEX_TYPE:
- case FILE_TYPE:
- case FUNCTION_TYPE:
- case GRANT_TYPE:
- case LANG_TYPE:
- case METHOD_TYPE:
- case OFFSET_TYPE:
- case POINTER_TYPE:
- case RECORD_TYPE:
- case REAL_TYPE:
- case SEIZE_TYPE:
- case UNION_TYPE:
- case VOID_TYPE:
- return 1;
- case ARRAY_TYPE:
- case BOOLEAN_TYPE:
- case CHAR_TYPE:
- case ENUMERAL_TYPE:
- case INTEGER_TYPE:
- case REFERENCE_TYPE:
- case SET_TYPE:
- return 0;
- }
-
- case TRUNC_DIV_EXPR:
- goto numerics;
- case TRUNC_MOD_EXPR:
- if (TREE_CODE (type) == REAL_TYPE)
- return 1;
- goto numerics;
- case TRUTH_ANDIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_NOT_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_OR_EXPR:
- relationals:
- switch ((int)TREE_CODE(type)) /* left operand must be discrete type */
- {
- case ARRAY_TYPE:
- case CHAR_TYPE:
- case COMPLEX_TYPE:
- case ENUMERAL_TYPE:
- case FILE_TYPE:
- case FUNCTION_TYPE:
- case GRANT_TYPE:
- case INTEGER_TYPE:
- case LANG_TYPE:
- case METHOD_TYPE:
- case OFFSET_TYPE:
- case POINTER_TYPE:
- case REAL_TYPE:
- case RECORD_TYPE:
- case REFERENCE_TYPE:
- case SEIZE_TYPE:
- case UNION_TYPE:
- case VOID_TYPE:
- return 1;
- case BOOLEAN_TYPE:
- case SET_TYPE:
- return 0;
- }
- break;
-
- default:
- return 1; /* perhaps you forgot to add a new DEFTREECODE? */
- }
- return 1;
-}
-
-
-static int
-invalid_right_operand (code, type)
- enum chill_tree_code code;
- tree type;
-{
- return invalid_operand (code, type, 1);
-}
-\f
-tree
-build_chill_abs (expr)
- tree expr;
-{
- tree temp;
-
- if (TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE
- || discrete_type_p (TREE_TYPE (expr)))
- temp = fold (build1 (ABS_EXPR, TREE_TYPE (expr), expr));
- else
- {
- error("ABS argument must be discrete or real mode");
- return error_mark_node;
- }
- /* FIXME: should call
- * cond_type_range_exception (temp);
- */
- return temp;
-}
-
-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-built-in 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);
-}
-\f
-/* Compute the value of the CHILL `size' operator just
- * like the C 'sizeof' operator (code stolen from c-typeck.c)
- * TYPE may be a location or mode tree. In pass 1, we build
- * a function-call syntax tree; in pass 2, we evaluate it.
- */
-tree
-build_chill_sizeof (type)
- tree type;
-{
- if (pass == 2)
- {
- tree temp;
- struct ch_class class;
- enum tree_code code;
- tree signame = NULL_TREE;
-
- if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_CODE (type) == IDENTIFIER_NODE)
- type = lookup_name (type);
-
- code = TREE_CODE (type);
- if (code == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_CODE_CLASS (TREE_CODE (type)) != 't')
- {
- if (TREE_CODE (type) == TYPE_DECL && CH_DECL_SIGNAL (type))
- signame = DECL_NAME (type);
- type = TREE_TYPE (type);
- }
-
- if (code == FUNCTION_TYPE)
- {
- if (pedantic || warn_pointer_arith)
- pedwarn ("size applied to a function mode");
- return error_mark_node;
- }
- if (code == VOID_TYPE)
- {
- if (pedantic || warn_pointer_arith)
- pedwarn ("sizeof applied to a void mode");
- return error_mark_node;
- }
- if (TYPE_SIZE (type) == 0)
- {
- error ("sizeof applied to an incomplete mode");
- return error_mark_node;
- }
-
- temp = size_binop (CEIL_DIV_EXPR, TYPE_SIZE_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;
-}
-\f
-/* Compute the declared maximum value of the variable,
- * expression or declared type
- */
-tree
-build_chill_upper (what)
- tree what;
-{
- return build_chill_lower_or_upper (what, 1);
-}
-\f
-/*
- * Here at the site of a function/procedure call.. We need to build
- * temps for the INOUT and OUT parameters, and copy the actual parameters
- * into the temps. After the call, we 'copy back' the values from the
- * temps to the actual parameter variables. This somewhat verbose pol-
- * icy meets the requirement that the actual parameters are undisturbed
- * if the function/procedure causes an exception. They are updated only
- * upon a normal return from the function.
- *
- * Note: the expr_list, which collects all of the above assignments, etc,
- * is built in REVERSE execution order. The list is corrected by nreverse
- * inside the build_chill_compound_expr call.
- */
-tree
-build_chill_function_call (function, expr)
- tree function, expr;
-{
- register tree typetail, valtail, typelist;
- register tree temp, actual_args = NULL_TREE;
- tree name = NULL_TREE;
- tree function_call;
- tree fntype;
- int parmno = 1; /* parameter number for error message */
- int callee_raise_exception = 0;
-
- /* list of assignments to run after the actual call,
- copying from the temps back to the user's variables. */
- tree copy_back = NULL_TREE;
-
- /* list of expressions to run before the call, copying from
- the user's variable to the temps that are passed to the function */
- tree expr_list = NULL_TREE;
-
- if (function == NULL_TREE || TREE_CODE (function) == ERROR_MARK)
- return error_mark_node;
-
- if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
- return error_mark_node;
-
- if (pass < 2)
- return error_mark_node;
-
- fntype = TREE_TYPE (function);
- if (TREE_CODE (function) == FUNCTION_DECL)
- {
- callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE;
-
- /* Differs from default_conversion by not setting TREE_ADDRESSABLE
- (because calling an inline function does not mean the function
- needs to be separately compiled). */
- fntype = build_type_variant (fntype,
- TREE_READONLY (function),
- TREE_THIS_VOLATILE (function));
- name = DECL_NAME (function);
-
- /* check that function is not a PROCESS */
- if (CH_DECL_PROCESS (function))
- {
- error ("cannot call a PROCESS, you START a PROCESS");
- return error_mark_node;
- }
-
- function = build1 (ADDR_EXPR, build_pointer_type (fntype), function);
- }
- else if (TREE_CODE (fntype) == POINTER_TYPE)
- {
- fntype = TREE_TYPE (fntype);
- callee_raise_exception = TYPE_RAISES_EXCEPTIONS (fntype) != NULL_TREE;
-
- /* Z.200 6.7 Call Action:
- "A procedure call causes the EMPTY exception if the
- procedure primitive value delivers NULL. */
- if (TREE_CODE (function) != ADDR_EXPR
- || TREE_CODE (TREE_OPERAND (function, 0)) != FUNCTION_DECL)
- function = check_non_null (function);
- }
-
- typelist = TYPE_ARG_TYPES (fntype);
- if (callee_raise_exception)
- {
- /* remove last two arguments from list for subsequent checking.
- They will get added automatically after checking */
- int len = list_length (typelist);
- int i;
- tree newtypelist = NULL_TREE;
- tree wrk = typelist;
-
- for (i = 0; i < len - 3; i++)
- {
- newtypelist = tree_cons (TREE_PURPOSE (wrk), TREE_VALUE (wrk), newtypelist);
- wrk = TREE_CHAIN (wrk);
- }
- /* add the void_type_node */
- newtypelist = tree_cons (NULL_TREE, void_type_node, newtypelist);
- typelist = nreverse (newtypelist);
- }
-
- /* Scan the given expressions and types, producing individual
- converted arguments and pushing them on ACTUAL_ARGS in
- reverse order. */
- for (valtail = expr, typetail = typelist;
- valtail != NULL_TREE && typetail != NULL_TREE; parmno++,
- valtail = TREE_CHAIN (valtail), typetail = TREE_CHAIN (typetail))
- {
- register tree actual = TREE_VALUE (valtail);
- register tree attr = TREE_PURPOSE (typetail)
- ? TREE_PURPOSE (typetail) : ridpointers[(int) RID_IN];
- register tree type = TREE_VALUE (typetail);
- char place[30];
- sprintf (place, "parameter %d", parmno);
-
- /* if we have reached void_type_node in typelist we are at the
- end of formal parameters and then we have too many actual
- parameters */
- if (type == void_type_node)
- break;
-
- /* check if actual is a TYPE_DECL. FIXME: what else ? */
- if (TREE_CODE (actual) == TYPE_DECL)
- {
- error ("invalid %s", place);
- actual = error_mark_node;
- }
- /* INOUT or OUT param to handle? */
- else if (attr == ridpointers[(int) RID_OUT]
- || attr == ridpointers[(int)RID_INOUT])
- {
- char temp_name[20];
- tree parmtmp;
- tree in_actual = NULL_TREE, out_actual;
-
- /* actual parameter must be a location so we can
- build a reference to it */
- if (!CH_LOCATION_P (actual))
- {
- error ("%s parameter %d must be a location",
- (attr == ridpointers[(int) RID_OUT]) ?
- "OUT" : "INOUT", parmno);
- continue;
- }
- if (TYPE_READONLY_PROPERTY (TREE_TYPE (actual))
- || TREE_READONLY (actual))
- {
- error ("%s parameter %d is READ-only",
- (attr == ridpointers[(int) RID_OUT]) ?
- "OUT" : "INOUT", parmno);
- continue;
- }
-
- sprintf (temp_name, "PARM_%d_%s", parmno,
- (attr == ridpointers[(int)RID_OUT]) ?
- "OUT" : "INOUT");
- parmtmp = decl_temp1 (get_unique_identifier (temp_name),
- TREE_TYPE (type), 0, NULL_TREE, 0, 0);
- /* this temp *must not* be optimized into a register */
- mark_addressable (parmtmp);
-
- if (attr == ridpointers[(int)RID_INOUT])
- {
- tree in_actual = chill_convert_for_assignment (TREE_TYPE (type),
- actual, place);
- tree tmp = build_chill_modify_expr (parmtmp, in_actual);
- expr_list = tree_cons (NULL_TREE, tmp, expr_list);
- }
- if (in_actual != error_mark_node)
- {
- /* list of copy back assignments to perform, from the temp
- back to the actual parameter */
- out_actual = chill_convert_for_assignment (TREE_TYPE (actual),
- parmtmp, place);
- copy_back = tree_cons (NULL_TREE,
- build_chill_modify_expr (actual,
- out_actual),
- copy_back);
- }
- /* we can do this because build_chill_function_type
- turned these parameters into REFERENCE_TYPEs. */
- actual = build1 (ADDR_EXPR, type, parmtmp);
- }
- else if (attr == ridpointers[(int) RID_LOC])
- {
- int is_location = chill_location (actual);
- if (is_location)
- {
- if (is_location == 1)
- {
- error ("LOC actual parameter %d is a non-referable location",
- parmno);
- actual = error_mark_node;
- }
- else if (! CH_READ_COMPATIBLE (type, TREE_TYPE (actual)))
- {
- error ("mode mismatch in parameter %d", parmno);
- actual = error_mark_node;
- }
- else
- actual = convert (type, actual);
- }
- else
- {
- 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;
- }
-}
-\f
-/* We saw something that looks like a function call,
- but if it's pass 1, we're not sure. */
-
-tree
-build_generalized_call (func, args)
- tree func, args;
-{
- tree type = TREE_TYPE (func);
-
- if (pass == 1)
- return build (CALL_EXPR, NULL_TREE, func, args, NULL_TREE);
-
- /* Handle string repetition */
- if (TREE_CODE (func) == INTEGER_CST)
- {
- if (args == NULL_TREE || TREE_CHAIN (args) != NULL_TREE)
- {
- error ("syntax error (integer used as function)");
- return error_mark_node;
- }
- if (TREE_CODE (args) == TREE_LIST)
- args = TREE_VALUE (args);
- return build_chill_repetition_op (func, args);
- }
-
- if (args != NULL_TREE)
- {
- if (TREE_CODE (args) == RANGE_EXPR)
- {
- tree lo = TREE_OPERAND (args, 0), hi = TREE_OPERAND (args, 1);
- if (TREE_CODE_CLASS (TREE_CODE (func)) == 't')
- return build_chill_range_type (func, lo, hi);
- else
- return build_chill_slice_with_range (func, lo, hi);
- }
- else if (TREE_CODE (args) != TREE_LIST)
- {
- error ("syntax error - missing operator, comma, or '('?");
- return error_mark_node;
- }
- }
-
- if (TREE_CODE (func) == TYPE_DECL)
- {
- if (CH_DECL_SIGNAL (func))
- return build_signal_descriptor (func, args);
- func = TREE_TYPE (func);
- }
-
- if (TREE_CODE_CLASS (TREE_CODE (func)) == 't'
- && args != NULL_TREE && TREE_CHAIN (args) == NULL_TREE)
- return build_chill_cast (func, TREE_VALUE (args));
-
- if (TREE_CODE (type) == FUNCTION_TYPE
- || (TREE_CODE (type) == POINTER_TYPE
- && TREE_TYPE (type) != NULL_TREE
- && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE))
- {
- /* Check for a built-in Chill function. */
- if (TREE_CODE (func) == FUNCTION_DECL
- && DECL_BUILT_IN (func)
- && DECL_FUNCTION_CODE (func) > END_BUILTINS)
- {
- tree fnname = DECL_NAME (func);
- switch ((enum chill_built_in_function)DECL_FUNCTION_CODE (func))
- {
- case BUILT_IN_CH_ABS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_abs (TREE_VALUE (args));
- case BUILT_IN_ABSTIME:
- if (check_arglist_length (args, 0, 6, fnname) < 0)
- return error_mark_node;
- return build_chill_abstime (args);
- case BUILT_IN_ADDR:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
-#if 0
- return build_chill_addr_expr (TREE_VALUE (args), (char *)0);
-#else
- return build_chill_arrow_expr (TREE_VALUE (args), 0);
-#endif
- case BUILT_IN_ALLOCATE_GLOBAL_MEMORY:
- if (check_arglist_length (args, 2, 2, fnname) < 0)
- return error_mark_node;
- return build_allocate_global_memory_call
- (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_ALLOCATE:
- if (check_arglist_length (args, 1, 2, fnname) < 0)
- return error_mark_node;
- return build_chill_allocate (TREE_VALUE (args),
- TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_ALLOCATE_MEMORY:
- if (check_arglist_length (args, 2, 2, fnname) < 0)
- return error_mark_node;
- return build_allocate_memory_call
- (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_ASSOCIATE:
- if (check_arglist_length (args, 2, 3, fnname) < 0)
- return error_mark_node;
- return build_chill_associate
- (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)),
- TREE_CHAIN (TREE_CHAIN (args)));
- case BUILT_IN_ARCCOS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__acos");
- case BUILT_IN_ARCSIN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__asin");
- case BUILT_IN_ARCTAN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__atan");
- case BUILT_IN_CARD:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_card (TREE_VALUE (args));
- case BUILT_IN_CONNECT:
- if (check_arglist_length (args, 3, 5, fnname) < 0)
- return error_mark_node;
- return build_chill_connect
- (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)),
- TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))),
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args))));
- case BUILT_IN_COPY_NUMBER:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_copy_number (TREE_VALUE (args));
- case BUILT_IN_CH_COS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__cos");
- case BUILT_IN_CREATE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_create (TREE_VALUE (args));
- case BUILT_IN_DAYS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_duration (TREE_VALUE (args), DAYS_MULTIPLIER,
- fnname, DAYS_MAX);
- case BUILT_IN_CH_DELETE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_delete (TREE_VALUE (args));
- case BUILT_IN_DESCR:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_descr (TREE_VALUE (args));
- case BUILT_IN_DISCONNECT:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_disconnect (TREE_VALUE (args));
- case BUILT_IN_DISSOCIATE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_dissociate (TREE_VALUE (args));
- case BUILT_IN_EOLN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_eoln (TREE_VALUE (args));
- case BUILT_IN_EXISTING:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_existing (TREE_VALUE (args));
- case BUILT_IN_EXP:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__exp");
- case BUILT_IN_GEN_CODE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_gen_code (TREE_VALUE (args));
- case BUILT_IN_GEN_INST:
- if (check_arglist_length (args, 2, 2, fnname) < 0)
- return error_mark_node;
- return build_gen_inst (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_GEN_PTYPE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_gen_ptype (TREE_VALUE (args));
- case BUILT_IN_GETASSOCIATION:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_getassociation (TREE_VALUE (args));
- case BUILT_IN_GETSTACK:
- if (check_arglist_length (args, 1, 2, fnname) < 0)
- return error_mark_node;
- return build_chill_getstack (TREE_VALUE (args),
- TREE_CHAIN (args) == NULL_TREE ? NULL_TREE : TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_GETTEXTACCESS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_gettextaccess (TREE_VALUE (args));
- case BUILT_IN_GETTEXTINDEX:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_gettextindex (TREE_VALUE (args));
- case BUILT_IN_GETTEXTRECORD:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_gettextrecord (TREE_VALUE (args));
- case BUILT_IN_GETUSAGE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_getusage (TREE_VALUE (args));
- case BUILT_IN_HOURS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_duration (TREE_VALUE (args), HOURS_MULTIPLIER,
- fnname, HOURS_MAX);
- case BUILT_IN_INDEXABLE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_indexable (TREE_VALUE (args));
- case BUILT_IN_INTTIME:
- if (check_arglist_length (args, 2, 7, fnname) < 0)
- return error_mark_node;
- return build_chill_inttime (TREE_VALUE (args),
- TREE_CHAIN (args));
- case BUILT_IN_ISASSOCIATED:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_isassociated (TREE_VALUE (args));
- case BUILT_IN_LENGTH:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_length (TREE_VALUE (args));
- case BUILT_IN_LN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__log");
- case BUILT_IN_LOG:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__log10");
- case BUILT_IN_LOWER:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_lower (TREE_VALUE (args));
- case BUILT_IN_MAX:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_max (TREE_VALUE (args));
- case BUILT_IN_MILLISECS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_duration (TREE_VALUE (args), MILLISECS_MULTIPLIER,
- fnname, MILLISECS_MAX);
- case BUILT_IN_MIN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_min (TREE_VALUE (args));
- case BUILT_IN_MINUTES:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_duration (TREE_VALUE (args), MINUTES_MULTIPLIER,
- fnname, MINUTES_MAX);
- case BUILT_IN_MODIFY:
- if (check_arglist_length (args, 1, -1, fnname) < 0)
- return error_mark_node;
- return build_chill_modify (TREE_VALUE (args), TREE_CHAIN (args));
- case BUILT_IN_NUM:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_num (TREE_VALUE (args));
- case BUILT_IN_OUTOFFILE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_outoffile (TREE_VALUE (args));
- case BUILT_IN_PRED:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_pred_or_succ (TREE_VALUE (args), MINUS_EXPR);
- case BUILT_IN_PROC_TYPE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_proc_type (TREE_VALUE (args));
- case BUILT_IN_QUEUE_LENGTH:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_queue_length (TREE_VALUE (args));
- case BUILT_IN_READABLE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_readable (TREE_VALUE (args));
- case BUILT_IN_READRECORD:
- if (check_arglist_length (args, 1, 3, fnname) < 0)
- return error_mark_node;
- return build_chill_readrecord (TREE_VALUE (args), TREE_CHAIN (args));
- case BUILT_IN_READTEXT:
- if (check_arglist_length (args, 2, -1, fnname) < 0)
- return error_mark_node;
- return build_chill_readtext (TREE_VALUE (args),
- TREE_CHAIN (args));
- case BUILT_IN_RETURN_MEMORY:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_return_memory (TREE_VALUE (args));
- case BUILT_IN_SECS:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_duration (TREE_VALUE (args), SECS_MULTIPLIER,
- fnname, SECS_MAX);
- case BUILT_IN_SEQUENCIBLE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_sequencible (TREE_VALUE (args));
- case BUILT_IN_SETTEXTACCESS:
- if (check_arglist_length (args, 2, 2, fnname) < 0)
- return error_mark_node;
- return build_chill_settextaccess (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_SETTEXTINDEX:
- if (check_arglist_length (args, 2, 2, fnname) < 0)
- return error_mark_node;
- return build_chill_settextindex (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_SETTEXTRECORD:
- if (check_arglist_length (args, 2, 2, fnname) < 0)
- return error_mark_node;
- return build_chill_settextrecord (TREE_VALUE (args),
- TREE_VALUE (TREE_CHAIN (args)));
- case BUILT_IN_CH_SIN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__sin");
- case BUILT_IN_SIZE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_sizeof (TREE_VALUE (args));
- case BUILT_IN_SQRT:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__sqrt");
- case BUILT_IN_SUCC:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_pred_or_succ (TREE_VALUE (args), PLUS_EXPR);
- case BUILT_IN_TAN:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_floatcall (TREE_VALUE (args),
- IDENTIFIER_POINTER (fnname),
- "__tan");
- case BUILT_IN_TERMINATE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_terminate (TREE_VALUE (args));
- case BUILT_IN_UPPER:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_upper (TREE_VALUE (args));
- case BUILT_IN_VARIABLE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_variable (TREE_VALUE (args));
- case BUILT_IN_WRITEABLE:
- if (check_arglist_length (args, 1, 1, fnname) < 0)
- return error_mark_node;
- return build_chill_writeable (TREE_VALUE (args));
- case BUILT_IN_WRITERECORD:
- if (check_arglist_length (args, 2, 3, fnname) < 0)
- return error_mark_node;
- return build_chill_writerecord (TREE_VALUE (args), TREE_CHAIN (args));
- case BUILT_IN_WRITETEXT:
- if (check_arglist_length (args, 2, -1, fnname) < 0)
- return error_mark_node;
- return build_chill_writetext (TREE_VALUE (args),
- TREE_CHAIN (args));
-
- case BUILT_IN_EXPIRED:
- case BUILT_IN_WAIT:
- sorry ("unimplemented built-in function `%s'",
- IDENTIFIER_POINTER (fnname));
- break;
- default:
- error ("internal error - bad built-in function `%s'",
- IDENTIFIER_POINTER (fnname));
- }
- }
- return build_chill_function_call (func, args);
- }
-
- if (chill_varying_type_p (TREE_TYPE (func)))
- type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
-
- if (CH_STRING_TYPE_P (type))
- {
- if (args == NULL_TREE)
- {
- error ("empty expression in string index");
- return error_mark_node;
- }
- if (TREE_CHAIN (args) != NULL)
- {
- error ("only one expression allowed in string index");
- return error_mark_node;
- }
- if (flag_old_strings)
- return build_chill_slice_with_length (func,
- TREE_VALUE (args),
- integer_one_node);
- else if (CH_BOOLS_TYPE_P (type))
- return build_chill_bitref (func, args);
- else
- return build_chill_array_ref (func, args);
- }
-
- else if (TREE_CODE (type) == ARRAY_TYPE)
- return build_chill_array_ref (func, args);
-
- if (TREE_CODE (func) != ERROR_MARK)
- error ("invalid: primval ( untyped_exprlist )");
- return error_mark_node;
-}
-\f
-/* Given a set stored as one bit per char (in BUFFER[0 .. BIT_SIZE-1]),
- return a CONTRUCTOR, of type TYPE (a SET_TYPE). */
-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;
-}
-\f
-/*
- * fold a set represented as a CONSTRUCTOR list.
- * An empty set has a NULL_TREE in its TREE_OPERAND (set, 1) slot.
- */
-static tree
-fold_set_expr (code, op0, op1)
- enum chill_tree_code code;
- tree op0, op1;
-{
- tree temp;
- char *buffer0, *buffer1 = 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;
- }
-}
-\f
-/*
- * 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);
-}
-\f
-/* Convert a varying string (or array) to dynamic non-varying string:
- EXP becomes EXP.var_data(0 UP EXP.var_length). */
-
-tree
-varying_to_slice (exp)
- tree exp;
-{
- if (!chill_varying_type_p (TREE_TYPE (exp)))
- return exp;
- else
- { tree size, data, data_domain, 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;
-}
-\f
-int
-compare_int_csts (op, val1, val2)
- enum tree_code op;
- tree val1, val2;
-{
- int result;
- tree tmp;
- tree type1 = TREE_TYPE (val1);
- tree type2 = TREE_TYPE (val2);
- switch (op)
- {
- case GT_EXPR:
- case GE_EXPR:
- tmp = val1; val1 = val2; val2 = tmp;
- tmp = type1; type1 = type2; type2 = tmp;
- op = (op == GT_EXPR) ? LT_EXPR : LE_EXPR;
- /* ... fall through ... */
- case LT_EXPR:
- case LE_EXPR:
- if (!TREE_UNSIGNED (type1))
- {
- if (!TREE_UNSIGNED (type2))
- result = INT_CST_LT (val1, val2);
- else if (TREE_INT_CST_HIGH (val1) < 0)
- result = 1;
- else
- result = INT_CST_LT_UNSIGNED (val1, val2);
- }
- else
- {
- if (!TREE_UNSIGNED (type2) && TREE_INT_CST_HIGH (val2) < 0)
- result = 0;
- else
- result = INT_CST_LT_UNSIGNED (val1, val2);
- }
- if (op == LT_EXPR || result == 1)
- break;
- /* else fall through ... */
- case NE_EXPR:
- case EQ_EXPR:
- if (TREE_INT_CST_LOW (val1) == TREE_INT_CST_LOW (val2)
- && TREE_INT_CST_HIGH (val1) == TREE_INT_CST_HIGH (val2)
- /* They're bitwise equal.
- Check for one being negative and the other unsigned. */
- && (TREE_INT_CST_HIGH (val2) >= 0
- || TREE_UNSIGNED (TREE_TYPE (val1))
- == TREE_UNSIGNED (TREE_TYPE (val2))))
- result = 1;
- else
- result = 0;
- if (op == NE_EXPR)
- result = !result;
- break;
- 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;
-}
-\f
-tree
-finish_chill_binary_op (node)
- tree node;
-{
- tree op0 = check_have_mode (TREE_OPERAND (node, 0), "binary expression");
- tree op1 = check_have_mode (TREE_OPERAND (node, 1), "binary expression");
- tree type0 = TREE_TYPE (op0);
- tree type1 = TREE_TYPE (op1);
- 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;
-}
-\f
-/*
- * This implements the '->' operator, which, like the '&' in C,
- * returns a pointer to an object, which has the type of
- * pointer-to-that-object.
- *
- * FORCE is 0 when we're evaluating a user-level syntactic construct,
- * and 1 when we're calling from inside the compiler.
- */
-tree
-build_chill_arrow_expr (ref, force)
- tree ref;
- int force;
-{
- tree addr_type;
- tree result;
-
- if (pass == 1)
- {
- error ("-> operator not allow in constant expression");
- return error_mark_node;
- }
-
- if (ref == NULL_TREE || TREE_CODE (ref) == ERROR_MARK)
- return ref;
-
- while (TREE_CODE (TREE_TYPE (ref)) == REFERENCE_TYPE)
- ref = convert (TREE_TYPE (TREE_TYPE (ref)), ref);
-
- if (!force && ! CH_LOCATION_P (ref))
- {
- if (TREE_CODE (ref) == STRING_CST)
- pedwarn ("taking the address of a string literal is non-standard");
- else if (TREE_CODE (TREE_TYPE (ref)) == FUNCTION_TYPE)
- pedwarn ("taking the address of a function is non-standard");
- else
- {
- error ("ADDR requires a LOCATION argument");
- return error_mark_node;
- }
- /* FIXME: Should we be sure that ref isn't a
- function if we're being pedantic? */
- }
-
- addr_type = build_pointer_type (TREE_TYPE (ref));
-
-#if 0
- /* This transformation makes chill_expr_class return CH_VALUE_CLASS
- when it should return CH_REFERENCE_CLASS. That could be fixed,
- but we probably don't want this transformation anyway. */
- if (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */
- {
- tree addr;
- while (TREE_CODE (ref) == NOP_EXPR) /* RETYPE_EXPR */
- ref = TREE_OPERAND (ref, 0);
- mark_addressable (ref);
- addr = build1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ref)), ref);
- return build1 (NOP_EXPR, /* RETYPE_EXPR */
- addr_type,
- addr);
- }
- else
-#endif
- {
- if (! mark_addressable (ref))
- {
- error ("-> expression is not addressable");
- return error_mark_node;
- }
- result = build1 (ADDR_EXPR, addr_type, ref);
- if (staticp (ref)
- && ! (TREE_CODE (ref) == FUNCTION_DECL
- && DECL_CONTEXT (ref) != 0))
- TREE_CONSTANT (result) = 1;
- return result;
- }
-}
-\f
-/*
- * This implements the ADDR builtin function, which returns a
- * free reference, analogous to the C 'void *'.
- */
-tree
-build_chill_addr_expr (ref, errormsg)
- tree ref;
- 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;
-}
-\f
-tree
-build_chill_binary_op (code, op0, op1)
- enum chill_tree_code code;
- tree op0, op1;
-{
- register tree result;
-
- if (op0 == NULL_TREE || TREE_CODE (op0) == ERROR_MARK)
- return error_mark_node;
- if (op1 == NULL_TREE || TREE_CODE (op1) == ERROR_MARK)
- return error_mark_node;
-
- result = build (code, NULL_TREE, op0, op1);
-
- if (pass != 1)
- result = finish_chill_binary_op (result);
- return result;
-}
-\f
-/*
- * process a string repetition phrase '(' COUNT ')' STRING
- */
-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);
-}
-\f
-/* Build a bit-string constant containing with the given LENGTH
- containing all ones (if VALUE is true), or all zeros (if VALUE is false). */
-
-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;
-}
-\f
-tree
-finish_chill_unary_op (node)
- tree node;
-{
- enum chill_tree_code code = TREE_CODE (node);
- tree op0 = check_have_mode (TREE_OPERAND (node, 0), "unary expression");
- tree type0 = TREE_TYPE (op0);
- struct ch_class class;
-
- if (TREE_CODE (op0) == ERROR_MARK)
- return error_mark_node;
- /* The expression codes of the data types of the arguments tell us
- whether the arguments are integers, floating, pointers, etc. */
-
- if (TREE_CODE (type0) == REFERENCE_TYPE)
- {
- op0 = convert (TREE_TYPE (type0), op0);
- type0 = TREE_TYPE (op0);
- }
-
- if (invalid_right_operand (code, type0))
- {
- error ("invalid operand of %s",
- tree_code_name[(int)code]);
- return error_mark_node;
- }
- switch ((int)TREE_CODE (type0))
- {
- case ARRAY_TYPE:
- if (TREE_CODE ( TREE_TYPE (type0)) == BOOLEAN_TYPE)
- code = SET_NOT_EXPR;
- else
- {
- error ("right operand of %s is not array of boolean",
- tree_code_name[(int)code]);
- return error_mark_node;
- }
- break;
- case BOOLEAN_TYPE:
- switch ((int)code)
- {
- case BIT_NOT_EXPR:
- case TRUTH_NOT_EXPR:
- return invert_truthvalue (truthvalue_conversion (op0));
-
- default:
- error ("%s operator applied to boolean variable",
- tree_code_name[(int)code]);
- return error_mark_node;
- }
- break;
-
- case SET_TYPE:
- switch ((int)code)
- {
- case BIT_NOT_EXPR:
- case NEGATE_EXPR:
- {
- tree temp = fold_set_expr (BIT_NOT_EXPR, op0, NULL_TREE);
-
- if (temp)
- return temp;
-
- code = SET_NOT_EXPR;
- }
- break;
-
- default:
- error ("invalid right operand of %s", tree_code_name[(int)code]);
- return error_mark_node;
- }
-
- }
-
- class = chill_expr_class (op0);
- if (class.mode)
- class.mode = CH_ROOT_MODE (class.mode);
- TREE_SET_CODE (node, code);
- TREE_OPERAND (node, 0) = op0 = convert_to_class (class, op0);
- TREE_TYPE (node) = TREE_TYPE (op0);
-
- node = convert_to_class (class, fold (node));
-
- /* FIXME: should call
- * cond_type_range_exception (op0);
- */
- return node;
-}
-
-/* op is TRUTH_NOT_EXPR, BIT_NOT_EXPR, or NEGATE_EXPR */
-
-tree
-build_chill_unary_op (code, op0)
- enum chill_tree_code code;
- tree op0;
-{
- register tree result = NULL_TREE;
-
- 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)));
-}
+++ /dev/null
-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
+++ /dev/null
-/* 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"
-#include "target.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;
-
-\f
-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;
-}
-\f
-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;
-}
-\f
-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);
-}
-\f
-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;
-}
-\f
-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;
-}
-\f
-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;
-}
-\f
-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;
-}
-\f
-/* 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);
-}
-\f
-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:
- REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk);
- 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;
-}
-\f
-/* 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 */
- }
-}
-\f
-/* 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;
-}
-\f
-/* 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;
-}
-\f
-/*
- * 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 && targetm.have_ctors_dtors)
- (* targetm.asm_out.constructor)
- (XEXP (DECL_RTL (chill_init_function), 0), DEFAULT_INIT_PRIORITY);
-
- /* ready now to link decls onto this list in pass 2. */
- module_init_list = NULL_TREE;
- tasking_list = NULL_TREE;
- }
-}
-
-
+++ /dev/null
-/* 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;
-}
+++ /dev/null
-/* 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;
-
-\f
-/* 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;
-}
-
-\f
-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);
-}
-\f
-/* 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;
-}
-\f
-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);
-}
-\f
-
-/* 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;
-}
-\f
-/* 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;
-}
-
-/*
- 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
-*/
-
-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;
-}
-\f
-/*
- 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
-*/
-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 than 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;
-}
-\f
-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;
-}
-\f
-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
-\f
-/* 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));
-}
-\f
-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;
-}
-\f
-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;
-}
-\f
-/* 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);
-}
-\f
-/* 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");
-}
-\f
-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 necessary 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;
-}
+++ /dev/null
-/* 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" },
+++ /dev/null
-/* 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"},
+++ /dev/null
-/* 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"
-#include "diagnostic.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 ((diagnostic_context *,
- const char *));
-\f
-/* 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;
-{
-}
-\f
-/*
- * 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 (context, file)
- diagnostic_context *buffer __attribute__((__unused__));
- 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;
-}
+++ /dev/null
-/* 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. */
-\f
-#include "config.h"
-#include "system.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 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;
-\f
-/* 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);
-}
-\f
-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))
-\f
-
-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 ();
-}
-
-\f
-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;
-}
-\f
-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;
-}
-\f
-/* 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;
-}
-\f
-/* 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;
-}
-\f
-/* 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;
-}
-\f
-#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 */
-\f
-/* 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;
- }
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
+++ /dev/null
-/* 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));
+++ /dev/null
-/* 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
-\f
-/* 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;
-\f
-/*
-
-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.
-\f
-
- 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
-\f
-
-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.
-*/
-\f
-/*
- * 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);
-}
-\f
-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);
-}
-\f
-
-/* 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);
-}
-\f
-/* 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! */
-}
-\f
-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);
-}
-\f
-/*
- * 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;
- }
- }
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/* 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;
- }
- }
-}
-\f
-/*
- * 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));
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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);
-}
-\f
-/*
- * 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
+++ /dev/null
-/* 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));
-\f
-/* 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;
-\f
-/*
-
-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.
-\f
-
- 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
-\f
-
-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.
-*/
-\f
-/*
- * 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);
-}
-\f
-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 ();
-}
-\f
-/* 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! */
-}
-\f
-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);
-}
-\f
-/*
- * 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;
- }
- }
- }
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/* 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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;
-}
-\f
-/*
- * 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);
-}
-\f
-/*
- * 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);
-}
+++ /dev/null
-/* 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 */
-\f
-/* re-initialize global variables for pass 2 */
-static void
-ch_parse_init ()
-{
- expand_exit_needed = 0;
- label = NULL_TREE; /* for statement labels */
- current_module = NULL;
- in_pseudo_module = 0;
-}
-
-static void
-check_end_label (start, end)
- tree start, end;
-{
- if (end != NULL_TREE)
- {
- if (start == NULL_TREE && pass == 1)
- error ("there was no start label to match the end label '%s'",
- IDENTIFIER_POINTER(end));
- else if (start != end && pass == 1)
- error ("start label '%s' does not match end label '%s'",
- IDENTIFIER_POINTER(start),
- IDENTIFIER_POINTER(end));
- }
-}
-
-
-/*
- * given a tree which is an id, a type or a decl,
- * return the associated type, or issue an error and
- * return error_mark_node.
- */
-tree
-get_type_of (id_or_decl)
- tree id_or_decl;
-{
- tree type = id_or_decl;
-
- if (id_or_decl == NULL_TREE
- || TREE_CODE (id_or_decl) == ERROR_MARK)
- return error_mark_node;
-
- if (pass == 1 || ignoring == 1)
- return id_or_decl;
-
- if (TREE_CODE (type) == IDENTIFIER_NODE)
- {
- type = lookup_name (id_or_decl);
- if (type == NULL_TREE)
- {
- error ("`%s' not declared", IDENTIFIER_POINTER (id_or_decl));
- type = error_mark_node;
- }
- }
- if (TREE_CODE (type) == TYPE_DECL)
- type = TREE_TYPE (type);
- return type; /* was a type all along */
-}
-
-
-static void
-end_function ()
-{
- if (CH_DECL_PROCESS (current_function_decl))
- {
- /* finishing a process */
- if (! ignoring)
- {
- tree result =
- build_chill_function_call
- (lookup_name (get_identifier ("__stop_process")),
- NULL_TREE);
- expand_expr_stmt (result);
- emit_line_note (input_filename, lineno);
- }
- }
- else
- {
- /* finishing a procedure.. */
- if (! ignoring)
- {
- if (result_never_set
- && TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl)))
- != VOID_TYPE)
- warning ("no RETURN or RESULT in procedure");
- chill_expand_return (NULL_TREE, 1);
- }
- }
- finish_chill_function ();
- pop_chill_function_context ();
-}
-
-static tree
-build_prefix_clause (id)
- tree id;
-{
- if (!id)
- {
- if (current_module && current_module->name)
- { 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 initialization");
- 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
+++ /dev/null
-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
-};
+++ /dev/null
-/* 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;
-}
+++ /dev/null
-/* 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;
-\f
-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);
-}
-\f
-/*
- * If this is a quasi declaration - parsed within a SPEC MODULE,
- * QUASI_FLAG is TRUE, to indicate that the variable should not
- * be initialized. The other module will do that.
- */
-tree
-generate_tasking_code_variable (name, tasking_code_ptr, quasi_flag)
- tree name, *tasking_code_ptr;
- int quasi_flag;
-{
-
- tree decl;
- tree tasking_code_name = get_tasking_code_name (name);
-
- if (pass == 2 && ! quasi_flag && *tasking_code_ptr != NULL_TREE)
- {
- /* check for value should be assigned is out of range */
- if (TREE_INT_CST_LOW (*tasking_code_ptr) >
- TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_taskingcode_type_node)))
- error ("tasking code %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
-\f
-/*
- * Transmute a process parameter list into an argument structure
- * TYPE_DECL for the start_process call to reference. Create a
- * proc_type variable for later. Returns the new struct type.
- */
-tree
-make_process_struct (name, processparlist)
- tree name, processparlist;
-{
- tree temp;
- tree a_parm;
- tree field_decls = NULL_TREE;
-
- if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK)
- return error_mark_node;
-
- if (processparlist == NULL_TREE)
- return tree_cons (NULL_TREE, NULL_TREE, void_list_node);
-
- if (TREE_CODE (processparlist) == ERROR_MARK)
- return error_mark_node;
-
- /* build list of field decls for build_chill_struct_type */
- for (a_parm = processparlist; a_parm != NULL_TREE;
- a_parm = TREE_CHAIN (a_parm))
- {
- tree parnamelist = TREE_VALUE (a_parm);
- tree purpose = TREE_PURPOSE (a_parm);
- tree mode = TREE_VALUE (purpose);
- tree parm_attr = TREE_PURPOSE (purpose);
- tree field;
-
- /* build a FIELD_DECL node */
- if (parm_attr != NULL_TREE)
- {
- if (parm_attr == ridpointers[(int)RID_LOC])
- mode = build_chill_reference_type (mode);
- else if (parm_attr == ridpointers[(int)RID_IN])
- ;
- else if (pass == 1)
- {
- for (field = parnamelist; field != NULL_TREE;
- field = TREE_CHAIN (field))
- error ("invalid attribute for argument `%s' (only IN or LOC allowed)",
- IDENTIFIER_POINTER (TREE_VALUE (field)));
- }
- }
-
- field = grok_chill_fixedfields (parnamelist, mode, NULL_TREE);
-
- /* chain the fields in reverse */
- if (field_decls == NULL_TREE)
- field_decls = field;
- else
- chainon (field_decls, field);
- }
-
- temp = build_chill_struct_type (field_decls);
- return temp;
-}
-\f
-/* Build a function for a PROCESS and define some
- types for the process arguments.
- After the PROCESS a wrapper function will be
- generated which gets the PROCESS arguments via a pointer
- to a structure having the same layout as the arguments.
- This wrapper function then will call the PROCESS.
- The advantage in doing it this way is, that PROCESS
- arguments may be displayed by gdb without any change
- to gdb.
-*/
-tree
-build_process_header (plabel, paramlist)
- tree plabel, paramlist;
-{
- tree struct_ptr_type = NULL_TREE;
- tree new_param_list = NULL_TREE;
- tree struct_decl = NULL_TREE;
- tree process_struct = NULL_TREE;
- tree struct_debug_type = NULL_TREE;
- tree code_decl;
-
- if (! global_bindings_p ())
- {
- error ("PROCESS may only be declared at module level");
- return error_mark_node;
- }
-
- if (paramlist)
- {
- /* must make the structure OUTSIDE the parameter scope */
- if (pass == 1)
- {
- process_struct = make_process_struct (plabel, paramlist);
- struct_ptr_type = build_chill_pointer_type (process_struct);
- }
- else
- {
- process_struct = NULL_TREE;
- struct_ptr_type = NULL_TREE;
- }
-
- struct_decl = push_modedef (get_struct_type_name (plabel),
- struct_ptr_type, -1);
- DECL_SOURCE_LINE (struct_decl) = 0;
- struct_debug_type = push_modedef (get_struct_debug_type_name (plabel),
- process_struct, -1);
- DECL_SOURCE_LINE (struct_debug_type) = 0;
-
- if (pass == 2)
- {
- /* build a list of PARM_DECL's */
- tree wrk = paramlist;
- tree tmp, list = NULL_TREE;
-
- while (wrk != NULL_TREE)
- {
- tree wrk1 = TREE_VALUE (wrk);
-
- while (wrk1 != NULL_TREE)
- {
- tmp = make_node (PARM_DECL);
- DECL_ASSEMBLER_NAME (tmp) = DECL_NAME (tmp) = TREE_VALUE (wrk1);
- if (list == NULL_TREE)
- new_param_list = list = tmp;
- else
- {
- TREE_CHAIN (list) = tmp;
- list = tmp;
- }
- wrk1 = TREE_CHAIN (wrk1);
- }
- wrk = TREE_CHAIN (wrk);
- }
- }
- else
- {
- /* build a list of modes */
- tree wrk = paramlist;
-
- while (wrk != NULL_TREE)
- {
- tree wrk1 = TREE_VALUE (wrk);
-
- while (wrk1 != NULL_TREE)
- {
- new_param_list = tree_cons (TREE_PURPOSE (TREE_PURPOSE (wrk)),
- TREE_VALUE (TREE_PURPOSE (wrk)),
- new_param_list);
- wrk1 = TREE_CHAIN (wrk1);
- }
- wrk = TREE_CHAIN (wrk);
- }
- new_param_list = nreverse (new_param_list);
- }
- }
-
- /* declare the code variable outside the process */
- code_decl = generate_tasking_code_variable (plabel,
- &process_type, 0);
-
- /* start the parameter scope */
- push_chill_function_context ();
-
- if (! start_chill_function (plabel, void_type_node,
- new_param_list, NULL_TREE, NULL_TREE))
- return error_mark_node;
-
- current_module->procedure_seen = 1;
- CH_DECL_PROCESS (current_function_decl) = 1;
- /* remember the code variable in the function decl */
- DECL_TASKING_CODE_DECL (current_function_decl) =
- (struct lang_decl *)code_decl;
- if (paramlist == NULL_TREE)
- /* do it here, cause we don't have a wrapper */
- add_taskstuff_to_list (code_decl, "_TT_Process", process_type,
- current_function_decl, NULL_TREE);
-
- return perm_tree_cons (code_decl, struct_decl, NULL_TREE);
-}
-\f
-/* Generate a function which gets a pointer
- to an argument block and call the corresponding
- PROCESS
-*/
-void
-build_process_wrapper (plabel, processdata)
- tree plabel;
- tree processdata;
-{
- tree args = NULL_TREE;
- tree wrapper = NULL_TREE;
- tree parammode = TREE_VALUE (processdata);
- tree code_decl = TREE_PURPOSE (processdata);
- tree func = lookup_name (plabel);
-
- /* check the mode. If it is an ERROR_MARK there was an error
- in build_process_header, if it is a NULL_TREE the process
- don't have parameters, so we must not generate a wrapper */
- if (parammode == NULL_TREE ||
- TREE_CODE (parammode) == ERROR_MARK)
- return;
-
- /* get the function name */
- wrapper = get_process_wrapper_name (plabel);
-
- /* build the argument */
- if (pass == 2)
- {
- /* build a PARM_DECL */
- args = make_node (PARM_DECL);
- DECL_ASSEMBLER_NAME (args) = DECL_NAME (args) = get_identifier ("x");
- }
- else
- {
- /* build a tree list with the mode */
- args = tree_cons (NULL_TREE,
- TREE_TYPE (parammode),
- NULL_TREE);
- }
-
- /* start the function */
- push_chill_function_context ();
-
- if (! start_chill_function (wrapper, void_type_node,
- args, NULL_TREE, NULL_TREE))
- return;
-
- /* to avoid granting */
- DECL_SOURCE_LINE (current_function_decl) = 0;
-
- if (! ignoring)
- {
- /* make the call to the PROCESS */
- tree wrk;
- tree x = lookup_name (get_identifier ("x"));
- /* no need to check this pointer to be NULL */
- tree indref = build_chill_indirect_ref (x, NULL_TREE, 0);
-
- args = NULL_TREE;
- wrk = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (x)));
- while (wrk != NULL_TREE)
- {
- args = tree_cons (NULL_TREE,
- build_component_ref (indref, DECL_NAME (wrk)),
- args);
- wrk = TREE_CHAIN (wrk);
- }
- CH_DECL_PROCESS (func) = 0;
- expand_expr_stmt (
- build_chill_function_call (func, nreverse (args)));
- CH_DECL_PROCESS (func) = 1;
- }
-
- add_taskstuff_to_list (code_decl, "_TT_Process", process_type,
- func, current_function_decl);
-
- /* finish the function */
- finish_chill_function ();
- pop_chill_function_context ();
-}
-\f
-/* Generate errors for INOUT, OUT parameters.
-
- "Only if LOC is specified may the mode have the non-value
- property"
- */
-
-#if 0
-static void
-validate_process_parameters (parms)
- tree parms ATTRIBUTE_UNUSED;
-{
-}
-#endif
-\f
-/*
- * build the tree for a start process action. Loop through the
- * actual parameters, making a constructor list, which we use to
- * initialize the argument structure. NAME is the process' name.
- * COPYNUM is its copy number, whatever that is. EXPRLIST is the
- * list of actual parameters passed by the start call. They must
- * match. EXPRLIST must still be in reverse order; we'll reverse it here.
- *
- * Note: the OPTSET name is not now used - it's here for
- * possible future support for the optional 'SET instance-var'
- * clause.
- */
-void
-build_start_process (process_name, copynum,
- exprlist, optset)
- tree process_name, copynum, exprlist, optset;
-{
- tree process_decl = 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 ();
-}
-\f
-/*
- * A CHILL SET which represents all of the possible tasking
- * elements.
- */
-static tree
-build_tasking_enum ()
-{
- tree result, decl1;
- tree enum1;
- tree list = NULL_TREE;
- tree value = integer_zero_node;
-
- enum1 = start_enum (NULL_TREE);
- result = build_enumerator (get_identifier ("_TT_UNUSED"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = build_enumerator (get_identifier ("_TT_Process"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = build_enumerator (get_identifier ("_TT_Signal"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = build_enumerator (get_identifier ("_TT_Buffer"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = build_enumerator (get_identifier ("_TT_Event"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = build_enumerator (get_identifier ("_TT_Synonym"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = build_enumerator (get_identifier ("_TT_Exception"),
- value);
- list = chainon (result, list);
- value = fold (build (PLUS_EXPR, integer_type_node,
- value, integer_one_node));
-
- result = finish_enum (enum1, list);
-
- decl1 = build_decl (TYPE_DECL,
- get_identifier ("__tmp_TaskingEnum"),
- result);
- pushdecl (decl1);
- satisfy_decl (decl1, 0);
- return decl1;
-}
-\f
-tree
-build_tasking_struct ()
-{
- tree listbase, decl1, decl2, result;
- tree enum_type = TREE_TYPE (build_tasking_enum ());
- /* We temporarily reset the maximum_field_alignment to zero so the
- compiler's init data structures can be compatible with the
- run-time system, even when we're compiling with -fpack. */
- 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;
-}
-\f
-/*
- * build data structures describing each task/signal, etc.
- * in current module.
- */
-void
-tasking_setup ()
-{
- tree tasknode;
- tree struct_type;
-
- if (pass == 1)
- return;
-
- struct_type = TREE_TYPE (lookup_name (
- get_identifier ("__tmp_TaskingStruct")));
-
- for (tasknode = tasking_list; tasknode != NULL_TREE;
- tasknode = TREE_CHAIN (tasknode))
- {
- /* This is the tasking_code_variable's decl */
- tree stuffnumber = TASK_INFO_STUFF_NUM (tasknode);
- tree code_decl = TASK_INFO_CODE_DECL (tasknode);
- tree proc_decl = TASK_INFO_PDECL (tasknode);
- tree entry = TASK_INFO_ENTRY (tasknode);
- tree name = DECL_NAME (proc_decl);
- char *init_struct = (char *) alloca (IDENTIFIER_LENGTH(name) + 20);
- /* take care of zero termination */
- tree task_name;
- /* these are the fields of the struct, in declaration order */
- tree init_flag = (stuffnumber == NULL_TREE) ?
- integer_zero_node : integer_one_node;
- tree type = DECL_INITIAL (TASK_INFO_STUFF_TYPE (tasknode));
- tree int_addr;
- tree entry_point;
- tree name_ptr;
- tree decl;
- tree struct_id;
- tree initializer;
-
- if (TREE_CODE (proc_decl) == FUNCTION_DECL
- && CH_DECL_PROCESS (proc_decl)
- && ! DECL_EXTERNAL (proc_decl))
- {
- if (entry == NULL_TREE)
- entry = proc_decl;
- mark_addressable (entry);
- entry_point = build1 (ADDR_EXPR,
- build_chill_pointer_type (void_ftype_void),
- entry);
- }
- else
- entry_point = build1 (NOP_EXPR,
- build_chill_pointer_type (void_ftype_void),
- null_pointer_node);
-
- /* take care of zero termination */
- task_name =
- build_chill_string (IDENTIFIER_LENGTH (name) + 1,
- IDENTIFIER_POINTER (name));
-
- mark_addressable (code_decl);
- int_addr = build1 (ADDR_EXPR,
- build_chill_pointer_type (chill_integer_type_node),
- code_decl);
-
- mark_addressable (task_name);
- name_ptr = build1 (ADDR_EXPR,
- build_chill_pointer_type (char_type_node),
- task_name);
-
- sprintf (init_struct, "__tmp_%s_struct",
- IDENTIFIER_POINTER (name));
-
- struct_id = get_identifier (init_struct);
- initializer = build (CONSTRUCTOR, struct_type, NULL_TREE,
- tree_cons (NULL_TREE, name_ptr,
- tree_cons (NULL_TREE, int_addr,
- tree_cons (NULL_TREE, init_flag,
- tree_cons (NULL_TREE, entry_point,
- tree_cons (NULL_TREE, type, NULL_TREE))))));
- TREE_CONSTANT (initializer) = 1;
- decl = decl_temp1 (struct_id, struct_type, 1, initializer, 0, 0);
- /* prevent granting of this type */
- DECL_SOURCE_LINE (decl) = 0;
-
- /* pass the decl to tasking_registry() in the symbol table */
- IDENTIFIER_LOCAL_VALUE (struct_id) = decl;
- }
-}
-
-
-/*
- * Generate code to register the tasking-related stuff
- * with the runtime. Only in pass 2.
- */
-void
-tasking_registry ()
-{
- tree tasknode, fn_decl;
-
- if (pass == 1)
- return;
-
- fn_decl = lookup_name (get_identifier ("__register_tasking"));
-
- for (tasknode = tasking_list; tasknode != NULL_TREE;
- tasknode = TREE_CHAIN (tasknode))
- {
- tree proc_decl = TASK_INFO_PDECL (tasknode);
- tree name = DECL_NAME (proc_decl);
- tree arg_decl;
- char *init_struct = (char *) alloca (IDENTIFIER_LENGTH (name) + 20);
-
- sprintf (init_struct, "__tmp_%s_struct",
- IDENTIFIER_POINTER (name));
- arg_decl = lookup_name (get_identifier (init_struct));
-
- expand_expr_stmt (
- build_chill_function_call (fn_decl,
- build_tree_list (NULL_TREE, force_addr_of (arg_decl))));
- }
-}
-\f
-/*
- * Put a tasking entity (a PROCESS, or SIGNAL) onto
- * the list for tasking_setup (). CODE_DECL is the integer code
- * variable's DECL, which describes the shadow integer which
- * accompanies each tasking entity. STUFFTYPE is a string
- * representing the sort of tasking entity we have here (i.e.
- * process, signal, etc.). STUFFNUMBER is an enumeration
- * value saying the same thing. PROC_DECL is the declaration of
- * the entity. It's a FUNCTION_DECL if the entity is a PROCESS, it's
- * a TYPE_DECL if the entity is a SIGNAL.
- */
-void
-add_taskstuff_to_list (code_decl, stufftype, stuffnumber,
- proc_decl, entry)
- tree code_decl;
- 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;
- }
-}
-\f
-/*
- * These next routines are called out of build_generalized_call
- */
-tree
-build_copy_number (instance_expr)
- tree instance_expr;
-{
- tree result;
-
- if (instance_expr == NULL_TREE
- || TREE_CODE (instance_expr) == ERROR_MARK)
- return error_mark_node;
- if (! CH_IS_INSTANCE_MODE (TREE_TYPE (instance_expr)))
- {
- error ("COPY_NUMBER argument must be INSTANCE expression");
- return error_mark_node;
- }
- result = build_component_ref (instance_expr,
- get_identifier (INS_COPY));
- CH_DERIVED_FLAG (result) = 1;
- return result;
-}
-
-
-tree
-build_gen_code (decl)
- tree decl;
-{
- tree result;
-
- if (decl == NULL_TREE || TREE_CODE (decl) == ERROR_MARK)
- return error_mark_node;
-
- if ((TREE_CODE (decl) == FUNCTION_DECL && CH_DECL_PROCESS (decl))
- || (TREE_CODE (decl) == TYPE_DECL && CH_DECL_SIGNAL (decl)))
- result = (tree)(DECL_TASKING_CODE_DECL (decl));
- else
- {
- error ("GEN_CODE argument must be a process or signal name");
- return error_mark_node;
- }
- CH_DERIVED_FLAG (result) = 1;
- return (result);
-}
-
-
-tree
-build_gen_inst (process, copyn)
- tree process, copyn;
-{
- tree ptype;
- tree result;
-
- if (copyn == NULL_TREE || TREE_CODE (copyn) == ERROR_MARK)
- return error_mark_node;
- if (process == NULL_TREE || TREE_CODE (process) == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_CODE (TREE_TYPE (copyn)) != INTEGER_TYPE)
- {
- error ("GEN_INST parameter 2 must be an integer mode");
- copyn = integer_zero_node;
- }
-
- copyn = check_range (copyn, copyn,
- TYPE_MIN_VALUE (chill_taskingcode_type_node),
- TYPE_MAX_VALUE (chill_taskingcode_type_node));
-
- if (TREE_CODE (process) == FUNCTION_DECL
- && CH_DECL_PROCESS (process))
- ptype = (tree)DECL_TASKING_CODE_DECL (process);
- else if (TREE_TYPE (process) != NULL_TREE
- && TREE_CODE (TREE_TYPE (process)) == INTEGER_TYPE)
- {
- process = check_range (process, process,
- TYPE_MIN_VALUE (chill_taskingcode_type_node),
- TYPE_MAX_VALUE (chill_taskingcode_type_node));
- ptype = convert (chill_taskingcode_type_node, process);
- }
- else
- {
- error ("GEN_INST parameter 1 must be a PROCESS or an integer expression");
- return (error_mark_node);
- }
-
- result = convert (instance_type_node,
- build_nt (CONSTRUCTOR, NULL_TREE,
- tree_cons (NULL_TREE, ptype,
- tree_cons (NULL_TREE,
- convert (chill_taskingcode_type_node, copyn), NULL_TREE))));
- CH_DERIVED_FLAG (result) = 1;
- return result;
-}
-
-
-tree
-build_gen_ptype (process_decl)
- tree process_decl;
-{
- tree result;
-
- if (process_decl == NULL_TREE || TREE_CODE (process_decl) == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_CODE (process_decl) != FUNCTION_DECL
- || ! CH_DECL_PROCESS (process_decl))
- {
- error_with_decl (process_decl, "%s is not a declared process");
- return error_mark_node;
- }
-
- result = (tree)DECL_TASKING_CODE_DECL (process_decl);
- CH_DERIVED_FLAG (result) = 1;
- return result;
-}
-
-
-tree
-build_proc_type (instance_expr)
- tree instance_expr;
-{
- tree result;
-
- if (instance_expr == NULL_TREE || TREE_CODE (instance_expr) == ERROR_MARK)
- return error_mark_node;
-
- if (! CH_IS_INSTANCE_MODE (TREE_TYPE (instance_expr)))
- {
- error ("PROC_TYPE argument must be INSTANCE expression");
- return error_mark_node;
- }
- result = build_component_ref (instance_expr,
- get_identifier (INS_PTYPE));
- CH_DERIVED_FLAG (result) = 1;
- return result;
-}
-
-tree
-build_queue_length (buf_ev)
- tree buf_ev;
-{
- if (buf_ev == NULL_TREE || TREE_CODE (buf_ev) == ERROR_MARK)
- return error_mark_node;
- if (TREE_TYPE (buf_ev) == NULL_TREE ||
- TREE_CODE (TREE_TYPE (buf_ev)) == ERROR_MARK)
- return error_mark_node;
-
- if (CH_IS_BUFFER_MODE (TREE_TYPE (buf_ev)) ||
- CH_IS_EVENT_MODE (TREE_TYPE (buf_ev)))
- {
- 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;
-}
-\f
-tree
-build_signal_struct_type (signame, sigmodelist, optsigdest)
- tree signame, sigmodelist, optsigdest;
-{
- tree decl, temp;
-
- if (pass == 1)
- {
- int fldcnt = 0;
- tree mode, field_decls = NULL_TREE;
-
- for (mode = sigmodelist; mode != NULL_TREE; mode = TREE_CHAIN (mode))
- {
- tree field;
- char fldname[20];
-
- if (TREE_VALUE (mode) == NULL_TREE)
- continue;
- sprintf (fldname, "fld%03d", fldcnt++);
- field = build_decl (FIELD_DECL,
- get_identifier (fldname),
- TREE_VALUE (mode));
- if (field_decls == NULL_TREE)
- field_decls = field;
- else
- chainon (field_decls, field);
- }
- if (field_decls == NULL_TREE)
- field_decls = build_decl (FIELD_DECL,
- get_identifier ("__tmp_empty"),
- boolean_type_node);
- temp = build_chill_struct_type (field_decls);
-
- /* save the destination process name of the signal */
- IDENTIFIER_SIGNAL_DEST (signame) = optsigdest;
- IDENTIFIER_SIGNAL_DATA (signame) = fldcnt;
- }
- else
- {
- /* optsigset is only valid in pass 2, so we have to save it now */
- IDENTIFIER_SIGNAL_DEST (signame) = optsigdest;
- temp = NULL_TREE; /* Actually, don't care. */
- }
-
- decl = push_modedef (signame, temp, -1);
- if (decl != NULL_TREE)
- CH_DECL_SIGNAL (decl) = 1;
- return decl;
-}
-\f
-/*
- * An instance type is a unique process identifier in the CHILL
- * tasking arena. It consists of a process type and a copy number.
- */
-void
-build_instance_type ()
-{
- tree decl1, decl2, tdecl;
-
- decl1 = build_decl (FIELD_DECL, get_identifier (INS_PTYPE),
- chill_taskingcode_type_node);
-
- TREE_CHAIN (decl1) = decl2 =
- build_decl (FIELD_DECL, get_identifier (INS_COPY),
- chill_taskingcode_type_node);
- TREE_CHAIN (decl2) = NULL_TREE;
-
- instance_type_node = build_chill_struct_type (decl1);
- tdecl = build_decl (TYPE_DECL, ridpointers[(int) RID_INSTANCE],
- instance_type_node);
- TYPE_NAME (instance_type_node) = tdecl;
- CH_NOVELTY (instance_type_node) = tdecl;
- DECL_SOURCE_LINE (tdecl) = 0;
- pushdecl (tdecl);
-
- pointer_to_instance = build_chill_pointer_type (instance_type_node);
-}
-\f
-/*
- *
- * 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;
- *
- *
- */
-
-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;
-}
-\f
-tree
-build_signal_descriptor (sigdef, exprlist)
- tree sigdef, exprlist;
-{
- tree fieldlist, typetail, valtail;
- tree actuallist = NULL_TREE;
- tree signame = DECL_NAME (sigdef);
- tree dataptr, datalen;
- int parmno = 1;
-
- if (sigdef == NULL_TREE
- || TREE_CODE (sigdef) == ERROR_MARK)
- return error_mark_node;
-
- if (exprlist != NULL_TREE
- && TREE_CODE (exprlist) == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_CODE (sigdef) != TYPE_DECL
- || ! CH_DECL_SIGNAL (sigdef))
- {
- error ("SEND requires a SIGNAL; %s is not a SIGNAL name",
- 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;
- }
- }
-}
-\f
-void
-expand_send_signal (sigmsgbuffer, optroutinginfo, optsendto,
- optpriority, signame)
- tree sigmsgbuffer;
- tree optroutinginfo;
- tree optsendto;
- tree optpriority;
- tree signame;
-{
- tree routing_size, routing_addr;
- tree filename, linenumber;
- tree sigdest = IDENTIFIER_SIGNAL_DEST (signame);
-
- /* check the presence of priority */
- if (optpriority == NULL_TREE)
- {
- if (send_signal_prio == NULL_TREE)
- {
- /* issue a warning in case of -Wall */
- if (extra_warnings)
- {
- warning ("signal sent without priority");
- warning (" and no default priority was set.");
- warning (" PRIORITY defaulted to 0");
- }
- optpriority = integer_zero_node;
- }
- else
- optpriority = send_signal_prio;
- }
-
- /* check the presence of a destination.
- optdest either may be an instance location
- or a process declaration */
- if (optsendto == NULL_TREE)
- {
- if (sigdest == NULL_TREE)
- {
- error ("SEND without a destination instance");
- error (" and no destination process specified");
- error (" for the signal");
- optsendto = convert (instance_type_node,
- null_pointer_node);
- }
- else
- {
- /* build an instance [sigdest; -1] */
- tree process_name = DECL_NAME (sigdest);
- tree copy_number = fold (build (MINUS_EXPR, integer_type_node,
- integer_zero_node,
- integer_one_node));
- tree tasking_code = (tree)DECL_TASKING_CODE_DECL (
- lookup_name (process_name));
-
- optsendto = build (CONSTRUCTOR, instance_type_node, NULL_TREE,
- tree_cons (NULL_TREE, tasking_code,
- tree_cons (NULL_TREE, copy_number, NULL_TREE)));
- /* as our system doesn't allow that and Z.200 specifies it,
- we issue a warning */
- warning ("SEND to ANY copy of process `%s'", IDENTIFIER_POINTER (process_name));
- }
- }
- else if (! CH_IS_INSTANCE_MODE (TREE_TYPE (optsendto)))
- {
- error ("SEND TO must be an INSTANCE mode");
- optsendto = convert (instance_type_node, null_pointer_node);
- }
- else
- optsendto = check_non_null (convert (instance_type_node, optsendto));
-
- /* check the routing stuff */
- if (optroutinginfo != NULL_TREE)
- {
- tree routing_name;
- tree decl;
-
- if (TREE_TYPE (optroutinginfo) == NULL_TREE)
- {
- error ("SEND WITH must have a mode");
- optroutinginfo = integer_zero_node;
- }
- routing_name = get_unique_identifier ("RI");
- decl = decl_temp1 (routing_name,
- TREE_TYPE (optroutinginfo), 0,
- optroutinginfo, 0, 0);
- /* prevent granting of this type */
- DECL_SOURCE_LINE (decl) = 0;
-
- routing_addr = force_addr_of (decl);
- routing_size = size_in_bytes (TREE_TYPE (decl));
- }
- else
- {
- routing_size = integer_zero_node;
- routing_addr = null_pointer_node;
- }
- /* get filename and linenumber */
- filename = force_addr_of (get_chill_filename ());
- linenumber = get_chill_linenumber ();
-
- /* Now (at last!) we can call the runtime */
- expand_expr_stmt (
- build_chill_function_call (lookup_name (get_identifier ("__send_signal")),
- tree_cons (NULL_TREE, sigmsgbuffer,
- tree_cons (NULL_TREE, optsendto,
- tree_cons (NULL_TREE, optpriority,
- tree_cons (NULL_TREE, routing_size,
- tree_cons (NULL_TREE, routing_addr,
- tree_cons (NULL_TREE, filename,
- tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))));
-}
-\f
-/*
- * 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:
- *
- */
-\f
-struct rc_state_type
-{
- struct rc_state_type *enclosing;
- rtx rcdoit;
- rtx rcsetup;
- tree n_sigs;
- tree sig_code;
- tree databufp;
- tree datalen;
- tree else_clause;
- tree received_signal;
- tree received_buffer;
- tree to_loc;
- int sigseen;
- int bufseen;
- tree actuallist;
- int call_generated;
- int if_generated;
- int bufcnt;
-};
-
-struct rc_state_type *current_rc_state = NULL;
-
-/*
- * this function tells if there is an if to terminate
- * or not
- */
-int
-build_receive_case_if_generated()
-{
- if (!current_rc_state)
- {
- error ("internal error: RECEIVE CASE stack invalid");
- abort ();
- }
- return current_rc_state->if_generated;
-}
-
-/* build_receive_case_start returns an INTEGER_CST node
- containing the case-label number to be used by
- build_receive_case_end to generate correct labels */
-tree
-build_receive_case_start (optset)
- tree optset;
-{
- /* counter to generate unique receive_case labels */
- static int rc_lbl_count = 0;
- tree current_label_value =
- build_int_2 ((HOST_WIDE_INT)rc_lbl_count, 0);
- tree sigcodename, filename, linenumber;
-
- struct rc_state_type *rc_state
- = (struct rc_state_type*) xmalloc (sizeof (struct rc_state_type));
- rc_state->rcdoit = gen_label_rtx ();
- rc_state->rcsetup = gen_label_rtx ();
- rc_state->enclosing = current_rc_state;
- current_rc_state = rc_state;
- rc_state->sigseen = 0;
- rc_state->bufseen = 0;
- rc_state->call_generated = 0;
- rc_state->if_generated = 0;
- rc_state->bufcnt = 0;
-
- rc_lbl_count++;
- if (optset == NULL_TREE || TREE_CODE (optset) == ERROR_MARK)
- optset = null_pointer_node;
- else
- {
- if (CH_IS_INSTANCE_MODE (TREE_TYPE (optset)) && CH_LOCATION_P (optset))
- optset = force_addr_of (optset);
- else
- {
- error ("SET requires INSTANCE location");
- optset = null_pointer_node;
- }
- }
-
- rc_state->to_loc = build_timeout_preface ();
-
- rc_state->n_sigs =
- decl_temp1 (get_identifier ("number_of_sigs"),
- integer_type_node, 0, integer_zero_node, 0, 0);
-
- rc_state->sig_code =
- decl_temp1 (get_identifier ("sig_codep"),
- ptr_type_node, 0, null_pointer_node, 0, 0);
-
- rc_state->databufp =
- decl_temp1 (get_identifier ("databufp"),
- ptr_type_node, 0, null_pointer_node, 0, 0);
-
- rc_state->datalen =
- decl_temp1 (get_identifier ("datalen"),
- integer_type_node, 0, integer_zero_node, 0, 0);
-
- rc_state->else_clause =
- decl_temp1 (get_identifier ("else_clause"),
- integer_type_node, 0, integer_zero_node, 0, 0);
-
- /* wait_signal will store the signal number in here */
- sigcodename = get_identifier ("received_signal");
- rc_state->received_signal =
- decl_temp1 (sigcodename, chill_integer_type_node, 0,
- NULL_TREE, 0, 0);
-
- /* wait_buffer will store the buffer address in here */
- sigcodename = get_unique_identifier ("received_buffer");
- rc_state->received_buffer =
- decl_temp1 (sigcodename, ptr_type_node, 0,
- NULL_TREE, 0, 0);
-
- /* now jump to the end of RECEIVE CASE actions, to
- set up variables for them. */
- emit_jump (rc_state->rcsetup);
-
- /* define the __rcdoit label. We come here after
- initialization of all variables, to execute the
- actions. */
- emit_label (rc_state->rcdoit);
-
- filename = force_addr_of (get_chill_filename ());
- linenumber = get_chill_linenumber ();
-
- /* Argument list for calling the runtime routine. We'll call it
- the first time we call build_receive_case_label, when we know
- whether to call wait_signal or wait_buffer. NOTE: at this time
- the first argument will be set. */
- rc_state->actuallist =
- tree_cons (NULL_TREE, NULL_TREE,
- tree_cons (NULL_TREE, rc_state->n_sigs,
- tree_cons (NULL_TREE, rc_state->sig_code,
- tree_cons (NULL_TREE, rc_state->databufp,
- tree_cons (NULL_TREE, rc_state->datalen,
- tree_cons (NULL_TREE, optset,
- tree_cons (NULL_TREE, rc_state->else_clause,
- tree_cons (NULL_TREE, rc_state->to_loc,
- tree_cons (NULL_TREE, filename,
- tree_cons (NULL_TREE, linenumber, NULL_TREE))))))))));
- return current_label_value;
-}
-\f
-static tree
-build_receive_signal_case_label (sigdecl, loclist)
- tree sigdecl, loclist;
-{
- struct rc_state_type *rc_state = current_rc_state;
- tree signame = DECL_NAME (sigdecl);
- tree expr;
-
- if (rc_state->bufseen != 0)
- {
- error ("SIGNAL in RECEIVE CASE alternative follows");
- error (" a BUFFER name on line %d", rc_state->bufseen);
- return error_mark_node;
- }
- rc_state->sigseen = lineno;
- rc_state->bufseen = 0;
-
- if (!IDENTIFIER_SIGNAL_DATA (signame) && loclist != NULL_TREE)
- {
- error ("SIGNAL `%s' has no data fields", IDENTIFIER_POINTER (signame));
- return error_mark_node;
- }
- if (IDENTIFIER_SIGNAL_DATA (signame) && loclist == NULL_TREE)
- {
- error ("SIGNAL `%s' requires data fields", IDENTIFIER_POINTER (signame));
- return error_mark_node;
- }
-
- if (!rc_state->call_generated)
- {
- tree wait_call;
-
- TREE_VALUE (rc_state->actuallist) = force_addr_of (rc_state->received_signal);
- wait_call = build_chill_function_call (lookup_name
- (get_identifier ("__wait_signal_timed")),
- rc_state->actuallist);
-#if 0
- chill_expand_assignment (rc_state->received_signal,
- NOP_EXPR, wait_call);
-#endif
- build_timesupervised_call (wait_call, rc_state->to_loc);
-
- rc_state->call_generated = 1;
- }
-
- /* build the conditional expression */
- expr = build (EQ_EXPR, boolean_type_node,
- rc_state->received_signal,
- (tree)DECL_TASKING_CODE_DECL (sigdecl));
-
- if (!rc_state->if_generated)
- {
- expand_start_cond (expr, 0);
- rc_state->if_generated = 1;
- }
- else
- expand_start_elseif (expr);
-
- if (IDENTIFIER_SIGNAL_DATA (signame))
- {
- /* copy data from signal buffer to user's variables */
- tree typelist = TYPE_FIELDS (TREE_TYPE (sigdecl));
- tree valtail, typetail;
- int parmno = 1;
- tree pointer_type = build_chill_pointer_type (TREE_TYPE (sigdecl));
- tree pointer = convert (pointer_type, rc_state->databufp);
-
- for (valtail = nreverse (loclist), typetail = typelist;
- valtail != NULL_TREE && typetail != NULL_TREE;
- parmno++, valtail = TREE_CHAIN (valtail),
- typetail = TREE_CHAIN (typetail))
- {
- register tree actual = valtail ? TREE_VALUE (valtail) : 0;
- register tree type = typetail ? TREE_TYPE (typetail) : 0;
- register tree assgn;
- char place[30];
- sprintf (place, "signal field %d", parmno);
-
- assgn = build_component_ref (build1 (INDIRECT_REF,
- TREE_TYPE (sigdecl),
- pointer),
- DECL_NAME (typetail));
- if (!CH_TYPE_NONVALUE_P (type))
- /* don't assign to non-value type. Error printed at signal definition */
- chill_expand_assignment (actual, NOP_EXPR, assgn);
- }
-
- if (valtail == NULL_TREE && typetail != NULL_TREE)
- error ("too few data fields provided for `%s'",
- IDENTIFIER_POINTER (signame));
- if (valtail != NULL_TREE && typetail == NULL_TREE)
- error ("too many data fields provided for `%s'",
- IDENTIFIER_POINTER (signame));
- }
-
- /* last action here */
- emit_line_note (input_filename, lineno);
-
- return build_tree_list (loclist, signame);
-}
-
-static tree
-build_receive_buffer_case_label (buffer, loclist)
- tree buffer, loclist;
-{
- struct rc_state_type *rc_state = current_rc_state;
- tree buftype = buffer_element_mode (TREE_TYPE (buffer));
- tree expr, var;
- tree pointer_type, pointer, assgn;
- int had_errors = 0;
- tree x, y, z, bufaddr;
-
- if (rc_state->sigseen != 0)
- {
- error ("BUFFER in RECEIVE CASE alternative follows");
- error (" a SIGNAL name on line %d", rc_state->sigseen);
- return error_mark_node;
- }
- rc_state->bufseen = lineno;
- rc_state->sigseen = 0;
-
- if (! CH_REFERABLE (buffer))
- {
- error ("BUFFER in RECEIVE CASE alternative must be a location");
- return error_mark_node;
- }
-
- if (TREE_CHAIN (loclist) != NULL_TREE)
- {
- error ("buffer receive alternative requires only 1 defining occurrence");
- 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 necessary, 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 occurrence in receive buffer alternative must be a location");
- had_errors = 1;
- }
-
- if (! had_errors)
- {
- pointer_type = build_chill_pointer_type (TREE_TYPE (var));
- pointer = convert (pointer_type,
- rc_state->databufp);
- /* no need to check this pointer being NULL */
- assgn = build_chill_indirect_ref (pointer, NULL_TREE, 0);
-
- chill_expand_assignment (var, NOP_EXPR, assgn);
- }
-
- /* last action here */
- emit_line_note (input_filename, lineno);
-
- return build_tree_list (loclist, buffer);
-}
-/*
- * SIGNAME is the signal name or buffer location,
- * LOCLIST is a list of possible locations to store data in
- */
-tree
-build_receive_case_label (signame, loclist)
- tree signame, loclist;
-{
- /* now see what we have got and do some checks */
- if (TREE_CODE (signame) == TYPE_DECL && CH_DECL_SIGNAL (signame))
- return build_receive_signal_case_label (signame, loclist);
-
- if (TREE_TYPE (signame) != NULL_TREE
- && CH_IS_BUFFER_MODE (TREE_TYPE (signame)))
- {
- if (loclist == NULL_TREE)
- {
- error ("buffer receive alternative without `IN location'");
- return error_mark_node;
- }
- return build_receive_buffer_case_label (signame, loclist);
- }
-
- error ("RECEIVE CASE alternative must specify a SIGNAL name or BUFFER location");
- return error_mark_node;
-}
-\f
-/*
- * LABEL_CNT is the case-label counter passed from build_receive_case_start.
- * ELSE_CLAUSE defines if the RECEIVE CASE action had an ELSE(1) or not(0).
- * BUF_LIST is a tree-list of tree-lists, where TREE_VALUE defines the
- * BUFFER location and TREE_PURPOSE defines the defining occurrence.
- */
-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);
-}
-\f
-/* build a CONTINUE action */
-
-void expand_continue_event (evloc)
- tree evloc;
-{
- tree filename, linenumber, evaddr;
-
- /* do some checks */
- if (evloc == NULL_TREE || TREE_CODE (evloc) == ERROR_MARK)
- return;
-
- if (! CH_REFERABLE (evloc) || ! CH_IS_EVENT_MODE (TREE_TYPE (evloc)))
- {
- error ("CONTINUE requires an event location");
- return;
- }
-
- evaddr = force_addr_of (evloc);
- filename = force_addr_of (get_chill_filename ());
- linenumber = get_chill_linenumber ();
-
- expand_expr_stmt (
- build_chill_function_call (lookup_name (get_identifier ("__continue")),
- tree_cons (NULL_TREE, evaddr,
- tree_cons (NULL_TREE, filename,
- tree_cons (NULL_TREE, linenumber, NULL_TREE)))));
-}
-\f
-/*
- * 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
- *
- */
-\f
-struct dl_state_type
-{
- struct dl_state_type *enclosing;
- rtx dldoit;
- rtx dlsetup;
- tree n_events;
- tree event_codes;
- tree received_event;
-};
-
-struct dl_state_type *current_dl_state = NULL;
-
-/* build_receive_case_start returns an INTEGER_CST node
- containing the case-label number to be used by
- build_receive_case_end to generate correct labels */
-tree
-build_delay_case_start (optset, optpriority)
- tree optset, optpriority;
-{
- /* counter to generate unique delay case labels */
- static int dl_lbl_count = 0;
- tree current_label_value =
- build_int_2 ((HOST_WIDE_INT)dl_lbl_count, 0);
- tree wait_call;
- tree actuallist = NULL_TREE;
- tree filename, linenumber;
- tree to_loc;
-
- struct dl_state_type *dl_state
- = (struct dl_state_type*) xmalloc (sizeof (struct dl_state_type));
- dl_state->enclosing = current_dl_state;
- current_dl_state = dl_state;
- dl_state->dldoit = gen_label_rtx ();
- dl_state->dlsetup = gen_label_rtx ();
-
- dl_lbl_count++;
-
- /* check the optional SET location */
- if (optset == NULL_TREE
- || TREE_CODE (optset) == ERROR_MARK)
- optset = null_pointer_node;
- else if (CH_IS_INSTANCE_MODE (TREE_TYPE (optset)) && CH_LOCATION_P (optset))
- optset = force_addr_of (optset);
- else
- {
- error ("SET requires INSTANCE location");
- optset = null_pointer_node;
- }
-
- /* check the presence of the PRIORITY expression */
- if (optpriority == NULL_TREE)
- optpriority = integer_zero_node;
- else if (TREE_CODE (optpriority) == ERROR_MARK)
- optpriority = integer_zero_node;
- else if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE)
- {
- error ("PRIORITY must be of integer type");
- optpriority = integer_zero_node;
- }
-
- /* check for time supervised */
- to_loc = build_timeout_preface ();
-
- dl_state->n_events =
- decl_temp1 (get_identifier ("number_of_events"),
- integer_type_node, 0, integer_zero_node, 0, 0);
-
- dl_state->event_codes =
- decl_temp1 (get_identifier ("event_codes"),
- ptr_type_node, 0, null_pointer_node, 0, 0);
-
- /* wait_event will store the signal number in here */
- dl_state->received_event =
- decl_temp1 (get_identifier ("received_event"),
- ptr_type_node, 0, NULL_TREE, 0, 0);
-
- /* now jump to the end of RECEIVE CASE actions, to
- set up variables for them. */
- emit_jump (dl_state->dlsetup);
-
- /* define the __rcdoit label. We come here after
- initialization of all variables, to execute the
- actions. */
- emit_label (dl_state->dldoit);
-
- filename = force_addr_of (get_chill_filename ());
- linenumber = get_chill_linenumber ();
-
- /* here we go, call the runtime routine */
- actuallist = tree_cons (NULL_TREE, force_addr_of (dl_state->received_event),
- tree_cons (NULL_TREE, dl_state->n_events,
- tree_cons (NULL_TREE, dl_state->event_codes,
- tree_cons (NULL_TREE, optpriority,
- tree_cons (NULL_TREE, to_loc,
- tree_cons (NULL_TREE, optset,
- tree_cons (NULL_TREE, filename,
- tree_cons (NULL_TREE, linenumber, NULL_TREE))))))));
-
- wait_call = build_chill_function_call (
- lookup_name (get_identifier ("__delay_event")),
- actuallist);
-
-#if 0
- chill_expand_assignment (dl_state->received_event, NOP_EXPR, wait_call);
-#endif
- build_timesupervised_call (wait_call, to_loc);
- return current_label_value;
-}
-\f
-/*
- EVENTLIST is the list of this alternative's events
- and IF_OR_ELSEIF indicates what action (1 for if and
- 0 for else if) should be generated.
-*/
-void
-build_delay_case_label (eventlist, if_or_elseif)
- tree eventlist;
- int if_or_elseif;
-{
- tree eventp, expr = NULL_TREE;
-
- if (eventlist == NULL_TREE || TREE_CODE (eventlist) == ERROR_MARK)
- return;
-
- for (eventp = eventlist; eventp != NULL_TREE;
- eventp = TREE_CHAIN (eventp))
- {
- tree event = TREE_VALUE (eventp);
- tree temp1;
-
- if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK)
- temp1 = null_pointer_node;
- else if (! CH_IS_EVENT_MODE (TREE_TYPE (event)) || ! CH_REFERABLE (event))
- {
- error ("delay alternative must be an EVENT location");
- temp1 = null_pointer_node;
- }
- else
- temp1 = force_addr_of (event);
-
- /* build the conditional expression */
- if (expr == NULL_TREE)
- expr = build (EQ_EXPR, boolean_type_node,
- current_dl_state->received_event, temp1);
- else
- expr =
- build (TRUTH_ORIF_EXPR, boolean_type_node, expr,
- build (EQ_EXPR, boolean_type_node,
- current_dl_state->received_event, temp1));
- }
- if (if_or_elseif)
- expand_start_cond (expr, 0);
- else
- expand_start_elseif (expr);
-
- /* last action here */
- emit_line_note (input_filename, lineno);
-}
-\f
-/*
- * EVENT_LIST is a tree list. The TREE_VALUEs are VAR_DECLs of
- * EVENT variables. LABEL_CNT is the case-label counter
- * passed from build_delay_case_start.
- */
-void
-build_delay_case_end (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);
-}
-\f
-/*
- * 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
- */
-void
-build_delay_action (event, optpriority)
- tree event, optpriority;
-{
- int had_errors = 0;
- tree to_loc = NULL_TREE;
- /* we discard the return value of __delay_event, cause in
- a normal DELAY action no selections have to be made */
- tree ev_got = null_pointer_node;
-
- /* check the event */
- if (event == NULL_TREE || TREE_CODE (event) == ERROR_MARK)
- had_errors = 1;
- else if (! CH_IS_EVENT_MODE (TREE_TYPE (event)) || ! CH_REFERABLE (event))
- {
- error ("DELAY action requires an event location");
- had_errors = 1;
- }
-
- /* check the presence of priority */
- if (optpriority != NULL_TREE)
- {
- if (TREE_CODE (optpriority) == ERROR_MARK)
- return;
- if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE)
- {
- error ("PRIORITY in DELAY action must be of integer type");
- return;
- }
- }
- else
- {
- /* issue a warning in case of -Wall */
- if (extra_warnings)
- {
- warning ("DELAY action without priority.");
- warning (" PRIORITY defaulted to 0");
- }
- optpriority = integer_zero_node;
- }
- if (had_errors)
- return;
-
- {
- tree descr_type;
- tree array_type_node;
- tree array_decl;
- tree descr_init;
- tree array_init;
- tree event_length = max_queue_size (TREE_TYPE (event));
- tree event_codes;
- tree filename = force_addr_of (get_chill_filename ());
- tree linenumber = get_chill_linenumber ();
- tree actuallist;
-
- to_loc = build_timeout_preface ();
-
- descr_type = TREE_TYPE (lookup_name (get_identifier ("__tmp_DESCR_type")));
-
- array_type_node =
- build_chill_array_type (descr_type,
- tree_cons (NULL_TREE,
- build_chill_range_type (NULL_TREE, integer_one_node,
- integer_one_node),
- NULL_TREE),
- 0, NULL_TREE);
- if (event_length == NULL_TREE)
- event_length = infinite_buffer_event_length_node;
-
- descr_init =
- tree_cons (NULL_TREE, force_addr_of (event),
- tree_cons (NULL_TREE, event_length, NULL_TREE));
- array_init =
- tree_cons (NULL_TREE,
- build_nt (CONSTRUCTOR, NULL_TREE, descr_init),
- NULL_TREE);
- array_decl =
- decl_temp1 (get_unique_identifier ("event_codes_array"),
- array_type_node, 0,
- build_nt (CONSTRUCTOR, NULL_TREE, array_init),
- 0, 0);
-
- event_codes =
- decl_temp1 (get_unique_identifier ("event_ptr"),
- ptr_type_node, 0,
- force_addr_of (array_decl),
- 0, 0);
-
- actuallist =
- tree_cons (NULL_TREE, ev_got,
- tree_cons (NULL_TREE, integer_one_node,
- tree_cons (NULL_TREE, event_codes,
- tree_cons (NULL_TREE, optpriority,
- tree_cons (NULL_TREE, to_loc,
- tree_cons (NULL_TREE, null_pointer_node,
- tree_cons (NULL_TREE, filename,
- tree_cons (NULL_TREE, linenumber, NULL_TREE))))))));
-
-
- build_timesupervised_call (
- build_chill_function_call (
- lookup_name (get_identifier ("__delay_event")),
- actuallist), to_loc);
- }
-}
-\f
-void
-expand_send_buffer (buffer, value, optpriority, optwith, optto)
- tree buffer, value, optpriority, optwith, optto;
-{
- tree filename, linenumber;
- tree buffer_mode_decl = NULL_TREE;
- tree buffer_ptr, value_ptr;
- int had_errors = 0;
- tree timeout_value, fcall;
-
- /* check buffer location */
- if (buffer == NULL_TREE || TREE_CODE (buffer) == ERROR_MARK)
- {
- buffer = NULL_TREE;
- had_errors = 1;
- }
- if (buffer != NULL_TREE)
- {
- if (! CH_IS_BUFFER_MODE (TREE_TYPE (buffer)) || ! CH_REFERABLE (buffer))
- {
- error ("send buffer action requires a BUFFER location");
- had_errors = 1;
- }
- else
- buffer_mode_decl = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (buffer)));
- }
-
- /* check value and type */
- if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK)
- {
- had_errors = 1;
- value = NULL_TREE;
- }
- if (value != NULL_TREE)
- {
- if (TREE_CHAIN (value) != NULL_TREE)
- {
- error ("there must be only 1 value for send buffer action");
- had_errors = 1;
- }
- else
- {
- value = TREE_VALUE (value);
- if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK)
- {
- had_errors = 1;
- value = NULL_TREE;
- }
- if (value != NULL_TREE && buffer_mode_decl != NULL_TREE)
- {
- if (TREE_TYPE (buffer_mode_decl) != NULL_TREE &&
- TREE_CODE (TREE_TYPE (buffer_mode_decl)) == ERROR_MARK)
- had_errors = 1;
- else if (CH_COMPATIBLE (value, TREE_TYPE (buffer_mode_decl)))
- {
- value = convert (TREE_TYPE (buffer_mode_decl), value);
- if (value == NULL_TREE || TREE_CODE (value) == ERROR_MARK)
- {
- error ("convert failed for send buffer action");
- had_errors = 1;
- }
- }
- else
- {
- error ("incompatible modes in send buffer action");
- had_errors = 1;
- }
- }
- }
- }
-
- /* check the presence of priority */
- if (optpriority == NULL_TREE)
- {
- if (send_buffer_prio == NULL_TREE)
- {
- /* issue a warning in case of -Wall */
- if (extra_warnings)
- {
- warning ("buffer sent without priority");
- warning (" and no default priority was set.");
- warning (" PRIORITY defaulted to 0");
- }
- optpriority = integer_zero_node;
- }
- else
- optpriority = send_buffer_prio;
- }
- else if (TREE_CODE (optpriority) == ERROR_MARK)
- had_errors = 1;
- else if (TREE_CODE (TREE_TYPE (optpriority)) != INTEGER_TYPE)
- {
- error ("PRIORITY must be of integer type");
- had_errors = 1;
- }
-
- if (optwith != NULL_TREE)
- {
- error ("WITH not allowed for send buffer action");
- had_errors = 1;
- }
- if (optto != NULL_TREE)
- {
- error ("TO not allowed for send buffer action");
- had_errors = 1;
- }
- if (had_errors)
- return;
-
- {
- tree descr_type;
- tree buffer_descr, buffer_init, buffer_length;
- tree val;
-
- /* process timeout */
- timeout_value = build_timeout_preface ();
-
- descr_type = lookup_name (get_identifier ("__tmp_DESCR_type"));
-
- /* build descr for buffer */
- buffer_length = max_queue_size (TREE_TYPE (buffer));
- if (buffer_length == NULL_TREE)
- buffer_length = infinite_buffer_event_length_node;
- buffer_init = build_nt (CONSTRUCTOR, NULL_TREE,
- tree_cons (NULL_TREE, force_addr_of (buffer),
- tree_cons (NULL_TREE, buffer_length, NULL_TREE)));
- buffer_descr = decl_temp1 (get_unique_identifier ("buffer_descr"),
- TREE_TYPE (descr_type), 0, buffer_init,
- 0, 0);
- buffer_ptr = decl_temp1 (get_unique_identifier ("buffer_ptr"),
- ptr_type_node, 0,
- force_addr_of (buffer_descr),
- 0, 0);
-
- /* build descr for value */
- if (! CH_REFERABLE (value))
- val = decl_temp1 (get_identifier ("buffer_value"),
- TREE_TYPE (value), 0,
- value, 0, 0);
- else
- val = value;
-
- value_ptr = build_chill_descr (val);
-
- }
-
- /* get filename and linenumber */
- filename = force_addr_of (get_chill_filename ());
- linenumber = get_chill_linenumber ();
-
- /* Now, we can call the runtime */
- fcall = build_chill_function_call (
- lookup_name (get_identifier ("__send_buffer")),
- tree_cons (NULL_TREE, buffer_ptr,
- tree_cons (NULL_TREE, value_ptr,
- tree_cons (NULL_TREE, optpriority,
- tree_cons (NULL_TREE, timeout_value,
- tree_cons (NULL_TREE, filename,
- tree_cons (NULL_TREE, linenumber, NULL_TREE)))))));
- build_timesupervised_call (fcall, timeout_value);
-}
-# if 0
-\f
-void
-process_buffer_decls (namelist, mode, optstatic)
- tree namelist, mode;
- int optstatic;
-{
- tree names;
- int quasi_flag = current_module->is_spec_module;
-
- if (pass < 2)
- return;
-
- for (names = namelist; names != NULL_TREE; names = TREE_CHAIN (names))
- {
- tree name = TREE_VALUE (names);
- tree bufdecl = lookup_name (name);
- tree code_decl =
- decl_tasking_code_variable (name, &buffer_code, quasi_flag);
-
- /* remember the code variable in the buffer decl */
- DECL_TASKING_CODE_DECL (bufdecl) = (struct lang_decl *)code_decl;
-
- add_taskstuff_to_list (code_decl, "_TT_Buffer",
- quasi_flag ? NULL_TREE : buffer_code,
- bufdecl);
- }
-}
-#endif
-\f
-/*
- * if no queue size was specified, QUEUESIZE is integer_zero_node.
- */
-tree
-build_buffer_type (element_type, queuesize)
- tree element_type, queuesize;
-{
- tree type, field;
- if (element_type == NULL_TREE || TREE_CODE (element_type) == ERROR_MARK)
- return error_mark_node;
- if (queuesize != NULL_TREE && TREE_CODE (queuesize) == ERROR_MARK)
- return error_mark_node;
-
- type = make_node (RECORD_TYPE);
- field = build_decl (FIELD_DECL, get_identifier("__buffer_data"),
- ptr_type_node);
- TYPE_FIELDS (type) = field;
- TREE_CHAIN (field)
- = build_lang_decl (TYPE_DECL, get_identifier ("__element_mode"),
- element_type);
- field = TREE_CHAIN (field);
- if (queuesize)
- {
- tree size_field = build_decl (CONST_DECL, get_identifier("__queue_max"),
- integer_type_node);
- DECL_INITIAL (size_field) = queuesize;
- TREE_CHAIN (field) = size_field;
- }
- CH_IS_BUFFER_MODE (type) = 1;
- CH_TYPE_NONVALUE_P (type) = 1;
- if (pass == 2)
- type = layout_chill_struct_type (type);
- return type;
-}
-\f
-#if 0
-tree
-build_buffer_descriptor (bufname, expr, optpriority)
- tree bufname, expr, optpriority;
-{
- tree bufdecl;
-
- if (bufname == NULL_TREE
- || TREE_CODE (bufname) == ERROR_MARK)
- return error_mark_node;
-
- if (expr != NULL_TREE
- && TREE_CODE (expr) == ERROR_MARK)
- return error_mark_node;
-#if 0
-/* FIXME: is this what we really want to test? */
- bufdecl = lookup_name (bufname);
- if (TREE_CODE (bufdecl) != TYPE_DECL
- || ! CH_IS_BUFFER_MODE (TREE_TYPE (bufdecl)))
- {
- error ("SEND requires a BUFFER; `%s' is not a BUFFER name",
- bufname);
- return error_mark_node;
- }
-#endif
- {
- /* build buffer/signal data structure */
- tree bufdataname = get_unique_identifier (IDENTIFIER_POINTER (bufname));
- tree dataptr;
-
- if (expr == NULL_TREE)
- dataptr = null_pointer_node;
- else
- {
- tree decl =
- decl_temp1 (bufdataname, TREE_TYPE (bufdecl), 0,
- expr, 0, 0);
- /* prevent granting of this variable */
- DECL_SOURCE_LINE (decl) = 0;
-
- dataptr = force_addr_of (decl);
- }
-
- /* build descriptor pointing to buffer data */
- {
- tree tasking_message_var = get_unique_identifier (IDENTIFIER_POINTER (bufname));
- tree data_len = (expr == NULL_TREE) ? integer_zero_node :
- size_in_bytes (TREE_TYPE (bufdecl));
- tree tasking_code = (tree)DECL_TASKING_CODE_DECL (bufdecl);
- tree tuple = build_nt (CONSTRUCTOR, NULL_TREE,
- tree_cons (NULL_TREE,
- build1 (ADDR_EXPR,
- build_chill_pointer_type (chill_integer_type_node),
- tasking_code),
- tree_cons (NULL_TREE, data_len,
- tree_cons (NULL_TREE, dataptr, NULL_TREE))));
-
- tree decl = decl_temp1 (tasking_message_var,
- TREE_TYPE (tasking_message_type), 0,
- tuple, 0, 0);
- mark_addressable (tasking_code);
- /* prevent granting of this variable */
- DECL_SOURCE_LINE (decl) = 0;
-
- tuple = force_addr_of (decl);
- return tuple;
- }
- }
-}
-#endif
-\f
-#if 0
-void
-process_event_decls (namelist, mode, optstatic)
- tree namelist, mode;
- int optstatic;
-{
- tree names;
- int quasi_flag = current_module->is_spec_module;
-
- if (pass < 2)
- return;
-
- for (names = namelist; names != NULL_TREE; names = TREE_CHAIN (names))
- {
- tree name = TREE_VALUE (names);
- tree eventdecl = lookup_name (name);
- tree code_decl =
- decl_tasking_code_variable (name, &event_code, quasi_flag);
-
- /* remember the code variable in the event decl */
- DECL_TASKING_CODE_DECL (eventdecl) = (struct lang_decl *)code_decl;
-
- add_taskstuff_to_list (code_decl, "_TT_Event",
- quasi_flag ? NULL_TREE : event_code,
- eventdecl);
- }
-}
-#endif
-\f
-/* Return the buffer or event length of a buffer or event mode.
- (NULL_TREE means unlimited.) */
-
-tree
-max_queue_size (mode)
- tree mode;
-{
- tree field = TYPE_FIELDS (mode);
- for ( ; field != NULL_TREE ; field = TREE_CHAIN (field))
- {
- if (TREE_CODE (field) == CONST_DECL)
- return DECL_INITIAL (field);
- }
- return NULL_TREE;
-}
-
-/* Return the buffer element mode of a buffer mode. */
-
-tree
-buffer_element_mode (bufmode)
- tree bufmode;
-{
- tree field = TYPE_FIELDS (bufmode);
- for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
- {
- if (TREE_CODE (field) == TYPE_DECL)
- return TREE_TYPE (field);
- }
- return NULL_TREE;
-}
-
-/* invalidate buffer element mode in case we detect, that the
- elelment mode has the non-value property */
-
-void
-invalidate_buffer_element_mode (bufmode)
- tree bufmode;
-{
- tree field = TYPE_FIELDS (bufmode);
- for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
- {
- if (TREE_CODE (field) == TYPE_DECL)
- {
- TREE_TYPE (field) = error_mark_node;
- return;
- }
- }
-}
-
-/* For an EVENT or BUFFER mode TYPE, with a give maximum queue size QSIZE,
- perform various error checks. Return a new queue size. */
-
-tree
-check_queue_size (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;
-}
-\f
-/*
- * Initialize the various types of tasking data.
- */
-void
-tasking_init ()
-{
- extern int ignore_case;
- extern int special_UC;
- extern tree chill_predefined_function_type;
- tree temp, ins_ftype_void;
- tree endlink = void_list_node;
- tree int_ftype_ptr_int_ptr_ptr_int_ptr_int_ptr_ptr_int;
- tree void_ftype_ptr;
- tree void_ftype_ptr_ins_int_int_ptr_ptr_int;
- tree int_ftype_ptr_ptr_int_ptr_ptr_int;
- tree void_ftype_int_int_int_ptr_ptr_ptr_int;
- tree int_ftype_ptr_int_ptr_int_ptr_ptr_ptr_int;
- tree int_ftype_ptr_int;
-
- /* type of tasking code variables */
- chill_taskingcode_type_node = short_unsigned_type_node;
-
- void_ftype_void =
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, void_type_node, NULL_TREE));
-
- build_instance_type ();
- ins_ftype_void
- = build_function_type (instance_type_node,
- tree_cons (NULL_TREE, void_type_node,
- build_tree_list (NULL_TREE, void_type_node)));
-
- builtin_function ("__whoami", ins_ftype_void,
- 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;
-}
+++ /dev/null
-/* 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 GCC_TASKING_H
-#define GCC_TASKING_H
-
-/* list of this module's process, buffer, etc. decls */
-extern tree tasking_list;
-
-#endif /* ! GCC_TASKING_H */
+++ /dev/null
-/* 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);
-}
-
-/*
- *
- * 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
- *
- */
-
-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);
-}
-
-/*
- *
- * 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;
- * }
- *
- */
-
-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));
-}
-
-/*
- *
- * 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:
- * }
- *
- */
-
-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 ();
- }
-}
+++ /dev/null
-/* 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"
-
-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));
-\f
-/* 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;
-}
-\f
-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);
-}
+++ /dev/null
-/* 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 *));
-\f
-/*
- * This function checks an array access.
- * It calls error (ERROR_MESSAGE) if the condition (index <= domain max value
- * index >= domain min value)
- * is not met at compile time,
- * If a runtime test is required and permitted,
- * check_expression is used to do so.
- * the global RANGE_CHECKING flags controls the
- * generation of runtime checking code.
- */
-tree
-valid_array_index_p (array, idx, error_message, is_varying_lhs)
- tree array, idx;
- 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 */
-}
-\f
-/*
- * Extract a slice from an array, which could look like a
- * SET_TYPE if it's a bitstring. The array could also be VARYING
- * if the element type is CHAR. The min_value and length values
- * must have already been checked with valid_array_index_p. No
- * checking is done here.
- */
-tree
-build_chill_slice (array, min_value, length)
- tree array, min_value, length;
-{
- tree result;
- tree array_type = TREE_TYPE (array);
-
- if (!CH_REFERABLE (array) && TREE_CODE (array) != SAVE_EXPR
- && (TREE_CODE (array) != COMPONENT_REF
- || TREE_CODE (TREE_OPERAND (array, 0)) != SAVE_EXPR))
- {
- if (!TREE_CONSTANT (array))
- warning ("possible internal error - slice argument is neither referable nor constant");
- else
- {
- /* Force to storage.
- NOTE: This could mean multiple identical copies of
- the same constant. FIXME. */
- tree mydecl = decl_temp1 (get_unique_identifier("SLICEE"),
- array_type, 1, array, 0, 0);
- TREE_READONLY (mydecl) = 1;
- /* mark_addressable (mydecl); FIXME: necessary? */
- array = mydecl;
- }
- }
-
- /*
- The code-generation which uses a slice tree needs not only to
- know the dynamic upper and lower limits of that slice, but the
- original static allocation, to use to build temps where one or both
- of the dynamic limits must be calculated at runtime.. We pass the
- dynamic size by building a new array_type whose limits are the
- min_value and min_value + length values passed to us.
-
- The static allocation info is passed by using the parent array's
- limits to compute a temp_size, which is passed in the lang_specific
- field of the slice_type. */
-
- if (TREE_CODE (array_type) == ARRAY_TYPE)
- {
- tree domain_type = TYPE_DOMAIN (array_type);
- tree 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;
- }
-}
-\f
-static tree
-build_empty_string (type)
- tree type;
-{
- int orig_pass = pass;
- tree range, result;
-
- range = build_chill_range_type (type, integer_zero_node,
- integer_minus_one_node);
- result = build_chill_array_type (type,
- tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE);
- pass = 2;
- range = build_chill_range_type (type, integer_zero_node,
- integer_minus_one_node);
- result = build_chill_array_type (type,
- tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE);
- pass = orig_pass;
-
- return decl_temp1 (get_unique_identifier ("EMPTY_STRING"),
- result, 0, NULL_TREE, 0, 0);
-}
-\f
-/* We build the runtime range-checking as a separate list
- * rather than making a compound_expr with min_value
- * (for example), to control when that comparison gets
- * generated. We cannot allow it in a TYPE_MAX_VALUE or
- * TYPE_MIN_VALUE expression, for instance, because that code
- * will get generated when the slice is laid out, which would
- * put it outside the scope of an exception handler for the
- * statement we're generating. I.e. we would be generating
- * cause_exception calls which might execute before the
- * necessary ch_link_handler call.
- */
-tree
-build_chill_slice_with_range (array, min_value, max_value)
- tree array, min_value, max_value;
-{
- if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
- || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK
- || max_value == NULL_TREE || TREE_CODE(max_value) == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_TYPE (array) == NULL_TREE
- || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE
- && TREE_CODE (TREE_TYPE (array)) != SET_TYPE
- && !chill_varying_type_p (TREE_TYPE (array))))
- {
- error ("can only take slice of array or string");
- return error_mark_node;
- }
-
- array = save_if_needed (array);
-
- /* FIXME: test here for max_value >= min_value, except
- for max_value == -1, min_value == 0 (empty string) */
- min_value = valid_array_index_p (array, min_value,
- "slice lower limit out-of-range", 0);
- if (TREE_CODE (min_value) == ERROR_MARK)
- return min_value;
-
- /* FIXME: suppress this test if max_value is the LENGTH of a
- varying array, which has presumably already been checked. */
- max_value = valid_array_index_p (array, max_value,
- "slice upper limit out-of-range", 0);
- if (TREE_CODE (max_value) == ERROR_MARK)
- return error_mark_node;
-
- if (TREE_CODE (min_value) == INTEGER_CST
- && TREE_CODE (max_value) == INTEGER_CST
- && tree_int_cst_lt (max_value, min_value))
- return build_empty_string (TREE_TYPE (TREE_TYPE (array)));
-
- return
- build_chill_slice
- (array, min_value,
- save_expr (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);
-}
-\f
-tree
-build_chill_array_ref (array, indexlist)
- tree array, indexlist;
-{
- tree idx;
-
- if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK)
- return error_mark_node;
- if (indexlist == NULL_TREE || TREE_CODE (indexlist) == ERROR_MARK)
- return error_mark_node;
-
- idx = TREE_VALUE (indexlist); /* handle first index */
-
- idx = valid_array_index_p (array, idx,
- "array index out-of-range", 0);
- if (TREE_CODE (idx) == ERROR_MARK)
- return error_mark_node;
-
- array = build_chill_array_ref_1 (array, idx);
-
- if (array && TREE_CODE (array) != ERROR_MARK
- && TREE_CHAIN (indexlist))
- {
- /* Z.200 (1988) section 4.2.8 says that:
- <array> '(' <expression {',' <expression> }* ')'
- is derived syntax (i.e. syntactic sugar) for:
- <array> '(' <expression ')' { '(' <expression> ')' }*
- The intent is clear if <array> has mode: ARRAY (...) ARRAY (...) XXX.
- But what if <array> has mode: ARRAY (...) CHARS (N)
- or: ARRAY (...) BOOLS (N).
- Z.200 doesn't explicitly prohibit it, but the intent is unclear.
- We'll allow it, since it seems reasonable and useful.
- However, we won't allow it if <array> is:
- ARRAY (...) PROC (...).
- (The latter would make sense if we allowed general
- Currying, which Chill doesn't.) */
- if (TREE_CODE (TREE_TYPE (array)) == ARRAY_TYPE
- || chill_varying_type_p (TREE_TYPE (array))
- || CH_BOOLS_TYPE_P (TREE_TYPE (array)))
- array = build_generalized_call (array, TREE_CHAIN (indexlist));
- else
- error ("too many index expressions");
- }
- return array;
-}
-
-/*
- * Don't error check the index in here. It's supposed to be
- * checked by the caller.
- */
-tree
-build_chill_array_ref_1 (array, idx)
- tree array, idx;
-{
- tree type;
- tree domain;
- tree rval;
-
- if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
- || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK)
- return error_mark_node;
-
- if (chill_varying_type_p (TREE_TYPE (array)))
- array = varying_to_slice (array);
-
- domain = TYPE_DOMAIN (TREE_TYPE (array));
-
-#if 0
- if (! integer_zerop (TYPE_MIN_VALUE (domain)))
- {
- /* The C part of the compiler doesn't understand how to do
- arithmetic with dissimilar enum types. So we check compatibility
- 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);
-}
-\f
-tree
-build_chill_bitref (bitstring, indexlist)
- tree bitstring, indexlist;
-{
- if (TREE_CODE (bitstring) == ERROR_MARK)
- return bitstring;
- if (TREE_CODE (indexlist) == ERROR_MARK)
- return indexlist;
-
- if (TREE_CHAIN (indexlist) != NULL_TREE)
- {
- error ("invalid compound index for bitstring mode");
- return error_mark_node;
- }
-
- if (TREE_CODE (indexlist) == TREE_LIST)
- {
- tree result = build (SET_IN_EXPR, boolean_type_node,
- TREE_VALUE (indexlist), bitstring);
- TREE_READONLY (result) = TREE_READONLY (bitstring);
- return result;
- }
- else abort ();
-}
-
-\f
-int
-discrete_type_p (type)
- tree type;
-{
- return INTEGRAL_TYPE_P (type);
-}
-
-/* Checks that EXP has discrete type, or can be converted to discrete.
- Otherwise, returns NULL_TREE.
- Normally returns the (possibly-converted) EXP. */
-
-tree
-convert_to_discrete (exp)
- tree exp;
-{
- if (! discrete_type_p (TREE_TYPE (exp)))
- {
- if (flag_old_strings)
- {
- if (CH_CHARS_ONE_P (TREE_TYPE (exp)))
- return convert (char_type_node, exp);
- if (CH_BOOLS_ONE_P (TREE_TYPE (exp)))
- return convert (boolean_type_node, exp);
- }
- return NULL_TREE;
- }
- return exp;
-}
-\f
-/* Write into BUFFER the target-machine representation of VALUE.
- Returns 1 on success, or 0 on failure. (Either the VALUE was
- not constant, or we don't know how to do the conversion.) */
-
-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 necessary ??? */
- /* 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;
-}
-\f
-/* Given a set_type, build an integer array from it that C will grok. */
-
-tree
-build_array_from_set (type)
- tree type;
-{
- tree bytespint, bit_array_size, int_array_count;
-
- if (type == NULL_TREE || type == error_mark_node
- || TREE_CODE (type) != SET_TYPE)
- return error_mark_node;
-
- /* ??? 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;
-}
-\f
-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;
- }
-}
-\f
-/* This function classifies an expr into the Null class,
- the All class, the M-Value, the M-derived, or the M-reference class.
- It probably has some inaccuracies. */
-
-struct ch_class
-chill_expr_class (expr)
- tree expr;
-{
- struct ch_class class;
- /* The Null class contains the NULL pointer constant (only). */
- if (expr == null_pointer_node)
- {
- class.kind = CH_NULL_CLASS;
- class.mode = NULL_TREE;
- return class;
- }
-
- /* The All class contains the <undefined value> "*". */
- if (TREE_CODE (expr) == UNDEFINED_EXPR)
- {
- class.kind = CH_ALL_CLASS;
- class.mode = NULL_TREE;
- return class;
- }
-
- if (CH_DERIVED_FLAG (expr))
- {
- class.kind = CH_DERIVED_CLASS;
- class.mode = TREE_TYPE (expr);
- return class;
- }
-
- /* The M-Reference contains <references location> (address-of) expressions.
- Note that something that's been converted to a reference doesn't count. */
- if (TREE_CODE (expr) == ADDR_EXPR
- && TREE_CODE (TREE_TYPE (expr)) != REFERENCE_TYPE)
- {
- class.kind = CH_REFERENCE_CLASS;
- class.mode = TREE_TYPE (TREE_TYPE (expr));
- return class;
- }
-
- /* The M-Value class contains expressions with a known, specific mode M. */
- class.kind = CH_VALUE_CLASS;
- class.mode = TREE_TYPE (expr);
- return class;
-}
-
-/* Returns >= 1 iff REF is a location. Return 2 if it is referable. */
-
-int chill_location (ref)
- tree ref;
-{
- register enum tree_code code = TREE_CODE (ref);
-
- switch (code)
- {
- case REALPART_EXPR:
- case IMAGPART_EXPR:
- case ARRAY_REF:
- case PACKED_ARRAY_REF:
- case COMPONENT_REF:
- case NOP_EXPR: /* RETYPE_EXPR */
- return chill_location (TREE_OPERAND (ref, 0));
- case COMPOUND_EXPR:
- return chill_location (TREE_OPERAND (ref, 1));
-
- case BIT_FIELD_REF:
- case SLICE_EXPR:
- /* A bit-string slice is nor referable. */
- return chill_location (TREE_OPERAND (ref, 0)) == 0 ? 0 : 1;
-
- case CONSTRUCTOR:
- case STRING_CST:
- return 0;
-
- case INDIRECT_REF:
- case VAR_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- case ERROR_MARK:
- if (TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE
- && TREE_CODE (TREE_TYPE (ref)) != METHOD_TYPE)
- return 2;
- break;
-
- default:
- break;
- }
- return 0;
-}
-
-int
-chill_referable (val)
- tree val;
-{
- return chill_location (val) > 1;
-}
-
-/* Make a copy of MODE, but with the given NOVELTY. */
-
-tree
-copy_novelty (novelty, mode)
- tree novelty, mode;
-{
- if (CH_NOVELTY (mode) != novelty)
- {
- mode = copy_node (mode);
- TYPE_MAIN_VARIANT (mode) = mode;
- TYPE_NEXT_VARIANT (mode) = 0;
- TYPE_POINTER_TO (mode) = 0;
- TYPE_REFERENCE_TO (mode) = 0;
- SET_CH_NOVELTY (mode, novelty);
- }
- return mode;
-}
-
-
-struct mode_chain
-{
- struct mode_chain *prev;
- tree mode1, mode2;
-};
-
-/* Tests if MODE1 and MODE2 are SIMILAR.
- This is more or less as defined in the Blue Book, though
- see FIXME for parts that are unfinished.
- CHAIN is used to catch infinite recursion: It is a list of pairs
- of mode arguments to calls to chill_similar "outer" to this call. */
-
-int
-chill_similar (mode1, mode2, chain)
- tree mode1, mode2;
- struct mode_chain *chain;
-{
- int varying1, varying2;
- tree t1, t2;
- struct mode_chain *link, node;
- if (mode1 == NULL_TREE || mode2 == NULL_TREE)
- return 0;
-
- while (TREE_CODE (mode1) == REFERENCE_TYPE)
- mode1 = TREE_TYPE (mode1);
- while (TREE_CODE (mode2) == REFERENCE_TYPE)
- mode2 = TREE_TYPE (mode2);
-
- /* Range modes are similar to their parent types. */
- while (TREE_CODE (mode1) == INTEGER_TYPE && TREE_TYPE (mode1) != NULL_TREE)
- mode1 = TREE_TYPE (mode1);
- while (TREE_CODE (mode2) == INTEGER_TYPE && TREE_TYPE (mode2) != NULL_TREE)
- mode2 = TREE_TYPE (mode2);
-
-
- /* see Z.200 sections 12.1.2.2 and 13.2 - all integer precisions
- are similar to INT and to each other */
- if (mode1 == mode2 ||
- (TREE_CODE (mode1) == INTEGER_TYPE && TREE_CODE (mode2) == INTEGER_TYPE))
- return 1;
-
- /* This guards against certain kinds of recursion.
- For example:
- SYNMODE a = STRUCT ( next REF a );
- SYNMODE b = STRUCT ( next REF b );
- These moes are similar, but will get an infite recursion trying
- to prove that. So, if we are recursing, assume the moes are similar.
- If they are not, we'll find some other discrepancy. */
- for (link = chain; link != NULL; link = link->prev)
- {
- if (link->mode1 == mode1 && link->mode2 == mode2)
- return 1;
- }
-
- node.mode1 = mode1;
- node.mode2 = mode2;
- node.prev = chain;
-
- varying1 = chill_varying_type_p (mode1);
- varying2 = chill_varying_type_p (mode2);
- /* FIXME: This isn't quite strict enough. */
- if ((varying1 && varying2)
- || (varying1 && TREE_CODE (mode2) == ARRAY_TYPE)
- || (varying2 && TREE_CODE (mode1) == ARRAY_TYPE))
- return 1;
-
- if (TREE_CODE(mode1) != TREE_CODE(mode2))
- {
- if (flag_old_strings)
- {
- /* The recursion is to handle varying strings. */
- if ((TREE_CODE (mode1) == CHAR_TYPE
- && CH_SIMILAR (mode2, string_one_type_node))
- || (TREE_CODE (mode2) == CHAR_TYPE
- && CH_SIMILAR (mode1, string_one_type_node)))
- return 1;
- if ((TREE_CODE (mode1) == BOOLEAN_TYPE
- && CH_SIMILAR (mode2, bitstring_one_type_node))
- || (TREE_CODE (mode2) == BOOLEAN_TYPE
- && CH_SIMILAR (mode1, bitstring_one_type_node)))
- return 1;
- }
- if (TREE_CODE (mode1) == FUNCTION_TYPE
- && TREE_CODE (mode2) == POINTER_TYPE
- && TREE_CODE (TREE_TYPE (mode2)) == FUNCTION_TYPE)
- mode2 = TREE_TYPE (mode2);
- else if (TREE_CODE (mode2) == FUNCTION_TYPE
- && TREE_CODE (mode1) == POINTER_TYPE
- && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE)
- mode1 = TREE_TYPE (mode1);
- else
- return 0;
- }
-
- if (CH_IS_BUFFER_MODE (mode1) && CH_IS_BUFFER_MODE (mode2))
- {
- tree len1 = max_queue_size (mode1);
- tree len2 = max_queue_size (mode2);
- return tree_int_cst_equal (len1, len2);
- }
- else if (CH_IS_EVENT_MODE (mode1) && CH_IS_EVENT_MODE (mode2))
- {
- tree len1 = max_queue_size (mode1);
- tree len2 = max_queue_size (mode2);
- return tree_int_cst_equal (len1, len2);
- }
- else if (CH_IS_ACCESS_MODE (mode1) && CH_IS_ACCESS_MODE (mode2))
- {
- tree index1 = access_indexmode (mode1);
- tree index2 = access_indexmode (mode2);
- tree record1 = access_recordmode (mode1);
- tree record2 = access_recordmode (mode2);
- if (! chill_read_compatible (index1, index2))
- return 0;
- return chill_read_compatible (record1, record2);
- }
- switch ((enum chill_tree_code)TREE_CODE (mode1))
- {
- case INTEGER_TYPE:
- case BOOLEAN_TYPE:
- case CHAR_TYPE:
- return 1;
- case ENUMERAL_TYPE:
- if (TYPE_VALUES (mode1) == TYPE_VALUES (mode2))
- return 1;
- else
- {
- /* FIXME: This is more strict than z.200, which seems to
- allow the elements to be reordered, as long as they
- have the same values. */
-
- tree field1 = TYPE_VALUES (mode1);
- tree field2 = TYPE_VALUES (mode2);
-
- while (field1 != NULL_TREE && field2 != NULL_TREE)
- {
- tree value1, value2;
- /* Check that the names are equal. */
- if (TREE_PURPOSE (field1) != TREE_PURPOSE (field2))
- break;
-
- value1 = TREE_VALUE (field1);
- value2 = TREE_VALUE (field2);
- /* This isn't quite sufficient in general, but will do ... */
- /* Note that proclaim_decl can cause the SET modes to be
- compared BEFORE they are satisfied, but otherwise
- chill_similar is mostly called after satisfaction. */
- if (TREE_CODE (value1) == CONST_DECL)
- value1 = DECL_INITIAL (value1);
- if (TREE_CODE (value2) == CONST_DECL)
- value2 = DECL_INITIAL (value2);
- /* Check that the values are equal or both NULL. */
- if (!(value1 == NULL_TREE && value2 == NULL_TREE)
- && (value1 == NULL_TREE || value2 == NULL_TREE
- || ! tree_int_cst_equal (value1, value2)))
- break;
- field1 = TREE_CHAIN (field1);
- field2 = TREE_CHAIN (field2);
- }
- return field1 == NULL_TREE && field2 == NULL_TREE;
- }
- case SET_TYPE:
- /* check for bit strings */
- if (CH_BOOLS_TYPE_P (mode1))
- return CH_BOOLS_TYPE_P (mode2);
- if (CH_BOOLS_TYPE_P (mode2))
- return CH_BOOLS_TYPE_P (mode1);
- /* both are powerset modes */
- return CH_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2));
-
- case POINTER_TYPE:
- /* Are the referenced modes equivalent? */
- return !integer_zerop (chill_equivalent (TREE_TYPE (mode1),
- TREE_TYPE (mode2),
- &node));
-
- case ARRAY_TYPE:
- /* char for char strings */
- if (CH_CHARS_TYPE_P (mode1))
- return CH_CHARS_TYPE_P (mode2);
- if (CH_CHARS_TYPE_P (mode2))
- return CH_CHARS_TYPE_P (mode1);
- /* array modes */
- if (CH_V_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2))
- /* Are the elements modes equivalent? */
- && !integer_zerop (chill_equivalent (TREE_TYPE (mode1),
- TREE_TYPE (mode2),
- &node)))
- {
- /* FIXME: Check that element layouts are equivalent */
-
- tree count1 = fold (build (MINUS_EXPR, sizetype,
- TYPE_MAX_VALUE (TYPE_DOMAIN (mode1)),
- TYPE_MIN_VALUE (TYPE_DOMAIN (mode1))));
- tree count2 = fold (build (MINUS_EXPR, sizetype,
- TYPE_MAX_VALUE (TYPE_DOMAIN (mode2)),
- TYPE_MIN_VALUE (TYPE_DOMAIN (mode2))));
- tree cond = build_compare_discrete_expr (EQ_EXPR, count1, count2);
- if (TREE_CODE (cond) == INTEGER_CST)
- return !integer_zerop (cond);
- else
- {
-#if 0
- extern int ignoring;
- if (!ignoring
- && range_checking
- && current_function_decl)
- return cond;
-#endif
- return 1;
- }
- }
- return 0;
-
- case RECORD_TYPE:
- case UNION_TYPE:
- for (t1 = TYPE_FIELDS (mode1), t2 = TYPE_FIELDS (mode2);
- t1 && t2; t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2))
- {
- if (TREE_CODE (t1) != TREE_CODE (t2))
- return 0;
- /* Are the field modes equivalent? */
- if (integer_zerop (chill_equivalent (TREE_TYPE (t1),
- TREE_TYPE (t2),
- &node)))
- return 0;
- }
- return t1 == t2;
-
- case FUNCTION_TYPE:
- if (!chill_l_equivalent (TREE_TYPE (mode1), TREE_TYPE (mode2), &node))
- return 0;
- for (t1 = TYPE_ARG_TYPES (mode1), t2 = TYPE_ARG_TYPES (mode2);
- t1 != NULL_TREE && t2 != NULL_TREE;
- t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2))
- {
- tree attr1 = TREE_PURPOSE (t1)
- ? TREE_PURPOSE (t1) : ridpointers[(int) RID_IN];
- tree attr2 = TREE_PURPOSE (t2)
- ? TREE_PURPOSE (t2) : ridpointers[(int) RID_IN];
- if (attr1 != attr2)
- return 0;
- if (!chill_l_equivalent (TREE_VALUE (t1), TREE_VALUE (t2), &node))
- return 0;
- }
- if (t1 != t2) /* Both NULL_TREE */
- return 0;
- /* check list of exception names */
- t1 = TYPE_RAISES_EXCEPTIONS (mode1);
- t2 = TYPE_RAISES_EXCEPTIONS (mode2);
- if (t1 == NULL_TREE && t2 != NULL_TREE)
- return 0;
- if (t1 != NULL_TREE && t2 == NULL_TREE)
- return 0;
- if (list_length (t1) != list_length (t2))
- return 0;
- while (t1 != NULL_TREE)
- {
- if (value_member (TREE_VALUE (t1), t2) == NULL_TREE)
- return 0;
- t1 = TREE_CHAIN (t1);
- }
- /* FIXME: Should also check they have the same RECURSIVITY */
- return 1;
-
- default:
- ;
- /* Need to handle row modes, instance modes,
- association modes, access modes, text modes,
- duration modes, absolute time modes, structure modes,
- parameterized structure modes */
- }
- 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;
-/*
- ... other conditions ...;
- */
- 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);
- }
-/*
- ...;
-*/
- }
- 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;
-/* FIXME!
- if (class.mode is a row mode)
- ...;
- else if (class.mode is not a static mode)
- return 0; is this possible?
-*/
- 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;
-}
-\f
-
-/*
- * See Z.200, section 6.3, static conditions. This function
- * returns bool_false_node if the condition is not met at compile time,
- * bool_true_node if the condition is detectably met at compile time
- * an expression if a runtime check would be required or was generated.
- * It should only be called with string modes and values.
- */
-tree
-string_assignment_condition (lhs_mode, rhs_value)
- tree lhs_mode, rhs_value;
-{
- tree lhs_size, rhs_size, cond;
- tree rhs_mode = TREE_TYPE (rhs_value);
- int lhs_varying = chill_varying_type_p (lhs_mode);
-
- if (lhs_varying)
- lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode));
- else if (CH_BOOLS_TYPE_P (lhs_mode))
- lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode));
- else
- lhs_size = size_in_bytes (lhs_mode);
- lhs_size = convert (chill_unsigned_type_node, lhs_size);
-
- if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE)
- rhs_mode = TREE_TYPE (rhs_mode);
- if (rhs_mode == NULL_TREE)
- {
- /* actually, count constructor's length */
- abort ();
- }
- else if (chill_varying_type_p (rhs_mode))
- rhs_size = build_component_ref (rhs_value, var_length_id);
- else if (CH_BOOLS_TYPE_P (rhs_mode))
- rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode));
- else
- rhs_size = size_in_bytes (rhs_mode);
- rhs_size = convert (chill_unsigned_type_node, rhs_size);
-
- /* validity condition */
- cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR,
- boolean_type_node, lhs_size, rhs_size));
- return cond;
-}
-\f
-/*
- * take a basic CHILL type and wrap it in a VARYING structure.
- * Be sure the length field is initialized. Return the wrapper.
- */
-tree
-build_varying_struct (type)
- tree type;
-{
- tree decl1, decl2, result;
-
- if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
- return error_mark_node;
-
- decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node);
- decl2 = build_decl (FIELD_DECL, var_data_id, type);
- TREE_CHAIN (decl1) = decl2;
- TREE_CHAIN (decl2) = NULL_TREE;
- result = build_chill_struct_type (decl1);
-
- /* mark this so we don't complain about missing initializers.
- It's fine for a VARYING array to be partially initialized.. */
- C_TYPE_VARIABLE_SIZE(type) = 1;
- return result;
-}
-
-
-/*
- * This is the struct type that forms the runtime initializer
- * list. There's at least one of these generated per module.
- * It's attached to the global initializer list by the module's
- * 'constructor' code. Should only be called in pass 2.
- */
-tree
-build_init_struct ()
-{
- tree decl1, decl2, result;
- /* We temporarily reset the maximum_field_alignment to zero so the
- compiler's init data structures can be compatible with the
- run-time system, even when we're compiling with -fpack. */
- 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;
-}
-\f
-\f
-/*
- * Return 1 if the given type is a single-bit boolean set,
- * in which the domain's min and max values
- * are both zero,
- * 0 if not. This can become a macro later..
- */
-int
-ch_singleton_set (type)
- tree type;
-{
- if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
- return 0;
- if (TREE_CODE (type) != SET_TYPE)
- return 0;
- if (TREE_TYPE (type) == NULL_TREE
- || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE)
- return 0;
- if (TYPE_DOMAIN (type) == NULL_TREE)
- return 0;
- if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
- integer_zero_node))
- return 0;
- if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
- integer_zero_node))
- return 0;
- return 1;
-}
-\f
-/* return non-zero if TYPE is a compiler-generated VARYING
- array of some base type */
-int
-chill_varying_type_p (type)
- tree type;
-{
- if (type == NULL_TREE)
- return 0;
- if (TREE_CODE (type) != RECORD_TYPE)
- return 0;
- if (TYPE_FIELDS (type) == NULL_TREE
- || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE)
- return 0;
- if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id)
- return 0;
- if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id)
- return 0;
- if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE)
- return 0;
- return 1;
-}
-
-/* return non-zero if TYPE is a compiler-generated VARYING
- string record */
-int
-chill_varying_string_type_p (type)
- tree type;
-{
- tree var_data_type;
-
- if (!chill_varying_type_p (type))
- return 0;
-
- var_data_type = CH_VARYING_ARRAY_TYPE (type);
- return CH_CHARS_TYPE_P (var_data_type);
-}
-\f
-/* swiped from c-typeck.c */
-/* Build an assignment expression of lvalue LHS from value RHS. */
-
-tree
-build_chill_modify_expr (lhs, rhs)
- tree lhs, rhs;
-{
- register tree result;
-
-
- tree lhstype = TREE_TYPE (lhs);
-
- /* Avoid duplicate error messages from operands that had errors. */
- if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
- return error_mark_node;
-
- /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */
- /* Do not use STRIP_NOPS here. We do not want an enumerator
- whose value is 0 to count as a null pointer constant. */
- if (TREE_CODE (rhs) == NON_LVALUE_EXPR)
- rhs = TREE_OPERAND (rhs, 0);
-
-#if 0
- /* Handle a cast used as an "lvalue".
- We have already performed any binary operator using the value as cast.
- Now convert the result to the cast type of the lhs,
- and then true type of the lhs and store it there;
- then convert result back to the cast type to be the value
- of the assignment. */
-
- switch (TREE_CODE (lhs))
- {
- case NOP_EXPR:
- case CONVERT_EXPR:
- case FLOAT_EXPR:
- case FIX_TRUNC_EXPR:
- case FIX_FLOOR_EXPR:
- case FIX_ROUND_EXPR:
- case FIX_CEIL_EXPR:
- {
- tree inner_lhs = TREE_OPERAND (lhs, 0);
- tree result;
- result = build_chill_modify_expr (inner_lhs,
- convert (TREE_TYPE (inner_lhs),
- convert (lhstype, rhs)));
- pedantic_lvalue_warning (CONVERT_EXPR);
- return convert (TREE_TYPE (lhs), result);
- }
- }
-
- /* Now we have handled acceptable kinds of LHS that are not truly lvalues.
- Reject anything strange now. */
-
- if (!lvalue_or_else (lhs, "assignment"))
- return error_mark_node;
-#endif
- /* FIXME: need to generate a RANGEFAIL if the RHS won't
- fit into the LHS. */
-
- if (TREE_CODE (lhs) != VAR_DECL
- && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE &&
- (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) ||
- chill_varying_type_p (TREE_TYPE (lhs)) ||
- chill_varying_type_p (TREE_TYPE (rhs))))
- {
- int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs));
- int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs));
-
- /* point at actual RHS data's type */
- tree rhs_data_type = rhs_varying ?
- CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) :
- TREE_TYPE (rhs);
- {
- /* point at actual LHS data's type */
- tree lhs_data_type = lhs_varying ?
- CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) :
- TREE_TYPE (lhs);
-
- int lhs_bytes = int_size_in_bytes (lhs_data_type);
- int rhs_bytes = int_size_in_bytes (rhs_data_type);
-
- /* if both sides not varying, and sizes not dynamically
- computed, sizes must *match* */
- if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes
- && lhs_bytes > 0 && rhs_bytes > 0)
- {
- error ("string lengths not equal");
- return error_mark_node;
- }
- /* Must have enough space on LHS for static size of RHS */
-
- if (lhs_bytes > 0 && rhs_bytes > 0
- && lhs_bytes < rhs_bytes)
- {
- if (rhs_varying)
- {
- /* FIXME: generate runtime test for room */
- ;
- }
- else
- {
- error ("can't do ARRAY assignment - too large");
- return error_mark_node;
- }
- }
- }
-
- /* now we know the RHS will fit in LHS, build trees for the
- emit_block_move parameters */
-
- if (lhs_varying)
- rhs = convert (TREE_TYPE (lhs), rhs);
- else
- {
- if (rhs_varying)
- rhs = build_component_ref (rhs, var_data_id);
-
- if (! mark_addressable (rhs))
- {
- error ("rhs of array assignment is not addressable");
- return error_mark_node;
- }
-
- lhs = force_addr_of (lhs);
- rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs);
- return
- build_chill_function_call (lookup_name (get_identifier ("memmove")),
- tree_cons (NULL_TREE, lhs,
- tree_cons (NULL_TREE, rhs,
- tree_cons (NULL_TREE, size_in_bytes (rhs_data_type),
- NULL_TREE))));
- }
- }
-
- result = build (MODIFY_EXPR, lhstype, lhs, rhs);
- TREE_SIDE_EFFECTS (result) = 1;
-
- return result;
-}
-\f
-/* Constructors for pointer, array and function types.
- (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are
- constructed by language-dependent code, not here.) */
-
-/* Construct, lay out and return the type of pointers to TO_TYPE.
- If such a type has already been constructed, reuse it. */
-
-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;
-}
-\f
-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;
-}
-
-\f
-/* 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 ("parameterized structures not implemented");
- return error_mark_node;
- }
- else
- {
- error ("invalid parameterized 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;
-}
-
-\f
-/* Return an unsigned type the same as TYPE in other respects. */
-
-tree
-unsigned_type (type)
- tree type;
-{
- tree type1 = TYPE_MAIN_VARIANT (type);
- if (type1 == signed_char_type_node || type1 == char_type_node)
- return unsigned_char_type_node;
- if (type1 == integer_type_node)
- return unsigned_type_node;
- if (type1 == short_integer_type_node)
- return short_unsigned_type_node;
- if (type1 == long_integer_type_node)
- return long_unsigned_type_node;
- if (type1 == long_long_integer_type_node)
- return long_long_unsigned_type_node;
-
- return signed_or_unsigned_type (1, type);
-}
-
-/* Return a signed type the same as TYPE in other respects. */
-
-tree
-signed_type (type)
- tree type;
-{
- tree type1 = TYPE_MAIN_VARIANT (type);
- while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE)
- type1 = TREE_TYPE (type1);
- if (type1 == unsigned_char_type_node || type1 == char_type_node)
- return signed_char_type_node;
- if (type1 == unsigned_type_node)
- return integer_type_node;
- if (type1 == short_unsigned_type_node)
- return short_integer_type_node;
- if (type1 == long_unsigned_type_node)
- return long_integer_type_node;
- if (type1 == long_long_unsigned_type_node)
- return long_long_integer_type_node;
- if (TYPE_PRECISION (type1) == 1)
- return signed_boolean_type_node;
-
- return signed_or_unsigned_type (0, type);
-}
-
-/* Return a type the same as TYPE except unsigned or
- signed according to UNSIGNEDP. */
-
-tree
-signed_or_unsigned_type (unsignedp, type)
- int unsignedp;
- tree type;
-{
- if (! INTEGRAL_TYPE_P (type)
- || TREE_UNSIGNED (type) == unsignedp)
- return type;
-
- if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
- return (unsignedp ? long_long_unsigned_type_node
- : long_long_integer_type_node);
- return type;
-}
-\f
-/* Mark EXP saying that we need to be able to take the
- address of it; it should not be allocated in a register.
- Value is 1 if successful. */
-
-int
-mark_addressable (exp)
- tree exp;
-{
- register tree x = exp;
- while (1)
- switch (TREE_CODE (x))
- {
- case ADDR_EXPR:
- case COMPONENT_REF:
- case ARRAY_REF:
- case REALPART_EXPR:
- case IMAGPART_EXPR:
- x = TREE_OPERAND (x, 0);
- break;
-
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case COMPOUND_EXPR:
- x = TREE_OPERAND (x, 1);
- break;
-
- case COND_EXPR:
- return mark_addressable (TREE_OPERAND (x, 1))
- & mark_addressable (TREE_OPERAND (x, 2));
-
- case CONSTRUCTOR:
- TREE_ADDRESSABLE (x) = 1;
- return 1;
-
- case INDIRECT_REF:
- /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode
- incompatibility problems. Handle this case by marking FOO. */
- if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR
- && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR)
- {
- x = TREE_OPERAND (TREE_OPERAND (x, 0), 0);
- break;
- }
- if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR)
- {
- x = TREE_OPERAND (x, 0);
- break;
- }
- return 1;
-
- case VAR_DECL:
- case CONST_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
- && DECL_NONLOCAL (x))
- {
- if (TREE_PUBLIC (x))
- {
- error ("global register variable `%s' used in nested function",
- IDENTIFIER_POINTER (DECL_NAME (x)));
- return 0;
- }
- pedwarn ("register variable `%s' used in nested function",
- IDENTIFIER_POINTER (DECL_NAME (x)));
- }
- else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
- {
- if (TREE_PUBLIC (x))
- {
- error ("address of global register variable `%s' requested",
- IDENTIFIER_POINTER (DECL_NAME (x)));
- return 0;
- }
-
- /* If we are making this addressable due to its having
- volatile components, give a different error message. Also
- handle the case of an unnamed parameter by not trying
- to give the name. */
-
- else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
- {
- error ("cannot put object with volatile field into register");
- return 0;
- }
-
- pedwarn ("address of register variable `%s' requested",
- IDENTIFIER_POINTER (DECL_NAME (x)));
- }
- put_var_into_stack (x);
-
- /* drops through */
- case FUNCTION_DECL:
- TREE_ADDRESSABLE (x) = 1;
-#if 0 /* poplevel deals with this now. */
- if (DECL_CONTEXT (x) == 0)
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
-#endif
- /* drops through */
- default:
- return 1;
- }
-}
-\f
-/* Return 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;
-}
+++ /dev/null
-/* 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:
- x = TREE_OPERAND (x, 0);
- break;
-
- 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
@c For copying conditions, see the file gcc.texi.
@node G++ and GCC
-@chapter Compile C, C++, Objective-C, Ada, CHILL, Fortran, or Java
+@chapter Compile C, C++, Objective-C, Ada, Fortran, or Java
@cindex Objective-C
@cindex Fortran
@cindex Java
-@cindex CHILL
@cindex Ada
-Several versions of the compiler (C, C++, Objective-C, Ada, CHILL,
+Several versions of the compiler (C, C++, Objective-C, Ada,
Fortran, and Java) are integrated; this is why we use the name
``GNU Compiler Collection''. GCC can compile programs written in any of these
-languages. The Ada, CHILL, Fortran, and Java compilers are described in
+languages. The Ada, Fortran, and Java compilers are described in
separate manuals.
@cindex GCC
@item include
Headers for the @code{libiberty} library.
-@item libchill
-The CHILL runtime library.
-
@item libf2c
The Fortran runtime library.
-@c Copyright (C) 2000, 2001 Free Software Foundation, Inc.
+@c Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
@c This is part of the GCC manual.
@c For copying conditions, see the file gcc.texi.
GNAT Reference Manual}, for information on standard
conformance and compatibility of the Ada compiler.
-@xref{References,,Language Definition References, chill, GNU Chill},
-for details of the CHILL standard.
-
@xref{Language,,The GNU Fortran Language, g77, Using and Porting GNU
Fortran}, for details of the Fortran language supported by GCC@.
+Mon Apr 15 10:59:14 2002 Mark Mitchell <mark@codesourcery.com>
+
+ * g77.texi: Remove Chill reference.
+
2002-04-13 Toon Moene <toon@moene.indiv.nluug.nl>
* news.texi: Deprecate frontend version number;
command-line options that are designed to cater to Fortran users
but apply to other languages as well.
-@xref{G++ and GCC,,Compile C; C++; Objective-C; Ada; CHILL; Fortran;
+@xref{G++ and GCC,,Compile C; C++; Objective-C; Ada; Fortran;
or Java,gcc,Using the GNU Compiler Collection (GCC)},
for information on the way different languages are handled
by the GNU CC compiler (@command{gcc}).
{".F", "#Fortran", 0}, {".FOR", "#Fortran", 0}, {".FPP", "#Fortran", 0},
{".r", "#Ratfor", 0},
{".p", "#Pascal", 0}, {".pas", "#Pascal", 0},
- {".ch", "#Chill", 0}, {".chi", "#Chill", 0},
{".java", "#Java", 0}, {".class", "#Java", 0},
{".zip", "#Java", 0}, {".jar", "#Java", 0},
/* Next come the entries for C. */
+2002-04-15 Mark Mitchell <mark@codesourcery.com>
+
+ * testsuite/lib/chill.exp: Remove.
+
2002-04-14 Jakub Jelinek <jakub@redhat.com>
* g++.dg/other/big-struct.C: New test.
+++ /dev/null
-#
-# Expect script for Chill Regression Tests
-# Copyright (C) 1993, 1996, 1997 Free Software Foundation
-#
-# This file 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 of the License, or
-# (at your option) any later version.
-#
-# This program 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 this program; if not, write to the Free Software
-# Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-#
-# Written by Jeffrey Wheat (cassidy@cygnus.com)
-#
-
-#
-# chill support library procedures and testsuite specific instructions
-#
-
-#
-# default_chill_version
-# extract and print the version number of the chill compiler
-# exits if compiler does not exist
-#
-proc default_chill_version { } {
- global GCC_UNDER_TEST
-
- # ignore any arguments after the command
- set compiler [lindex $GCC_UNDER_TEST 0]
-
- # verify that the compiler exists
- if {[which $compiler] != 0} then {
- set tmp [ exec $compiler -v ]
- regexp "version.*$" $tmp version
-
- if [info exists version] then {
- clone_output "[which $compiler] $version\n"
- }
- } else {
- warning "$compiler does not exist"
- exit -1
- }
-}
-
-#
-# chill_compile
-# compile the specified file
-#
-# returns values:
-# return 0 on success
-# return 1 on failure with $result containing compiler output
-# exit with -1 if compiler doesn't exist
-#
-# verbosity output:
-# 1 - indicate compile in progress
-# 2 - indicate compile, target name
-# 3 - indicate compile, target name, exec command, and result
-#
-proc chill_compile { src obj } {
- global GCC_UNDER_TEST
- global CFLAGS
-
- global errno
- global result
- global verbose
-
- global subdir
- global tmpdir
-
- set errno 0
- set cflags $CFLAGS
- set dumpfile [file rootname $obj].cmp ;# name of file to dump stderr in
-
- # verify that the compiler exists
- if { [which $GCC_UNDER_TEST] == 0 } then {
- warning "$GCC_UNDER_TEST does not exist"
- exit -1
- }
-
- if { $verbose == 1 } then {
- send_user "Compiling... "
- } else {
- verbose " - CMPL: Compiling [file tail $src]" 2
- }
-
- # if object type is a grt file, then only build a grant file
- if [string match "*.grt" $obj] then {
- set cflags [concat $cflags -fgrant-only]
- }
-
- # build command line
- set commandline "$GCC_UNDER_TEST $cflags -I$subdir -c $src"
-
- # write command line to logfile
- send_log "\n### EXEC: $commandline\n"
-
- # tell us whats going on if verbose
- verbose "### EXEC: $commandline" 3
-
- # exec the compiler with the appropriate flags
- set errno [catch "exec $commandline" result]
-
- # dump compiler's stderr output into $dumpfile - this is a gross hack
- set dumpfile [open $dumpfile w+]; puts $dumpfile $result; close $dumpfile
-
- # log any compiler output unless its null
- if ![string match "" $result] then { send_log "\n$result\n" }
- unset cflags
- return
-}
-
-#
-# chill_link
-# link the specified files
-#
-# returns values:
-# return 0 on success
-# return 1 on failure with $result containing compiler output
-# exit with -1 if compiler doesn't exist
-#
-# verbosity output:
-# 1 - indicate linking in progress
-# 2 - indicate linking, target name
-# 3 - indicate linking, target name, exec command, and result
-#
-proc chill_link { target } {
- global GCC_UNDER_TEST
- global CFLAGS
-
- global errno
- global result
- global verbose
- global tmptarget
-
- global crt0
- global libs
- global objs
-
- set errno 0
-
- # verify that the compiler exists
- if { [which $GCC_UNDER_TEST] == 0 } then {
- warning "$GCC_UNDER_TEST does not exist"
- exit -1
- }
-
- if { $verbose == 1 } then {
- send_user "Linking... "
- } else {
- verbose " - LINK: Linking [file tail $target]" 2
- }
-
- # verify that the object exists
- if ![file exists $target.o] then {
- set errno 1
- set result "file $target.o doesn't exist"
- return
- }
-
- # build command line
- set commandline "$GCC_UNDER_TEST $CFLAGS -o $target $target.o $objs $crt0 $libs"
-
- # write command line to logfile
- send_log "\n### EXEC: $commandline\n"
-
- # tell us whats going on if we are verbose
- verbose "### EXEC: $commandline" 3
-
- # link the objects, sending any linker output to $result
- set errno [catch "exec $commandline > $tmptarget.lnk" result]
-
- # log any linker output unless its null
- if ![string match "" $result] then { send_log "\n$result\n" }
- return
-}
-
-#
-# default_chill_start
-#
-proc default_chill_start { } {
- global srcdir
- global subdir
- global tmpdir
- global verbose
-
- if { $verbose > 1 } then { send_user "Configuring testsuite... " }
-
- # tmpdir is obtained from $objdir/site.exp. if not, set it to /tmp
- if ![info exists tmpdir] then { set tmpdir /tmp }
-
- # save and convert $srcdir to an absolute pathname, stomp on the old value
- # stomp on $subdir and set to the absolute path to the subdirectory
- global osrcdir; set osrcdir $srcdir; set srcdir [cd $srcdir; pwd]
- global osubdir; set osubdir $subdir; set subdir $srcdir/$subdir
-
- # cd the temporary directory, $tmpdir
- cd $tmpdir; verbose "### PWD: [pwd]" 5
-
- # copy init files to the tmpdir
- foreach initfile [glob -nocomplain $subdir/*.init] {
- set targfile $tmpdir/[file tail [file rootname $initfile]]
- verbose "### EXEC: cp $initfile $targfile" 5
- if [catch "exec cp $initfile $targfile"] then {
- send_user "\nConfigure failed.\n"
- exit -1
- }
- }
- if { $verbose > 1 } then { send_user "Configuring finished.\n" }
-}
-
-#
-# default_chill_exit
-#
-#
-proc default_chill_exit { } {
- global srcdir
- global objdir
- global tmpdir
- global osrcdir
- global osubdir
-
- # reset directory variables
- set srcdir $osrcdir; set subdir $osubdir
-
- # remove all generated targets and objects
- verbose "### EXEC: rm -f $tmpdir/*" 3
- catch "exec rm -f $tmpdir/*" result
-
- # change back to the main object directory
- cd $objdir
- verbose "### SANITY: [pwd]" 5
-}
-
-#
-# chill_diff
-# compare two files line-by-line
-#
-# returns values:
-# return 0 on success
-# return 1 if different
-# return -1 if output file doesn't exist
-#
-# verbosity output:
-# 1 - indicate diffing in progress
-# 2 - indicate diffing, target names
-# 3 - indicate diffing, target names, and result
-#
-proc chill_diff { file_1 file_2 } {
- global errno
- global result
- global target
- global tmptarget
-
- global verbose
-
- set eof -1
- set errno 0
- set differences 0
-
- if { $verbose == 1 } then {
- send_user "Diffing... "
- } else {
- verbose " - DIFF: Diffing [file tail $file_1] [file tail $file_2]" 2
- }
-
- # write command line to logfile
- send_log "### EXEC: diff $file_1 $file_2\n"
-
- # tell us whats going on if we are verbose
- verbose "### EXEC: diff $file_1 $file_2" 3
-
- # verify file exists and open it
- if [file exists $file_1] then {
- set file_a [open $file_1 r]
- } else {
- set errno -1; set result "$file_1 doesn't exist"
- return
- }
-
- # verify file exists and is not zero length, and then open it
- if [file exists $file_2] then {
- if [file size $file_2]!=0 then {
- set file_b [open $file_2 r]
- } else {
- set errno -1; set result "$file_2 is zero bytes"; return
- }
- } else {
- set errno -1; set result "$file_2 doesn't exist"; return
- }
-
- # spoof the diff routine
- lappend list_a $target
-
- while { [gets $file_a line] != $eof } {
- if [regexp "^#.*$" $line] then {
- continue
- } else {
- lappend list_a $line
- }
- }
- close $file_a
-
- # spoof the diff routine
- lappend list_b $target
-
- while { [gets $file_b line] != $eof } {
- if [regexp "^#.*$" $line] then {
- continue
- } else {
- # use [file tail $line] to strip off pathname
- lappend list_b [file tail $line]
- }
- }
- close $file_b
-
- for { set i 0 } { $i < [llength $list_a] } { incr i } {
- set line_a [lindex $list_a $i]
- set line_b [lindex $list_b $i]
-
- if [string compare $line_a $line_b] then {
- set errno 1
- set count [expr $i+1]
- set linenum [format %dc%d $count $count]
- verbose "$linenum" 3
- verbose "< $line_a" 3
- verbose "---" 3
- verbose "> $line_b" 3
-
- send_log "$file_1: < $count: $line_a\n"
- send_log "$file_2: > $count: $line_b\n"
- set result "differences found"
- }
- }
- return
-}
-
-#
-# chill_fail
-# a wrapper around the framework fail proc
-#
-proc chill_fail { target result } {
- global verbose
-
- if { $verbose == 1 } then { send_user "\n" }
- fail $target
- verbose "--------------------------------------------------" 3
- verbose "### RESULT: $result" 3
-}
-
-#
-# chill_pass
-# a wrapper around the framework fail proc
-#
-proc chill_pass { target } {
- global verbose
-
- if { $verbose == 1 } then { send_user "\n" }
- pass $target
-}
+2002-04-15 Mark Mitchell <mark@codesourcery.com>
+
+ * gcc_release (build_tarfiles): Do not build Chill tarfiles.
+ (CHILL_DIRS): Remove.
+
2002-03-10 Joseph S. Myers <jsm28@cam.ac.uk>
* gcc_release: Build diffs for ada and chill. Make "bzip2" a new
# Now, build one for each of the languages.
build_tarfile gcc-ada-${RELEASE} ${ADA_DIRS}
- build_tarfile gcc-chill-${RELEASE} ${CHILL_DIRS}
build_tarfile gcc-g++-${RELEASE} ${CPLUSPLUS_DIRS}
build_tarfile gcc-g77-${RELEASE} ${FORTRAN_DIRS}
build_tarfile gcc-java-${RELEASE} ${JAVA_DIRS}
# The core is everything else.
EXCLUDES=""
- for x in ${ADA_DIRS} ${CHILL_DIRS} ${CPLUSPLUS_DIRS} ${FORTRAN_DIRS} \
+ for x in ${ADA_DIRS} ${CPLUSPLUS_DIRS} ${FORTRAN_DIRS} \
${JAVA_DIRS} ${OBJECTIVEC_DIRS} ${TESTSUITE_DIRS}; do
EXCLUDES="${EXCLUDES} --exclude $x"
done
# The directories that should be part of the various language-specific
# tar files. These are all relative to the top of the source tree.
ADA_DIRS="gcc/ada"
-CHILL_DIRS="gcc/ch libchill"
CPLUSPLUS_DIRS="gcc/cp libstdc++-v3"
FORTRAN_DIRS="gcc/f libf2c"
JAVA_DIRS="gcc/java libjava libffi fastjar zlib boehm-gc"
# Recompute the names of all the language-specific directories,
# relative to the WORKING_DIRECTORY.
ADA_DIRS=`adjust_dirs ${ADA_DIRS}`
-CHILL_DIRS=`adjust_dirs ${CHILL_DIRS}`
CPLUSPLUS_DIRS=`adjust_dirs ${CPLUSPLUS_DIRS}`
FORTRAN_DIRS=`adjust_dirs ${FORTRAN_DIRS}`
JAVA_DIRS=`adjust_dirs ${JAVA_DIRS}`
projects / platform / upstream / linaro-gcc.git / commitdiff