Migrate from devo/gcc/ch.
From-SVN: r22034
--- /dev/null
+/* Declarations for ch-actions.c.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* used by compile_file */
+
+void init_chill PROTO((void));
+
+extern int grant_count;
+
+extern void push_handler PROTO((void));
+extern void pop_handler PROTO((int));
+extern void push_action PROTO((void));
+
+extern int chill_handle_single_dimension_case_label PROTO((tree, tree, int *, int *));
+extern tree build_chill_multi_dimension_case_expr PROTO((tree, tree, tree));
+extern tree build_multi_case_selector_expression PROTO((tree, tree));
+extern void compute_else_ranges PROTO((tree, tree));
--- /dev/null
+/* Exception support for GNU CHILL.
+ WARNING: Only works for native (needs setjmp.h)! FIXME!
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "rtl.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
+
+extern int expand_exit_needed;
+extern tree build_chill_exception_decl PROTO((char *));
+extern void chill_handle_case_default PROTO((void));
+extern void emit_jump PROTO((rtx));
+extern void expand_decl PROTO((tree));
+extern void fatal PROTO((char *, ...));
+extern void make_decl_rtl PROTO((tree, char *, int));
+extern void rest_of_decl_compilation PROTO((tree, char *, int, int));
+
+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 PROTO((void));
+static void initialize_exceptions PROTO((void));
+static tree char_pointer_type_for_handler;
+
+/* If this is 1, operations to push and pop on the __exceptionStack
+ are inline. The default is is to use a function call, to
+ allow for a per-thread exception stack. */
+static int inline_exception_stack_ops = 0;
+
+struct handler_state
+{
+ struct handler_state *next;
+
+ /* Starts at 0, then incremented for every <on-alternative>. */
+ int prev_on_alternative;
+
+ /* If > 0: handler number for ELSE handler. */
+ int else_handler;
+
+ int action_number;
+
+ char do_pushlevel;
+
+ tree on_alt_list;
+ tree setjmp_expr;
+
+ /* A decl for the static handler array (used to map exception name to int).*/
+ tree handler_array_decl;
+
+ rtx end_label;
+
+ /* Used to pass a tree from emit_setup_handler to chill_start_on. */
+ tree handler_ref;
+
+ tree unlink_cleanup;
+
+ tree function;
+
+ /* flag to indicate that we are currently compiling this handler.
+ is_handled will need this to determine an unhandled exception */
+ int compiling;
+};
+
+/* This is incremented by one each time we start an action which
+ might have an ON-handler. It is reset between passes. */
+static int action_number = 0;
+
+int action_nesting_level = 0;
+
+/* The global_handler_list is constructed in pass 1. It is not sorted.
+ It contains one element for each action that actually had an ON-handler.
+ An element's ACTION_NUMBER matches the action_number
+ of that action. The global_handler_list is eaten up during pass 2. */
+#define ACTION_NUMBER(HANDLER) ((HANDLER)->action_number)
+struct handler_state *global_handler_list = NULL;
+
+/* This is a stack of handlers, one for each nested ON-handler. */
+static struct handler_state *current_handler = NULL;
+
+static struct handler_state *free_handlers = NULL; /* freelist */
+
+static tree handler_element_type;
+static tree handler_link_type;
+static tree BISJ;
+static tree jbuf_ident, prev_ident, handlers_ident;
+static tree exception_stack_decl = 0;
+
+/* Chain of cleanups assocated with exception handlers.
+ The TREE_PURPOSE is an INTEGER_CST whose value is the
+ DECL_ACTION_NESTING_LEVEL (when the handled actions was entered).
+ The TREE_VALUE is an expression to expand when we exit that action. */
+
+static tree cleanup_chain = NULL_TREE;
+\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)
+ fatal ("internal error: on stack out of sync");
+ 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. */
+ extern int maximum_field_alignment;
+ 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;
+{
+ 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 = current_handler->on_alt_list;
+ while (TREE_INT_CST_LOW (TREE_PURPOSE (tmp)) != alternative)
+ 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)
+ fatal ("internal error: on stack not empty when done");
+}
+
+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),
+ 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,
+ NOT_BUILT_IN, NULL_PTR);
+ unlink_handler_decl = builtin_function ("__ch_unlink_handler", link_ftype,
+ 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 (TREE_INT_CST_LOW (TREE_PURPOSE (list)) > label_level)
+ 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
+/* Implement grant-file output & seize-file input for CHILL.
+ Copyright (C) 1992, 93, 94, 95, 1996 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+#include <string.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 "errno.h"
+#include "rtl.h"
+#include "tasking.h"
+
+/* Disable possible macro over-rides, so the externs parse
+ portably. */
+#undef strchr
+#undef strrchr
+
+#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 void assemble_constructor PROTO((char *));
+extern void assemble_name PROTO((FILE *, char *));
+extern void error PROTO((char *, ...));
+extern tree tasking_list;
+extern void tasking_registry PROTO((void));
+extern void tasking_setup PROTO((void));
+extern void build_enum_tables PROTO((void));
+extern tree process_type;
+extern void warning PROTO((char *, ...));
+extern tree get_file_function_name PROTO((int));
+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 version strings */
+extern char *gnuchill_version;
+extern char *version_string;
+
+/* 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 PROTO((tree));
+static MYSTRING *decode_constant PROTO((tree));
+static void grant_one_decl PROTO((tree));
+static MYSTRING *get_type PROTO((tree));
+static MYSTRING *decode_mode PROTO((tree));
+static MYSTRING *decode_prefix_rename PROTO((tree));
+static MYSTRING *decode_constant_selective PROTO((tree, tree));
+static MYSTRING *decode_mode_selective PROTO((tree, tree));
+static MYSTRING *get_type_selective PROTO((tree, tree));
+static MYSTRING *decode_decl_selective PROTO((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)
+ 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;
+ 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;
+ char *in;
+{
+ MYSTRING *res = inout;
+ if (strlen (in))
+ {
+ res = newstring (in);
+ res = APPEND (res, inout->str);
+ FREE (inout);
+ }
+ return res;
+}
+\f
+void
+grant_use_seizefile (seize_filename)
+ 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, "%d", 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;
+ 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;
+ char *op;
+ char wrk[256];
+ MYSTRING *mode_string;
+
+ switch ((enum chill_tree_code)TREE_CODE (val))
+ {
+ case CALL_EXPR:
+ tmp_string = decode_constant (TREE_OPERAND (val, 0));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ val = TREE_OPERAND (val, 1); /* argument list */
+ if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
+ {
+ APPEND (result, " ");
+ tmp_string = decode_constant (val);
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ }
+ else
+ {
+ APPEND (result, " (");
+ if (val != NULL_TREE)
+ {
+ for (;;)
+ {
+ tmp_string = decode_constant (TREE_VALUE (val));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ val = TREE_CHAIN (val);
+ if (val == NULL_TREE)
+ break;
+ APPEND (result, ", ");
+ }
+ }
+ APPEND (result, ")");
+ }
+ return result;
+
+ case NOP_EXPR:
+ /* Generate an "expression conversion" expression (a cast). */
+ tmp_string = decode_mode (type);
+
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ APPEND (result, "(");
+ val = TREE_OPERAND (val, 0);
+ type = TREE_TYPE (val);
+
+ /* If the coercee is a tuple, make sure it is prefixed by its mode. */
+ if (TREE_CODE (val) == CONSTRUCTOR
+ && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
+ {
+ tmp_string = decode_mode (type);
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ APPEND (result, " ");
+ }
+
+ tmp_string = decode_constant (val);
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ APPEND (result, ")");
+ return result;
+
+ case IDENTIFIER_NODE:
+ APPEND (result, IDENTIFIER_POINTER (val));
+ return result;
+
+ case PAREN_EXPR:
+ APPEND (result, "(");
+ tmp_string = decode_constant (TREE_OPERAND (val, 0));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ APPEND (result, ")");
+ return result;
+
+ case UNDEFINED_EXPR:
+ APPEND (result, "*");
+ return result;
+
+ case PLUS_EXPR: op = "+"; goto binary;
+ case MINUS_EXPR: op = "-"; goto binary;
+ case MULT_EXPR: op = "*"; goto binary;
+ case TRUNC_DIV_EXPR: op = "/"; goto binary;
+ case FLOOR_MOD_EXPR: op = " MOD "; goto binary;
+ case TRUNC_MOD_EXPR: op = " REM "; goto binary;
+ case CONCAT_EXPR: op = "//"; goto binary;
+ case BIT_IOR_EXPR: op = " OR "; goto binary;
+ case BIT_XOR_EXPR: op = " XOR "; goto binary;
+ case TRUTH_ORIF_EXPR: op = " ORIF "; goto binary;
+ case BIT_AND_EXPR: op = " AND "; goto binary;
+ case TRUTH_ANDIF_EXPR: op = " ANDIF "; goto binary;
+ case GT_EXPR: op = ">"; goto binary;
+ case GE_EXPR: op = ">="; goto binary;
+ case SET_IN_EXPR: op = " IN "; goto binary;
+ case LT_EXPR: op = "<"; goto binary;
+ case LE_EXPR: op = "<="; goto binary;
+ case EQ_EXPR: op = "="; goto binary;
+ case NE_EXPR: op = "/="; goto binary;
+ case RANGE_EXPR:
+ if (TREE_OPERAND (val, 0) == NULL_TREE)
+ {
+ APPEND (result, TREE_OPERAND (val, 1) == NULL_TREE ? "*" : "ELSE");
+ return result;
+ }
+ op = ":"; goto binary;
+ binary:
+ tmp_string = decode_constant (TREE_OPERAND (val, 0));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ APPEND (result, op);
+ tmp_string = decode_constant (TREE_OPERAND (val, 1));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ return result;
+
+ case REPLICATE_EXPR:
+ APPEND (result, "(");
+ tmp_string = decode_constant (TREE_OPERAND (val, 0));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ APPEND (result, ")");
+ tmp_string = decode_constant (TREE_OPERAND (val, 1));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ return result;
+
+ case NEGATE_EXPR: op = "-"; goto unary;
+ case BIT_NOT_EXPR: op = " NOT "; goto unary;
+ case ADDR_EXPR: op = "->"; goto unary;
+ unary:
+ APPEND (result, op);
+ tmp_string = decode_constant (TREE_OPERAND (val, 0));
+ APPEND (result, tmp_string->str);
+ FREE (tmp_string);
+ return result;
+
+ case INTEGER_CST:
+ APPEND (result, display_int_cst (val));
+ return result;
+
+ case REAL_CST:
+#ifndef REAL_IS_NOT_DOUBLE
+ sprintf (wrk, "%.20g", TREE_REAL_CST (val));
+#else
+ REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk);
+#endif
+ APPEND (result, wrk);
+ return result;
+
+ case STRING_CST:
+ {
+ 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;
+ char *op;
+ char wrk[256];
+ 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 ((enum chill_tree_code)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))
+ {
+ extern FILE *asm_out_file;
+ extern char *first_global_object_name;
+ 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)
+ char *fname;
+ 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)
+ pfatal_with_name (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)
+ {
+ extern char* strchr ();
+ 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;
+ pfatal_with_name (grant_file_name);
+ }
+#endif
+ fclose (fb);
+}
+
+
+/* handle grant statement */
+
+void
+set_default_grant_file ()
+{
+#undef strrchr
+ extern char *strrchr ();
+ char *p, *tmp, *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, decl;
+{
+#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;
+ }
+
+ /* 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;
+static char *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)
+ + strlen (header_template) + 1);
+ 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)
+ {
+ extern char *first_global_object_name;
+ /* If we don't do this spoof, we get the name of the first
+ tasking_code variable, and not the file name. */
+ 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. */
+ tmp = strrchr (IDENTIFIER_POINTER (chill_init_name), '.');
+ if (tmp)
+ *tmp = '\0';
+ }
+
+ start_chill_function (chill_init_name, void_type_node, NULL_TREE,
+ NULL_TREE, NULL_TREE);
+ TREE_PUBLIC (current_function_decl) = 1;
+ chill_init_function = current_function_decl;
+
+ /* For each module that we've compiled, that had module-level
+ code to be called, add its entry to the global initializer
+ list. */
+
+ if (pass == 2)
+ {
+ tree module_init;
+
+ for (module_init = module_init_list;
+ module_init != NULL_TREE;
+ module_init = TREE_CHAIN (module_init))
+ {
+ tree init_entry = TREE_VALUE (module_init);
+
+ /* assign module_entry.next := _ch_init_list; */
+ expand_expr_stmt (
+ build_chill_modify_expr (
+ build_component_ref (init_entry,
+ get_identifier ("__INIT_NEXT")),
+ global_list));
+
+ /* assign _ch_init_list := &module_entry; */
+ expand_expr_stmt (
+ build_chill_modify_expr (global_list,
+ build1 (ADDR_EXPR, ptr_type_node, init_entry)));
+ }
+ }
+
+ tasking_registry ();
+
+ make_decl_rtl (current_function_decl, NULL, 1);
+
+ finish_chill_function ();
+
+ if (pass == 2)
+ {
+ assemble_constructor (IDENTIFIER_POINTER (chill_init_name));
+ globalize_decl (chill_init_function);
+ }
+
+ /* ready now to link decls onto this list in pass 2. */
+ module_init_list = NULL_TREE;
+ tasking_list = NULL_TREE;
+ }
+}
+
+
--- /dev/null
+/* Implement I/O-related actions for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+ This file is part of GNU CC.
+
+ GNU CC is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ GNU CC is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GNU CC; see the file COPYING. If not, write to
+ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+#include <string.h>
+#include <limits.h>
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "rtl.h"
+#include "lex.h"
+#include "flags.h"
+#include "input.h"
+#include "assert.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;
+
+extern void error PROTO((char *, ...));
+extern void sorry PROTO((char *, ...));
+extern void warning PROTO((char *, ...));
+
+extern tree build_chill_compound_expr PROTO((tree));
+
+static int intsize_of_charsexpr PROTO((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 */
+ char *name = IDENTIFIER_POINTER (DECL_NAME (wrk->ptrdecl));
+ tree var = get_identifier (name);
+ 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)
+ char *name;
+ 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. */
+ extern int maximum_field_alignment;
+ 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, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT",
+ chill_predefined_function_type,
+ BUILT_IN_CONNECT, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE",
+ chill_predefined_function_type,
+ BUILT_IN_CREATE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE",
+ chill_predefined_function_type,
+ BUILT_IN_CH_DELETE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT",
+ chill_predefined_function_type,
+ BUILT_IN_DISCONNECT, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE",
+ chill_predefined_function_type,
+ BUILT_IN_DISSOCIATE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN",
+ chill_predefined_function_type,
+ BUILT_IN_EOLN, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING",
+ chill_predefined_function_type,
+ BUILT_IN_EXISTING, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION",
+ chill_predefined_function_type,
+ BUILT_IN_GETASSOCIATION, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS",
+ chill_predefined_function_type,
+ BUILT_IN_GETTEXTACCESS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX",
+ chill_predefined_function_type,
+ BUILT_IN_GETTEXTINDEX, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD",
+ chill_predefined_function_type,
+ BUILT_IN_GETTEXTRECORD, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE",
+ chill_predefined_function_type,
+ BUILT_IN_GETUSAGE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE",
+ chill_predefined_function_type,
+ BUILT_IN_INDEXABLE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED",
+ chill_predefined_function_type,
+ BUILT_IN_ISASSOCIATED, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY",
+ chill_predefined_function_type,
+ BUILT_IN_MODIFY, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE",
+ chill_predefined_function_type,
+ BUILT_IN_OUTOFFILE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE",
+ chill_predefined_function_type,
+ BUILT_IN_READABLE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD",
+ chill_predefined_function_type,
+ BUILT_IN_READRECORD, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT",
+ chill_predefined_function_type,
+ BUILT_IN_READTEXT, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE",
+ chill_predefined_function_type,
+ BUILT_IN_SEQUENCIBLE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS",
+ chill_predefined_function_type,
+ BUILT_IN_SETTEXTACCESS, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX",
+ chill_predefined_function_type,
+ BUILT_IN_SETTEXTINDEX, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD",
+ chill_predefined_function_type,
+ BUILT_IN_SETTEXTRECORD, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE",
+ chill_predefined_function_type,
+ BUILT_IN_VARIABLE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE",
+ chill_predefined_function_type,
+ BUILT_IN_WRITEABLE, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD",
+ chill_predefined_function_type,
+ BUILT_IN_WRITERECORD, NULL_PTR);
+ builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT",
+ chill_predefined_function_type,
+ BUILT_IN_WRITETEXT, 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,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__create", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__delete", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__disconnect", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__dissociate", void_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__eoln", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__existing", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__getusage", int_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__indexable", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__isassociated", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__outoffile", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__readable", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__sequencible", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__variable", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__writeable", bool_ftype_ptr_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
+ NOT_BUILT_IN, NULL_PTR);
+ builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
+ 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;
+}
+
+#if 0
+ returns a structure like
+ STRUCT (data STRUCT (flags ULONG,
+ reclength ULONG,
+ lowindex LONG,
+ highindex LONG,
+ association PTR,
+ base ULONG,
+ store_loc PTR,
+ rectype LONG),
+ this is followed by a
+ TYPE_DECL __recordmode recordmode ? recordmode : void_type_node
+ TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
+ CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node
+#endif
+
+static tree
+build_access_part ()
+{
+ tree listbase, decl;
+
+ listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
+ long_unsigned_type_node);
+ decl = build_decl (FIELD_DECL, get_identifier ("reclength"),
+ long_unsigned_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("lowindex"),
+ long_unsigned_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("highindex"),
+ long_integer_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("association"),
+ ptr_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("base"),
+ long_unsigned_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"),
+ ptr_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("rectype"),
+ long_integer_type_node);
+ listbase = chainon (listbase, decl);
+ return build_chill_struct_type (listbase);
+}
+
+tree
+build_access_mode (indexmode, recordmode, dynamic)
+ tree indexmode;
+ tree recordmode;
+ int dynamic;
+{
+ tree type, listbase, decl, datamode;
+
+ if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
+ return error_mark_node;
+ if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK)
+ return error_mark_node;
+
+ datamode = build_access_part ();
+
+ type = make_node (RECORD_TYPE);
+ listbase = build_decl (FIELD_DECL, get_identifier ("data"),
+ datamode);
+ TYPE_FIELDS (type) = listbase;
+ decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
+ recordmode == NULL_TREE ? void_type_node : recordmode);
+ chainon (listbase, decl);
+ decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
+ indexmode == NULL_TREE ? void_type_node : indexmode);
+ chainon (listbase, decl);
+ decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
+ integer_type_node);
+ DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
+ chainon (listbase, decl);
+ CH_IS_ACCESS_MODE (type) = 1;
+ CH_TYPE_NONVALUE_P (type) = 1;
+ return type;
+}
+\f
+#if 0
+ returns a structure like:
+ STRUCT (txt STRUCT (flags ULONG,
+ text_record PTR,
+ access_sub PTR,
+ actual_index LONG),
+ acc STRUCT (flags ULONG,
+ reclength ULONG,
+ lowindex LONG,
+ highindex LONG,
+ association PTR,
+ base ULONG,
+ store_loc PTR,
+ rectype LONG),
+ tloc CHARS(textlength) VARYING;
+ )
+ followed by
+ TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
+ CONST_DECL __text_length
+ CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node
+#endif
+tree
+build_text_mode (textlength, indexmode, dynamic)
+ tree textlength;
+ tree indexmode;
+ int dynamic;
+{
+ tree txt, acc, listbase, decl, type, tltype;
+ tree savedlength = textlength;
+
+ if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
+ return error_mark_node;
+ if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK)
+ return error_mark_node;
+
+ /* build the structure */
+ listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
+ long_unsigned_type_node);
+ decl = build_decl (FIELD_DECL, get_identifier ("text_record"),
+ ptr_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("access_sub"),
+ ptr_type_node);
+ listbase = chainon (listbase, decl);
+ decl = build_decl (FIELD_DECL, get_identifier ("actual_index"),
+ long_integer_type_node);
+ listbase = chainon (listbase, decl);
+ txt = build_chill_struct_type (listbase);
+
+ acc = build_access_part ();
+
+ type = make_node (RECORD_TYPE);
+ listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
+ TYPE_FIELDS (type) = listbase;
+ decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
+ chainon (listbase, decl);
+ /* the text location */
+ tltype = build_string_type (char_type_node, textlength);
+ tltype = build_varying_struct (tltype);
+ decl = build_decl (FIELD_DECL, get_identifier ("tloc"),
+ tltype);
+ chainon (listbase, decl);
+ /* the index mode */
+ decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
+ indexmode == NULL_TREE ? void_type_node : indexmode);
+ chainon (listbase, decl);
+ /* save dynamic */
+ decl = build_decl (CONST_DECL, get_identifier ("__textlength"),
+ integer_type_node);
+ if (TREE_CODE (textlength) == COMPONENT_REF)
+ /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build
+ another one */
+ savedlength = build_component_ref (TREE_OPERAND (textlength, 0),
+ TREE_OPERAND (textlength, 1));
+ DECL_INITIAL (decl) = savedlength;
+ chainon (listbase, decl);
+ /* save dynamic */
+ decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
+ integer_type_node);
+ DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
+ chainon (listbase, decl);
+ CH_IS_TEXT_MODE (type) = 1;
+ CH_TYPE_NONVALUE_P (type) = 1;
+ return type;
+}
+
+tree
+check_text_length (type, length)
+ tree type, length;
+{
+ if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK)
+ return length;
+ if (TREE_TYPE (length) == NULL_TREE
+ || !CH_SIMILAR (TREE_TYPE (length), integer_type_node))
+ {
+ error ("non-integral text length");
+ return integer_one_node;
+ }
+ if (TREE_CODE (length) != INTEGER_CST)
+ {
+ error ("non-constant text length");
+ return integer_one_node;
+ }
+ if (compare_int_csts (LE_EXPR, length, integer_zero_node))
+ {
+ error ("text length must be greater then 0");
+ return integer_one_node;
+ }
+ return length;
+}
+
+tree
+text_indexmode (text)
+ tree text;
+{
+ tree field;
+
+ if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
+ return NULL_TREE;
+ if (! CH_IS_TEXT_MODE (text))
+ return NULL_TREE;
+
+ field = TYPE_FIELDS (text);
+ for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == TYPE_DECL)
+ return TREE_TYPE (field);
+ }
+ return void_type_node;
+}
+
+tree
+text_dynamic (text)
+ tree text;
+{
+ tree field;
+
+ if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
+ return NULL_TREE;
+ if (! CH_IS_TEXT_MODE (text))
+ return NULL_TREE;
+
+ field = TYPE_FIELDS (text);
+ for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == CONST_DECL &&
+ DECL_NAME (field) == get_identifier ("__dynamic"))
+ return DECL_INITIAL (field);
+ }
+ return integer_zero_node;
+}
+
+tree
+text_length (text)
+ tree text;
+{
+ tree field;
+
+ if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
+ return NULL_TREE;
+ if (! CH_IS_TEXT_MODE (text))
+ return NULL_TREE;
+
+ field = TYPE_FIELDS (text);
+ for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == CONST_DECL &&
+ DECL_NAME (field) == get_identifier ("__textlength"))
+ return DECL_INITIAL (field);
+ }
+ return integer_zero_node;
+}
+
+static tree
+textlocation_mode (text)
+ tree text;
+{
+ tree field;
+
+ if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
+ return NULL_TREE;
+ if (! CH_IS_TEXT_MODE (text))
+ return NULL_TREE;
+
+ field = TYPE_FIELDS (text);
+ for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
+ {
+ if (TREE_CODE (field) == FIELD_DECL &
+ DECL_NAME (field) == get_identifier ("tloc"))
+ return TREE_TYPE (field);
+ }
+ return NULL_TREE;
+}
+\f
+static int
+check_assoc (assoc, argnum, errmsg)
+ tree assoc;
+ int argnum;
+ 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, arg2, arg3, arg4, arg5, 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;
+ 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, arg2, arg3, arg4, arg5, 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;
+ 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);
+ tree textlength = text_length (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;
+ 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;
+ 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;
+ extern int maximum_field_alignment;
+ 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);
+ char *fieldname = 0;
+ 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;
+
+ 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;
+
+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;
+
+/* 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;
+
+ 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;
+ 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;
+ }
+
+ do_the_action: ;
+ 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 neccesary enum-tables used for
+ WRITETEXT or READTEXT of an enum */
+
+void build_enum_tables ()
+{
+ SAVE_ENUM_NAMES *names;
+ SAVE_ENUMS *wrk;
+ void *saveptr;
+ /* We temporarily reset the maximum_field_alignment to zero so the
+ compiler's init data structures can be compatible with the
+ run-time system, even when we're compiling with -fpack. */
+ extern int maximum_field_alignment;
+ 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
+/* Lexical analyzer for GNU CHILL. -*- C -*-
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+\f
+#include <stdio.h>
+#include <errno.h>
+#include <setjmp.h>
+#include <ctype.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#include "config.h"
+#include "tree.h"
+#include "input.h"
+
+#include "lex.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "parse.h"
+#include "obstack.h"
+
+#ifdef MULTIBYTE_CHARS
+#include <stdlib.h>
+#include <locale.h>
+#endif
+
+/* include the keyword recognizers */
+#include "hash.h"
+
+#undef strchr
+
+FILE* finput;
+
+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); }
+
+/* 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;
+
+#ifndef errno
+extern int errno;
+#endif
+
+extern tree build_string_type PROTO((tree, tree));
+extern void error PROTO((char *, ...));
+extern void error_with_file_and_line PROTO((char *, int, char *, ...));
+extern void grant_use_seizefile PROTO((char *));
+extern void pedwarn PROTO((char *, ...));
+extern void pfatal_with_name PROTO((char *));
+extern void push_obstacks PROTO((struct obstack *, struct obstack *));
+extern void set_identifier_size PROTO((int));
+extern void sorry PROTO((char *, ...));
+extern int target_isinf PROTO((REAL_VALUE_TYPE));
+extern int tolower PROTO((int));
+extern void warning PROTO((char *, ...));
+
+/* forward declarations */
+static void close_input_file PROTO((char *));
+static tree convert_bitstring PROTO((char *));
+static tree convert_integer PROTO((char *));
+static void maybe_downcase PROTO((char *));
+static int maybe_number PROTO((char *));
+static tree equal_number PROTO((void));
+static void handle_use_seizefile_directive PROTO((int));
+static int handle_name PROTO((tree));
+static void push_back PROTO((int));
+static char *readstring PROTO((int, int *));
+static void read_directive PROTO((void));
+static tree read_identifier PROTO((int));
+static tree read_number PROTO((int));
+static void skip_c_comment PROTO((void));
+static void skip_line_comment PROTO((void));
+static int skip_whitespace PROTO((void));
+static tree string_or_char PROTO((int, char *));
+
+/* 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;
+}
+
+
+char *
+init_parse (filename)
+ 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)
+ pfatal_with_name (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 ();
+
+#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;
+
+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)
+ 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 (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 (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;
+ 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;
+ 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)
+ {
+ if (isupper (*str))
+ *str = tolower (*str);
+ str++;
+ }
+}
+
+
+static int
+maybe_number (s)
+ 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 (*s))
+ return 0;
+ break;
+ case 'b':
+ case 'B':
+ if (*s < '0' || *s > '1')
+ return 0;
+ break;
+ case 'o':
+ case 'O':
+ if (*s < '0' || *s > '7')
+ return 0;
+ break;
+ default:
+ return 0;
+ }
+ s++;
+ }
+ return 1;
+}
+
+static void
+push_back (c)
+char c;
+{
+ if (c == '\n')
+ lineno--;
+ unput (c);
+}
+\f
+static char *
+readstring (terminator, len)
+ char terminator;
+ int *len;
+{
+ int c;
+ unsigned allocated = 1024;
+ char *tmp = xmalloc (allocated);
+ int 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);
+ if (oldp == 0) fatal ("stack space exhausted");
+ 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)
+ char *filename1;
+ char *filename2;
+{
+ struct stat s[2];
+ char *fn_input[2];
+ int i, stat_status;
+ extern char *strchr();
+
+ 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)
+ pfatal_with_name (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
+ */
+int
+getlc (file)
+ FILE *file;
+{
+ register int c;
+
+ c = getc (file);
+ if (isupper (c) && ignore_case)
+ c = tolower (c);
+ return c;
+}
+\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 (isupper (c) && 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'
+ && (isspace (c = getlc (finput))))
+ {
+#ifdef HANDLE_PRAGMA
+ return HANDLE_PRAGMA (finput, c);
+#else
+ goto skipline;
+#endif /* HANDLE_PRAGMA */
+ }
+ }
+
+ else if (c == 'd')
+ {
+ if (getlc (finput) == 'e'
+ && getlc (finput) == 'f'
+ && getlc (finput) == 'i'
+ && getlc (finput) == 'n'
+ && getlc (finput) == 'e'
+ && (isspace (c = getlc (finput))))
+ {
+#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'
+ && (isspace (c = getlc (finput))))
+ {
+#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 cccp.c. */
+
+ /* 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 (*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)
+ 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 *strchr ();
+ extern char *chill_real_input_filename;
+ tree node;
+
+ close_input_file (input_filename);
+
+ use_seizefile_name = NULL_TREE;
+
+ if (next_file_to_seize && !grant_only_flag)
+ {
+ FILE *grt_in = NULL;
+ 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)
+ pfatal_with_name (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
+/* Implement looping actions for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <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 PROTO((tree));
+extern rtx emit_line_note PROTO((char *, int));
+extern void error PROTO((char *, ...));
+extern rtx expand_assignment PROTO((tree, tree, int, int));
+extern void save_expr_under_name PROTO((tree, tree));
+extern void stamp_nesting_label PROTO((tree));
+extern int int_fits_type_p PROTO((tree, tree));
+extern void warning PROTO((char *, ...));
+
+/* forward declarations */
+static int classify_loop PROTO((void));
+static int declare_temps PROTO((void));
+static int initialize_iter_var PROTO((void));
+static int maybe_skip_loop PROTO((void));
+static int top_loop_end_check PROTO((void));
+static int bottom_loop_end_check PROTO((void));
+static int increment_temps PROTO((void));
+static tree build_temporary_variable PROTO((char *, tree));
+static tree maybe_make_for_temp PROTO((tree, char *, tree));
+static tree chill_unsigned_type PROTO((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
+#if 0
+
+Here is a CHILL DO FOR statement:
+
+DO FOR user_var := start_exp BY step_exp [DOWN] TO end_exp
+ WHILE condition;
+
+For this loop to be 'safe', like a Pascal FOR loop, the start,
+end, and increment expressions are computed once, before the
+assignment to the iteration variable and saved in temporaries,
+before the first assignment of the iteration variable, so the
+following works:
+
+ FOR i := (i+1) TO (i+10) DO
+
+To prevent changes to the start/end/step expressions from
+effecting the loop''s termination, and to make the loop end-check
+as simple as possible, we evaluate the step expression into
+a temporary and compute a hidden iteration count before entering
+the loop''s body. User code cannot effect the counter, and the
+end-loop check simply decrements the counter and checks for zero.
+
+The whole phrase FOR iter := ... TO end_exp can be repeated
+multiple times, with different user-iteration variables. This
+is discussed later.
+
+The loop counter calculations need careful design since a loop
+from MININT TO MAXINT must work, in the precision of integers.
+
+Here''s how it works, in C:
+
+ 0) The DO ... OD loop is simply a block with
+ its own scope.
+
+ 1) The DO FOR EVER is simply implemented:
+
+ loop_top:
+ .
+ . body of loop
+ .
+ goto loop_top
+ end_loop:
+
+ 2) The DO WHILE is also simple:
+
+
+ loop_top:
+ if (!condition) goto end_loop
+ .
+ . body of loop
+ .
+ goto loop_top
+ end_loop:
+
+
+ 3) The DO FOR [while condition] loop (no DOWN)
+
+ push a new scope,
+ decl iter_var
+
+ step_temp = step_exp
+ start_temp = start_exp
+ end_temp = end_exp
+ if (end_exp < start_exp) goto end_loop
+ /* following line is all unsigned arithmetic */
+ iter_var = (end_exp - start_exp + step_exp) / step_exp
+ user_var = start_temp
+ loop_top:
+ if (!condition) goto end_loop
+ .
+ . body of loop
+ .
+ iter_var--
+ if (iter_var == 0) goto end_loop
+ user_var += step_temp
+ goto loop_top
+ end_loop:
+ pop scope
+
+ 4) The proposed CHILL for [while condition] loop (with DOWN)
+
+ push a new scope,
+ decl iter
+ step_temp = step_exp
+ start_temp = start_exp
+ end_temp = end_exp
+ if (end_exp > start_exp) goto end_loop
+ /* following line is all unsigned arithmetic */
+ iter_var = (start_exp - end_exp + step_exp) / step_exp
+ user_var = start_temp
+ loop_top:
+ if (!condition) goto end_loop
+ .
+ . body of loop
+ .
+ iter_var--
+ if (iter_var == 0) goto end_loop
+ user_var -= step_temp
+ goto loop_top
+ end_loop:
+ pop scope
+
+
+ 5) The range loop, which iterates over a mode''s possible
+ values, works just like the above step loops, but with
+ the start and end values taken from the mode''s lower
+ and upper domain values.
+\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.
+#endif
+\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
+typedef union {
+ long itype;
+ tree ttype;
+ enum tree_code code;
+ char *filename;
+ int lineno;
+} YYSTYPE;
+extern YYSTYPE yylval;
+
+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, NOT, NUMBER,
+ OD, OF, ON, OR, ORIF,
+ PARAMATTR, PERVASIVE, PLUS, 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,
+
+ /* These tokens are recognized in the lexer, and completely
+ ignored. They represent unimplemented features in the
+ current version of GNU CHILL. */
+ NOPACK, PACK,
+
+/* These tokens are recognized in the lexer, and returned
+ as reserved tokens, to prevent users from using them
+ accidently (they'll cause a parser syntax error). They
+ represent unimplemented features in the current version
+ of GNU CHILL. */
+ POS, /*STEP, ROW,*/
+
+/* 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
+/* Implement string-related runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Bill Cox
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define MIN(a, b) ((a) < (b) ? (a) : (b))
+
+extern void cause_exception (char *exname, char *file, int lineno);
+
+/*
+ * function __concatstring
+ *
+ * parameters:
+ * OUT - pointer to output string
+ * S1 - pointer to left string
+ * LEN1 - length of left string
+ * S2 - pointer to right string
+ * LEN2 - length of right string
+ *
+ * returns:
+ * pointer to OUT string
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * concatenates two character strings into the output string
+ *
+ */
+
+char *
+__concatstring (out, s1, len1, s2, len2)
+ char *out, *s1;
+ int len1;
+ char *s2;
+ int len2;
+{
+ if (out)
+ {
+ if (s2 /* Check for overlap between s2 and out. */
+ && ((s2 >= out && s2 < (out + len1 + len2))
+ || (s2 + len2 > out && s2 <= out + len1)))
+ {
+ char *tmp = alloca (len2);
+ memcpy (tmp, s2, len2);
+ s2 = tmp;
+ }
+ if (s1)
+ memmove (out, s1, len1);
+ if (s2)
+ memcpy (&out[len1], s2, len2);
+ }
+ return out;
+}
--- /dev/null
+/* Implement tasking-related runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "rtltypes.h"
+#include "rts.h"
+
+/*
+ * function __continue
+ *
+ * parameters:
+ * evaddr pointer to Eventlocation
+ * filename source file name where function gets called
+ * lineno linenumber in source file
+ *
+ * returns:
+ * void
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * implement the CHILL CONTINUE action.
+ */
+
+void
+__continue (evaddr, filename, lineno)
+ Event_Queue **evaddr;
+ char *filename;
+ int lineno;
+{
+ Event_Queue *ev = *evaddr;
+ Event_Queue *wrk;
+
+ if (ev == 0)
+ /* nothing to do */
+ return;
+
+ /* search for 1st one is not already continued */
+ while (ev && ev->is_continued)
+ ev = ev->forward;
+ if (!ev)
+ /* all have been continued in that queue, do nothing */
+ return;
+
+ wrk = ev->startlist;
+ while (wrk)
+ {
+ Event_Queue *tmp = (Event_Queue *)wrk->listhead;
+
+ while (tmp->forward != wrk)
+ tmp = tmp->forward;
+ tmp->forward = wrk->forward;
+ wrk = wrk->chain;
+ }
+
+ /* so far so good, continue this one */
+ ev->is_continued = 1;
+ ev->who_continued = THIS;
+
+ /* tell the runtime system to activate the process */
+ __continue_that (ev->this, ev->priority, filename, lineno);
+}
+
+/* force function print_event to be linked */
+extern void __print_event ();
+static EntryPoint pev = __print_event;
--- /dev/null
+/* Implement timing-related runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "rts.h"
+
+/*
+ * function __convert_duration_rtstime
+ *
+ * parameters:
+ * dur the duration value
+ * t pointer to the duration value converted to RtsTime
+ *
+ * returns:
+ * void
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * converts a duration value (unsigned long in millisecs) to RtsTime
+ * format.
+ *
+ */
+
+void
+__convert_duration_rtstime (dur, t)
+ unsigned long dur;
+ RtsTime *t;
+{
+ unsigned long tmp;
+
+ t->secs = dur / 1000;
+ tmp = dur - (t->secs * 1000);
+ t->nanosecs = tmp * 1000000;
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __ffsetclrpowerset
+ *
+ * parameters:
+ * ps powerset
+ * bitlength length of powerset
+ *
+ * returns:
+ * int -1 .. nothing found
+ * >=0 .. index of first true bit found
+ * exceptions:
+ * none
+ */
+
+int
+__ffsetclrpowerset (ps, bitlength, first_bit)
+ SET_WORD *ps;
+ unsigned long bitlength;
+ int first_bit;
+{
+ register int bitno;
+
+ if (first_bit >= bitlength)
+ return -1;
+
+#ifndef USE_CHARS
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ for (bitno = first_bit; bitno < bitlength; bitno++)
+ if (GET_BIT_IN_CHAR (*((SET_CHAR *)ps), bitno))
+ break;
+ return bitno == bitlength ? -1 : bitno;
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ for (bitno = first_bit; bitno < bitlength; bitno++)
+ if (GET_BIT_IN_SHORT (*((SET_SHORT *)ps), bitno))
+ break;
+ return bitno == bitlength ? -1 : bitno;
+ }
+ else
+#endif
+ {
+ unsigned int words_to_skip = (unsigned) first_bit / SET_WORD_SIZE;
+ unsigned long cnt = words_to_skip * SET_WORD_SIZE;
+ SET_WORD *p = ps + words_to_skip;
+ SET_WORD *endp = ps + BITS_TO_WORDS(bitlength);
+ SET_WORD c;
+ first_bit = (unsigned) first_bit % (unsigned) SET_WORD_SIZE;
+
+ c = *p++;
+ if (c)
+ {
+ for (bitno = first_bit; bitno < SET_WORD_SIZE; bitno++)
+ if (GET_BIT_IN_WORD(c, bitno))
+ goto found;
+ }
+ cnt += SET_WORD_SIZE;
+
+ while (p < endp)
+ {
+ if ((c = *p++))
+ {
+ /* found a bit set .. calculate which */
+ for (bitno = 0; bitno < SET_WORD_SIZE; bitno++)
+ if (GET_BIT_IN_WORD(c, bitno))
+ goto found;
+ }
+ cnt += SET_WORD_SIZE;
+ }
+ return -1;
+ found:
+ bitno += cnt;
+ return bitno >= bitlength ? -1 : bitno;
+ }
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __flsetclrpowerset
+ *
+ * parameters:
+ * ps powerset
+ * bitlength length of powerset
+ *
+ * returns:
+ * int -1 .. nothing found
+ * >= 0 .. index of last set bit
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * Find last bit set in a powerset and return the corresponding value
+ * in *out and clear this bit. Return 0 for no more found, else 1.
+ *
+ */
+int
+__flsetclrpowerset (ps, bitlength, first_bit)
+ SET_WORD *ps;
+ unsigned long bitlength;
+ int first_bit;
+{
+ register int bitno;
+
+#ifndef USE_CHARS
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ for (bitno = bitlength - 1; bitno >= first_bit; bitno--)
+ if (GET_BIT_IN_CHAR (*((SET_CHAR *)ps), bitno))
+ break;
+ return bitno < first_bit ? -1 : bitno;
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ for (bitno = bitlength - 1; bitno >= first_bit; bitno--)
+ if (GET_BIT_IN_SHORT (*((SET_SHORT *)ps), bitno))
+ break;
+ return bitno < first_bit ? -1 : bitno;
+ }
+ else
+#endif
+ {
+ SET_WORD *p, c;
+ bitno = bitlength - 1;
+ if (bitno < first_bit)
+ return -1;
+ p = &ps[(unsigned) bitno / SET_WORD_SIZE];
+ c = *p;
+ if (((unsigned) bitlength % SET_WORD_SIZE) != 0)
+ MASK_UNUSED_WORD_BITS(&c, (unsigned) bitlength % SET_WORD_SIZE);
+ if (c)
+ goto found;
+ else
+ bitno -= ((unsigned) bitno % SET_WORD_SIZE) + 1;
+ while (bitno >= first_bit)
+ {
+ c = *--p;
+ if (c)
+ goto found;
+ bitno -= SET_WORD_SIZE;
+ }
+ return -1;
+ found:
+ for (; bitno >= first_bit; bitno--)
+ {
+ if (GET_BIT_IN_WORD (c, (unsigned) bitno % SET_WORD_SIZE))
+ return bitno;
+ }
+ return -1;
+ }
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __lepowerset
+ *
+ * parameters:
+ * left powerset
+ * right powerset
+ * bitlength length of powerset
+ *
+ * returns:
+ * int 1 .. left is included in right
+ * 0 .. not
+ *
+ * abstract:
+ * check if one powerset is included in another
+ *
+ */
+int
+__lepowerset (left, right, bitlength)
+ SET_WORD *left;
+ SET_WORD *right;
+ unsigned long bitlength;
+{
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ if ((*((SET_CHAR *)left) & *((SET_CHAR *)right))
+ != *((SET_CHAR *)left))
+ return 0;
+ return 1;
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ if ((*((SET_SHORT *)left) & *((SET_SHORT *)right))
+ != *((SET_SHORT *)left))
+ return 0;
+ return 1;
+ }
+ else
+ {
+ SET_WORD *endp = left + BITS_TO_WORDS(bitlength);
+
+ while (left < endp)
+ {
+ if ((*right & *left) != *left)
+ return 0;
+ left++;
+ right++;
+ }
+ return 1;
+ }
+}
--- /dev/null
+/* Common macros for POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _POWERSET_H
+#define _POWERSET_H
+
+#define USE_CHARS
+
+#ifdef USE_CHARS
+
+#define SET_WORD unsigned char
+#define SET_CHAR unsigned char
+#define SET_SHORT unsigned char
+
+#else
+
+#ifndef SET_WORD
+#define SET_WORD unsigned int
+#endif
+#define SET_CHAR unsigned char
+#define SET_SHORT unsigned short
+#endif
+
+#define SET_WORD_SIZE (BITS_PER_UNIT * sizeof (SET_WORD))
+#define SET_SHORT_SIZE (BITS_PER_UNIT * sizeof (SET_SHORT))
+#define SET_CHAR_SIZE BITS_PER_UNIT
+
+/* Powersets and bit strings are stored as arrays of SET_WORD.
+ if they are a word or longer. Powersets and bit strings whic
+ fit in a byte or short are stored that way by the compiler.
+
+ The order of the bits follows native bit order:
+ If BITS_BIG_ENDIAN, bit 0 is the most significant bit (i.e. 0x80..00);
+ otherwise, bit 0 is the least significant bit (i.e. 0x1).
+
+ MASK_UNUSED_BITS masks out unused bits in powersets and bitstrings.
+ GET_BIT_IN_WORD(W,B) yields 1 (or 0) if the B'th bit if W is set (cleared).
+*/
+
+#if BITS_BIG_ENDIAN
+#define GET_BIT_IN_WORD(w,b) (((w) >> (SET_WORD_SIZE - 1 - (b))) & 1)
+#define GET_BIT_IN_SHORT(w,b) (((w) >> (SET_SHORT_SIZE - 1 - (b))) & 1)
+#define GET_BIT_IN_CHAR(w,b) (((w) >> (SET_CHAR_SIZE - 1 - (b))) & 1)
+
+#define SET_BIT_IN_WORD(w,b) ((w) |= 1 << ((SET_WORD_SIZE) - 1 - (b)))
+#define SET_BIT_IN_SHORT(w,b) ((w) |= 1 << ((SET_SHORT_SIZE) - 1 - (b)))
+#define SET_BIT_IN_CHAR(w,b) ((w) |= 1 << ((SET_CHAR_SIZE) - 1 - (b)))
+
+#define CLEAR_BIT_IN_WORD(w,b) ((w) &= ~(1 << ((SET_WORD_SIZE) - 1 - (b))))
+#define CLEAR_BIT_IN_SHORT(w,b) ((w) &= ~(1 << ((SET_SHORT_SIZE) - 1 - (b))))
+#define CLEAR_BIT_IN_CHAR(w,b) ((w) &= ~(1 << ((SET_CHAR_SIZE) - 1 - (b))))
+#define MASK_UNUSED_WORD_BITS(p,b) \
+{ if (b) *(p) &= (~0) << (SET_WORD_SIZE - (b)); }
+#define MASK_UNUSED_SHORT_BITS(p,b) \
+{ if (b) *(p) &= (~0) << (SET_SHORT_SIZE - (b)); }
+#define MASK_UNUSED_CHAR_BITS(p,b) \
+{ if (b) *(p) &= (~0) << (SET_CHAR_SIZE - (b)); }
+
+#else /* !BITS_BIG_ENDIAN */
+
+#define GET_BIT_IN_WORD(w,b) (((w) >> (b)) & 1)
+#define GET_BIT_IN_SHORT(w,b) GET_BIT_IN_WORD(w,b)
+#define GET_BIT_IN_CHAR(w,b) GET_BIT_IN_WORD(w,b)
+
+#define SET_BIT_IN_WORD(w,b) ((w) |= 1 << (b))
+#define SET_BIT_IN_SHORT(w,b) SET_BIT_IN_WORD(w,b)
+#define SET_BIT_IN_CHAR(w,b) SET_BIT_IN_WORD(w,b)
+
+#define CLEAR_BIT_IN_WORD(w,b) ((w) &= ~(1 << (b)))
+#define CLEAR_BIT_IN_SHORT(w,b) CLEAR_BIT_IN_WORD(w,b)
+#define CLEAR_BIT_IN_CHAR(w,b) CLEAR_BIT_IN_WORD(w,b)
+
+#define MASK_UNUSED_WORD_BITS(p,b) \
+{ if (b) *(p) &= ~((~0) << (b)); }
+#define MASK_UNUSED_SHORT_BITS(p,b) MASK_UNUSED_WORD_BITS(p,b)
+#define MASK_UNUSED_CHAR_BITS(p,b) MASK_UNUSED_WORD_BITS(p,b)
+
+#endif
+
+
+/* Number of words needed for a bitstring/powerset of size BITLENGTH.
+ This definition handles the (BITLENGTH==0) by yielding 0. */
+
+#define BITS_TO_WORDS(BITLENGTH) \
+ (((BITLENGTH) + (SET_WORD_SIZE-1)) / SET_WORD_SIZE)
+#define BITS_TO_CHARS(BITLENGTH) \
+ (((BITLENGTH) + (SET_CHAR_SIZE-1)) / SET_CHAR_SIZE)
+
+#endif
--- /dev/null
+/* Implement tasking-related runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "rtltypes.h"
+#include "rts.h"
+
+/*
+ * function __queue_length
+ *
+ * parameters:
+ * buf_ev Buffer or event location
+ * is_event 0 .. buf_ev is a buffer location
+ * 1 .. buf_ev is an event location
+ *
+ * returns:
+ * int number of delayed processeson an event location
+ * or number of send delayed processes on a buffer
+ *
+ * exceptions:
+ * none
+ *
+ * abstract:
+ * implements the QUEUE_LENGTH built-in.
+ *
+ */
+
+int
+__queue_length (buf_ev, is_event)
+ void *buf_ev;
+ int is_event;
+{
+ int retval = 0;
+
+ /* if buf_ev == 0 then we don't have anything */
+ if (buf_ev == 0)
+ return 0;
+
+ if (is_event)
+ {
+ /* process an event queue */
+ Event_Queue *ev = buf_ev;
+
+ while (ev)
+ {
+ retval++;
+ ev = ev->forward;
+ }
+ }
+ else
+ {
+ /* process a buffer queue */
+ Buffer_Queue *bq = buf_ev;
+ Buffer_Send_Queue *bsq = bq->sendqueue;
+
+ while (bsq)
+ {
+ retval++;
+ bsq = bsq->forward;
+ }
+ }
+ return retval;
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <setjmp.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <unistd.h>
+
+#include "fileio.h"
+
+#ifdef EOF
+#undef EOF
+#endif
+#define EOF -1
+
+static
+Boolean
+doRead( Access_Mode* the_access, void* buf, size_t nbyte )
+{
+ size_t nread;
+
+ nread = read( the_access->association->handle, buf, nbyte );
+ if( nread == nbyte )
+ {
+ CLR_FLAG( the_access, IO_OUTOFFILE );
+ return True;
+ }
+ if( nread == 0 )
+ {
+ SET_FLAG( the_access, IO_OUTOFFILE );
+ return False;
+ }
+ the_access->association->syserrno = errno;
+ RWEXCEPTION( READFAIL, OS_IO_ERROR );
+ /* no return */
+}
+
+static
+int bgetc( int handle, readbuf_t* rbptr )
+{
+ if( rbptr->cur >= rbptr->len )
+ {
+ rbptr->len = read( handle, rbptr->buf, READBUFLEN );
+ if( rbptr->len == 0 )
+ return EOF;
+ rbptr->cur = 0;
+ }
+ return rbptr->buf[rbptr->cur++];
+}
+
+static
+void bungetc( readbuf_t* rbptr, int c )
+{
+ rbptr->buf[--rbptr->cur] = c;
+}
+
+void*
+__readrecord( Access_Mode* the_access,
+ signed long the_index,
+ char* the_buf_addr,
+ char* file,
+ int line )
+{
+ unsigned long info;
+ char* actaddr;
+ unsigned short actlen;
+ off_t filepos;
+ unsigned short reclen;
+ unsigned long readlen;
+
+ if( !the_access )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+ if( !the_access->association )
+ CHILLEXCEPTION( file, line, NOTCONNECTED, IS_NOT_CONNECTED );
+
+ /* Usage must not be WriteOnly */
+ if( the_access->association->usage == WriteOnly )
+ CHILLEXCEPTION( file, line, READFAIL, BAD_USAGE );
+
+ /* OUTOFFILE must not be True when connected for sequential read */
+ if( !TEST_FLAG( the_access, IO_INDEXED )
+ && TEST_FLAG( the_access, IO_OUTOFFILE ) )
+ CHILLEXCEPTION( file, line, READFAIL, OUT_OF_FILE );
+
+ /*
+ * Positioning
+ */
+ if( TEST_FLAG( the_access, IO_INDEXED ) )
+ {
+ /* index expression must be within bounds of index mode */
+ if( the_index < the_access->lowindex
+ || the_access->highindex < the_index )
+ CHILLEXCEPTION( file, line, RANGEFAIL, BAD_INDEX );
+
+ filepos = the_access->base +
+ (the_index - the_access->lowindex) * the_access->reclength;
+
+ if( lseek( the_access->association->handle, filepos, SEEK_SET ) == -1L )
+ CHILLEXCEPTION( file, line, READFAIL, LSEEK_FAILS );
+ }
+
+ /* establish store loc */
+ if( !(actaddr = the_buf_addr ))
+ {
+ /* if not yet allocated, do it now */
+ if (!the_access->store_loc)
+ if( !(the_access->store_loc = (char*)malloc( the_access->reclength ) ) )
+ CHILLEXCEPTION( file, line, SPACEFAIL, STORE_LOC_ALLOC );
+ actaddr = the_access->store_loc;
+ }
+ actlen = the_access->reclength;
+
+ if( (info = setjmp( __rw_exception )) )
+ CHILLEXCEPTION( file, line, info>>16, info & 0xffff );
+
+ if( TEST_FLAG( the_access, IO_TEXTIO ) )
+ {
+ readlen = actlen - 2;
+ if( TEST_FLAG( the_access, IO_INDEXED ) )
+ {
+ if( ! doRead( the_access, &reclen, sizeof(reclen) ) )
+ return NULL;
+ if( reclen > readlen )
+ CHILLEXCEPTION( file, line, RANGEFAIL, RECORD_TOO_LONG );
+ if( ! doRead( the_access, actaddr + 2, reclen ) )
+ CHILLEXCEPTION( file, line, READFAIL, RECORD_TOO_SHORT );
+ }
+ else
+ {
+ Association_Mode *assoc = the_access->association;
+ int handle = assoc->handle;
+ readbuf_t* rbuf = assoc->bufptr;
+ char* cptr = actaddr+2;
+ int curr;
+
+ reclen = 0;
+ while( readlen-- )
+ {
+ curr = bgetc( handle, rbuf );
+ if( curr == '\n' )
+ goto end_of_line;
+ if( curr == EOF )
+ {
+ if( !reclen )
+ SET_FLAG( the_access, IO_OUTOFFILE );
+ goto end_of_line;
+ }
+ *cptr++ = curr;
+ reclen++;
+ }
+ if( (curr = bgetc( handle, rbuf )) != '\n' )
+ {
+ bungetc( rbuf, curr );
+ CHILLEXCEPTION( file, line, RANGEFAIL, RECORD_TOO_LONG );
+ }
+end_of_line: ;
+ }
+ MOV2(actaddr,&reclen);
+ }
+ else
+ {
+ switch( the_access->rectype )
+ {
+ case Fixed:
+ if( ! doRead( the_access, actaddr, actlen ) )
+ return NULL;
+ break;
+ case VaryingChars:
+ if( TEST_FLAG( the_access->association, IO_VARIABLE ) )
+ {
+ if( ! doRead( the_access, &reclen, sizeof(reclen) ) )
+ return NULL;
+ if( reclen > actlen - 2 )
+ CHILLEXCEPTION( file, line, RANGEFAIL, RECORD_TOO_LONG );
+ readlen = TEST_FLAG( the_access, IO_INDEXED ) ? actlen - 2 : reclen;
+ if( ! doRead( the_access, actaddr + 2, readlen ) )
+ CHILLEXCEPTION( file, line, READFAIL, RECORD_TOO_SHORT );
+ }
+ else
+ {
+ if( ! doRead( the_access, actaddr + 2, reclen = actlen - 2 ) )
+ CHILLEXCEPTION( file, line, READFAIL, RECORD_TOO_SHORT );
+ }
+ MOV2(actaddr,&reclen);
+ break;
+ }
+ }
+
+ return actaddr;
+}
--- /dev/null
+/* Implement runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+/*#include "gvarargs.h" Gcc source and runtime libs use gvarargs.h */
+
+#include "rtltypes.h"
+
+typedef void (*init_ptr) ();
+typedef int * tasking_ptr;
+
+/* Dummy functions for rts access. When we come here we have an error. */
+
+typedef char *(*fetch_names) (int number);
+typedef int (*fetch_numbers) (char *name);
+
+static void __rts_main_loop ()
+{
+ /* do nothing in case of no run time system */
+}
+init_ptr __RTS_MAIN_LOOP__ = __rts_main_loop;
+
+static void __rts_init ()
+{
+ /* do nothing in case of no run time system */
+}
+init_ptr __RTS_INIT__ = __rts_init;
+
+static char *__fetch_name (int number)
+{
+ fprintf (stderr, "ChillLib: fetch_name: no runtime system library linked.\n");
+ fflush (stderr);
+ abort ();
+}
+fetch_names __RTS_FETCH_NAMES__ = __fetch_name;
+
+static int __fetch_number (char *name)
+{
+ fprintf (stderr, "ChillLib: fetch_number: no runtime system library linked.\n");
+ fflush (stderr);
+ abort ();
+}
+fetch_numbers __RTS_FETCH_NUMBERS__ = __fetch_number;
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+Boolean
+__sequencible( Association_Mode* the_assoc, char* file, int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+ if( !TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+ return TEST_FLAG(the_assoc, IO_SEQUENCIBLE) ? True : False;
+}
+
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+extern void __cause_ex1 (char *exname, char *file, int lineno);
+
+/*
+ * function __setbitpowerset
+ *
+ * parameters:
+ * set destination set
+ * bitlength length of powerset in bits
+ * minval lowest valid set value
+ * bitno bit number within set
+ * new_value zero or one - (new bit value)
+ *
+ * returns:
+ * int 1 .. found
+ * 0 .. not found
+ *
+ * exceptions:
+ * rangefail
+ *
+ * abstract:
+ * checks if a given value is included in a powerset
+ *
+ */
+void
+__setbitpowerset (powerset, bitlength, minval, bitno, new_value, filename, lineno)
+ SET_WORD *powerset;
+ unsigned long bitlength;
+ long minval;
+ long bitno;
+ char new_value; /* booleans are represented as 8 bit value */
+ char * filename;
+ int lineno;
+{
+ if (powerset == NULL
+ || bitno < minval
+ || (bitno - minval) >= bitlength)
+ __cause_ex1 ("rangefail", filename, lineno);
+
+ bitno -= minval;
+ if (bitlength <= SET_CHAR_SIZE)
+ {
+ if (new_value & 1)
+ SET_BIT_IN_CHAR (*((SET_CHAR *)powerset), bitno);
+ else
+ CLEAR_BIT_IN_CHAR (*((SET_CHAR *)powerset), bitno);
+ }
+ else if (bitlength <= SET_SHORT_SIZE)
+ {
+ if (new_value & 1)
+ SET_BIT_IN_SHORT (*((SET_SHORT *)powerset), bitno);
+ else
+ CLEAR_BIT_IN_SHORT (*((SET_SHORT *)powerset), bitno);
+ }
+ else
+ {
+ powerset += (bitno/SET_WORD_SIZE);
+ bitno %= SET_WORD_SIZE;
+ if (new_value & 1)
+ SET_BIT_IN_WORD (*powerset, bitno);
+ else
+ CLEAR_BIT_IN_WORD (*powerset, bitno);
+ }
+}
--- /dev/null
+/* Implement POWERSET runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+extern void __cause_ex1 (char *exname, char *file, int lineno);
+
+/*
+ * function __setbits
+ *
+ * parameters:
+ * out result
+ * bitlength length of bitstring in bits
+ * startbit starting bitnumber
+ * endbit ending bitnumber
+ *
+ * returns:
+ * void
+ *
+ * exceptions:
+ * rangefail
+ *
+ * abstract:
+ * set all bits from starting bitnumber to ending bitnumber
+ * in a powerset
+ *
+ */
+void
+__setbits (out, bitlength, startbit, endbit)
+ SET_WORD *out;
+ unsigned long bitlength;
+ long startbit;
+ long endbit;
+{
+ unsigned long i;
+
+ if (out == NULL
+ || startbit < 0
+ || startbit >= bitlength
+ || endbit < 0
+ || endbit >= bitlength
+ || endbit < startbit)
+ __cause_ex1 ("rangefail", "__setbits", __LINE__);
+
+ if (bitlength <= SET_CHAR_SIZE)
+ for (i = startbit; i <= endbit; i++)
+ SET_BIT_IN_CHAR (*((SET_CHAR *)out), i);
+ else if (bitlength <= SET_SHORT_SIZE)
+ for (i = startbit; i <= endbit; i++)
+ SET_BIT_IN_SHORT (*((SET_SHORT *)out), i);
+ else
+ {
+ SET_WORD *p;
+ unsigned long bitnr;
+
+ /* FIXME - this is inefficient! */
+ for (i = startbit; i <= endbit; i++)
+ {
+ p = out + (i / SET_WORD_SIZE);
+ bitnr = i % SET_WORD_SIZE;
+ SET_BIT_IN_WORD (*p, bitnr);
+ }
+ }
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+void
+__settextindex( Text_Mode* the_text,
+ signed long the_text_index,
+ char* file,
+ int line )
+{
+ if( !the_text )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_TEXT );
+
+ if( the_text_index < 0
+ || the_text->access_sub->reclength - 2 < the_text_index )
+ CHILLEXCEPTION( file, line, TEXTFAIL, BAD_TEXTINDEX );
+
+ the_text->actual_index = the_text_index;
+}
+
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+Boolean
+__variable( Association_Mode* the_assoc, char* file, int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+ if( !TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+ return TEST_FLAG( the_assoc, IO_VARIABLE ) ? True : False;
+}
--- /dev/null
+/* Implement Input/Output runtime actions for CHILL.
+ Copyright (C) 1992,1993 Free Software Foundation, Inc.
+ Author: Wilfried Moser, et al
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "fileio.h"
+
+Boolean
+__writeable( Association_Mode* the_assoc, char* file, int line )
+{
+ if( !the_assoc )
+ CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+ if( !TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+ CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+ return TEST_FLAG(the_assoc, IO_WRITEABLE) ? True : False;
+}
--- /dev/null
+/* Implement process-related declarations for CHILL.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _CH_TASKING_H
+#define _CH_TASKING_H
+
+/* list of this module's process, buffer, etc. decls */
+extern tree tasking_list;
+
+#endif
--- /dev/null
+/* Language-dependent node constructors for parse phase of GNU compiler.
+ Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include "config.h"
+#include "obstack.h"
+#include "tree.h"
+#include "ch-tree.h"
+
+/* Here is how primitive or already-canonicalized types'
+ hash codes are made. */
+#define TYPE_HASH(TYPE) ((HOST_WIDE_INT) (TYPE) & 0777777)
+
+extern void error PROTO((char *, ...));
+extern int get_type_precision PROTO((tree, tree));
+
+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;
+\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, integer_one_node);
+ else
+ length = build (MINUS_EXPR, sizetype, length, integer_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
+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)
+ 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);
+
+ 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;
+{
+ 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);
+}
projects / gcc.git / commitdiff