From 80a093b29e752ac54172945174c7cd59cec1fd05 Mon Sep 17 00:00:00 2001 From: Per Bothner Date: Thu, 27 Aug 1998 13:51:39 -0700 Subject: =?UTF-8?q?=EF=BF=BD=20Migrate=20from=20devo/gcc/ch.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit From-SVN: r22034 --- gcc/ch/actions.h | 33 + gcc/ch/except.c | 703 ++++++ gcc/ch/grant.c | 3053 +++++++++++++++++++++++++ gcc/ch/inout.c | 4675 +++++++++++++++++++++++++++++++++++++++ gcc/ch/lex.c | 2169 ++++++++++++++++++ gcc/ch/nloop.c | 1244 +++++++++++ gcc/ch/parse.h | 76 + gcc/ch/runtime/concatstr.c | 69 + gcc/ch/runtime/continue.c | 83 + gcc/ch/runtime/convdurrtstime.c | 52 + gcc/ch/runtime/ffsetclrps.c | 102 + gcc/ch/runtime/flsetclrps.c | 99 + gcc/ch/runtime/leps.c | 76 + gcc/ch/runtime/powerset.h | 106 + gcc/ch/runtime/queuelength.c | 79 + gcc/ch/runtime/readrecord.c | 208 ++ gcc/ch/runtime/rtsdummy.c | 65 + gcc/ch/runtime/sequencible.c | 32 + gcc/ch/runtime/setbitps.c | 89 + gcc/ch/runtime/setbits.c | 85 + gcc/ch/runtime/settextindex.c | 38 + gcc/ch/runtime/variable.c | 31 + gcc/ch/runtime/writeable.c | 31 + gcc/ch/tasking.h | 26 + gcc/ch/tree.c | 293 +++ 25 files changed, 13517 insertions(+) create mode 100644 gcc/ch/actions.h create mode 100644 gcc/ch/except.c create mode 100644 gcc/ch/grant.c create mode 100644 gcc/ch/inout.c create mode 100644 gcc/ch/lex.c create mode 100644 gcc/ch/nloop.c create mode 100644 gcc/ch/parse.h create mode 100644 gcc/ch/runtime/concatstr.c create mode 100644 gcc/ch/runtime/continue.c create mode 100644 gcc/ch/runtime/convdurrtstime.c create mode 100644 gcc/ch/runtime/ffsetclrps.c create mode 100644 gcc/ch/runtime/flsetclrps.c create mode 100644 gcc/ch/runtime/leps.c create mode 100644 gcc/ch/runtime/powerset.h create mode 100644 gcc/ch/runtime/queuelength.c create mode 100644 gcc/ch/runtime/readrecord.c create mode 100644 gcc/ch/runtime/rtsdummy.c create mode 100644 gcc/ch/runtime/sequencible.c create mode 100644 gcc/ch/runtime/setbitps.c create mode 100644 gcc/ch/runtime/setbits.c create mode 100644 gcc/ch/runtime/settextindex.c create mode 100644 gcc/ch/runtime/variable.c create mode 100644 gcc/ch/runtime/writeable.c create mode 100644 gcc/ch/tasking.h create mode 100644 gcc/ch/tree.c (limited to 'gcc/ch') diff --git a/gcc/ch/actions.h b/gcc/ch/actions.h new file mode 100644 index 0000000..d1eceb3 --- /dev/null +++ b/gcc/ch/actions.h @@ -0,0 +1,33 @@ +/* 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)); diff --git a/gcc/ch/except.c b/gcc/ch/except.c new file mode 100644 index 0000000..d3b3c70 --- /dev/null +++ b/gcc/ch/except.c @@ -0,0 +1,703 @@ +/* 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 +#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 . */ + int prev_on_alternative; + + /* If > 0: handler number for ELSE handler. */ + int else_handler; + + int action_number; + + char do_pushlevel; + + tree on_alt_list; + tree setjmp_expr; + + /* A decl for the static handler array (used to map exception name to int).*/ + tree handler_array_decl; + + rtx end_label; + + /* Used to pass a tree from emit_setup_handler to chill_start_on. */ + tree handler_ref; + + tree unlink_cleanup; + + tree function; + + /* flag to indicate that we are currently compiling this handler. + is_handled will need this to determine an unhandled exception */ + int compiling; +}; + +/* This is incremented by one each time we start an action which + might have an ON-handler. It is reset between passes. */ +static int action_number = 0; + +int action_nesting_level = 0; + +/* The global_handler_list is constructed in pass 1. It is not sorted. + It contains one element for each action that actually had an ON-handler. + An element's ACTION_NUMBER matches the action_number + of that action. The global_handler_list is eaten up during pass 2. */ +#define ACTION_NUMBER(HANDLER) ((HANDLER)->action_number) +struct handler_state *global_handler_list = NULL; + +/* This is a stack of handlers, one for each nested ON-handler. */ +static struct handler_state *current_handler = NULL; + +static struct handler_state *free_handlers = NULL; /* freelist */ + +static tree handler_element_type; +static tree handler_link_type; +static tree BISJ; +static tree jbuf_ident, prev_ident, handlers_ident; +static tree exception_stack_decl = 0; + +/* Chain of cleanups assocated with exception handlers. + The TREE_PURPOSE is an INTEGER_CST whose value is the + DECL_ACTION_NESTING_LEVEL (when the handled actions was entered). + The TREE_VALUE is an expression to expand when we exit that action. */ + +static tree cleanup_chain = NULL_TREE; + +#if 0 +/* Merge the current sequence onto the tail of the previous one. */ + +void +pop_sequence () +{ + rtx sequence_first = get_insns (); + + end_sequence (); + emit_insns (sequence_first); + +} +#endif + +/* Things we need to do at the beginning of pass 2. */ + +void +except_init_pass_2 () +{ + /* First sort the global_handler_list on ACTION_NUMBER. + This will already be in close to reverse order (the exception being + nested ON-handlers), so insertion sort should essentially linear. */ + + register struct handler_state *old_list = global_handler_list; + + /* First add a dummy final element. */ + if (free_handlers) + global_handler_list = free_handlers; + else + global_handler_list + = (struct handler_state*) permalloc (sizeof (struct handler_state)); + /* Make the final dummy "larger" than any other element. */ + ACTION_NUMBER (global_handler_list) = action_number + 1; + /* Now move all the elements in old_list over to global_handler_list. */ + while (old_list != NULL) + { + register struct handler_state **ptr = &global_handler_list; + /* Unlink from old_list. */ + register struct handler_state *current = old_list; + old_list = old_list->next; + + while (ACTION_NUMBER (current) > ACTION_NUMBER (*ptr)) + ptr = &(*ptr)->next; + /* Link into proper place in global_handler_list (new list). */ + current->next = *ptr; + *ptr = current; + } + + /* Don't forget to reset action_number. */ + action_number = 0; +} + +/* This function is called at the beginning of an action that might be + followed by an ON-handler. Chill syntax doesn't let us know if + we actually have an ON-handler until we see the ON, so we save + away during pass 1 that information for use during pass 2. */ + +void +push_handler () +{ + register struct handler_state *hstate; + + action_number++; + action_nesting_level++; + + if (pass == 1) + { + if (free_handlers) + { + hstate = free_handlers; + free_handlers = hstate->next; + } + else + { + hstate = + (struct handler_state*) permalloc (sizeof (struct handler_state)); + } + + hstate->next = current_handler; + current_handler = hstate; + hstate->prev_on_alternative = 0; + hstate->else_handler = 0; + hstate->on_alt_list = NULL_TREE; + hstate->compiling = 0; + + ACTION_NUMBER (hstate) = action_number; + return; + } + + if (ACTION_NUMBER (global_handler_list) != action_number) + return; + + /* OK. This action actually has an ON-handler. + Pop it from global_handler_list, and use it. */ + + hstate = global_handler_list; + global_handler_list = hstate->next; + + /* Since this is pass 2, let's generate prologue code for that. */ + + hstate->next = current_handler; + current_handler = hstate; + + hstate->prev_on_alternative = 0; + hstate->function = current_function_decl; + + emit_setup_handler (); +} + +static tree +start_handler_array () +{ + tree handler_array_type, decl; + + push_obstacks_nochange (); + end_temporary_allocation (); + handler_array_type = build_array_type (handler_element_type, NULL_TREE); + decl = build_lang_decl (VAR_DECL, + get_unique_identifier ("handler_table"), + handler_array_type); + +/* TREE_TYPE (decl) = handler_array_type;*/ + TREE_READONLY (decl) = 1; + TREE_STATIC (decl) = 1; + DECL_INITIAL (decl) = error_mark_node; + + pushdecl (decl); + make_decl_rtl (decl, NULL_PTR, 0); + current_handler->handler_array_decl = decl; + return decl; +} + +static void +finish_handler_array () +{ + tree decl = current_handler->handler_array_decl; + tree t; + tree handler_array_init = NULL_TREE; + int handlers_count = 1; + int nelts; + + /* Build the table mapping exceptions to handler(-number)s. + This is done in reverse order. */ + + /* First push the end of the list. This is either the ELSE + handler (current_handler->else_handler>0) or NULL handler to indicate + the end of the list (if current_handler->else-handler == 0). + The following works either way. */ + handler_array_init = build_tree_list + (NULL_TREE, chill_expand_tuple + (handler_element_type, + build_nt (CONSTRUCTOR, NULL_TREE, + tree_cons (NULL_TREE, + null_pointer_node, + build_tree_list (NULL_TREE, + build_int_2 (current_handler->else_handler, + 0)))))); + + for (t = current_handler->on_alt_list; t != NULL_TREE; t = TREE_CHAIN (t)) + { tree handler_number = TREE_PURPOSE(t); + tree elist = TREE_VALUE (t); + for ( ; elist != NULL_TREE; elist = TREE_CHAIN (elist)) + { + tree ex_decl = + build_chill_exception_decl (IDENTIFIER_POINTER(TREE_VALUE(elist))); + tree ex_addr = build1 (ADDR_EXPR, + char_pointer_type_for_handler, + ex_decl); + tree el = build_nt (CONSTRUCTOR, NULL_TREE, + tree_cons (NULL_TREE, + ex_addr, + build_tree_list (NULL_TREE, + handler_number))); + mark_addressable (ex_decl); + TREE_CONSTANT (ex_addr) = 1; + handler_array_init = + tree_cons (NULL_TREE, + chill_expand_tuple (handler_element_type, el), + handler_array_init); + handlers_count++; + } + } + +#if 1 + nelts = list_length (handler_array_init); + TYPE_DOMAIN (TREE_TYPE (decl)) + = build_index_type (build_int_2 (nelts - 1, - (nelts == 0))); + layout_type (TREE_TYPE (decl)); + DECL_INITIAL (decl) + = convert (TREE_TYPE (decl), + build_nt (CONSTRUCTOR, NULL_TREE, handler_array_init)); + + /* Pop back to the obstack that is current for this binding level. + This is because MAXINDEX, rtl, etc. to be made below + must go in the permanent obstack. But don't discard the + temporary data yet. */ + pop_obstacks (); + layout_decl (decl, 0); + /* To prevent make_decl_rtl (called indiectly by rest_of_decl_compilation) + throwing the existing RTL (which has already been used). */ + PUT_MODE (DECL_RTL (decl), DECL_MODE (decl)); + rest_of_decl_compilation (decl, (char*)0, 0, 0); + expand_decl_init (decl); +#else + /* To prevent make_decl_rtl (called indirectly by finish_decl) + altering the existing RTL. */ + GET_MODE (DECL_RTL (current_handler->handler_array_decl)) = + DECL_MODE (current_handler->handler_array_decl); + + finish_decl (current_handler->handler_array_decl, + build_nt (CONSTRUCTOR, NULL_TREE, handler_array_init), + NULL_TREE); +#endif +} + + +void +pop_handler (used) + int used; +{ + action_nesting_level--; + if (pass == 1) + { + struct handler_state *old = current_handler; + if (old == NULL) + 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 = { <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: ON END. + Assume we've parsed , 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); +} diff --git a/gcc/ch/grant.c b/gcc/ch/grant.c new file mode 100644 index 0000000..5dcf450 --- /dev/null +++ b/gcc/ch/grant.c @@ -0,0 +1,3053 @@ +/* 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 +#include +#include +#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; + + +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; +} + +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; +} + +static MYSTRING * +get_tag_value (val) + tree val; +{ + MYSTRING *result; + + if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val)) + { + result = newstring (IDENTIFIER_POINTER (DECL_NAME (val))); + } + else if (TREE_CODE (val) == CONST_DECL) + { + /* it's a synonym -- get the value */ + result = decode_constant (DECL_INITIAL (val)); + } + else + { + result = decode_constant (val); + } + return (result); +} + +static MYSTRING * +get_tag_value_selective (val, all_decls) + tree val; + tree all_decls; +{ + MYSTRING *result; + + if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val)) + result = newstring (""); + else if (TREE_CODE (val) == CONST_DECL) + { + /* it's a synonym -- get the value */ + result = decode_constant_selective (DECL_INITIAL (val), all_decls); + } + else + { + result = decode_constant_selective (val, all_decls); + } + return (result); +} + +static MYSTRING * +print_enumeral (type) + tree type; +{ + MYSTRING *result = newstring (""); + tree fields; + +#if 0 + if (TYPE_LANG_SPECIFIC (type) == NULL) +#endif + { + + APPEND (result, "SET ("); + for (fields = TYPE_VALUES (type); + fields != NULL_TREE; + fields = TREE_CHAIN (fields)) + { + if (TREE_PURPOSE (fields) == NULL_TREE) + APPEND (result, "*"); + else + { + tree decl = TREE_VALUE (fields); + APPEND (result, IDENTIFIER_POINTER (TREE_PURPOSE (fields))); + if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl)) + { + MYSTRING *val_string = decode_constant (DECL_INITIAL (decl)); + APPEND (result, " = "); + APPEND (result, val_string->str); + FREE (val_string); + } + } + if (TREE_CHAIN (fields) != NULL_TREE) + APPEND (result, ",\n "); + } + APPEND (result, ")"); + } + return result; +} + +static MYSTRING * +print_enumeral_selective (type, all_decls) + tree type; + tree all_decls; +{ + MYSTRING *result = newstring (""); + tree fields; + + for (fields = TYPE_VALUES (type); + fields != NULL_TREE; + fields = TREE_CHAIN (fields)) + { + if (TREE_PURPOSE (fields) != NULL_TREE) + { + tree decl = TREE_VALUE (fields); + if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl)) + { + MYSTRING *val_string = decode_constant_selective (DECL_INITIAL (decl), all_decls); + if (val_string->len) + APPEND (result, val_string->str); + FREE (val_string); + } + } + } + return result; +} + +static MYSTRING * +print_integer_type (type) + tree type; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + char *name_ptr; + tree base_type; + + if (TREE_TYPE (type)) + { + mode_string = decode_mode (TREE_TYPE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + + APPEND (result, "("); + mode_string = decode_constant (TYPE_MIN_VALUE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + + if (TREE_TYPE (type) != ridpointers[(int) RID_BIN]) + { + APPEND (result, ":"); + mode_string = decode_constant (TYPE_MAX_VALUE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + } + + APPEND (result, ")"); + return result; + } + /* We test TYPE_MAIN_VARIANT because pushdecl often builds + a copy of a built-in type node, which is logically id- + entical but has a different address, and the same + TYPE_MAIN_VARIANT. */ + /* FIXME this should not be needed! */ + + base_type = TREE_TYPE (type) ? TREE_TYPE (type) : type; + + if (TREE_UNSIGNED (base_type)) + { + if (base_type == chill_unsigned_type_node + || TYPE_MAIN_VARIANT(base_type) == + TYPE_MAIN_VARIANT (chill_unsigned_type_node)) + name_ptr = "UINT"; + else if (base_type == long_integer_type_node + || TYPE_MAIN_VARIANT(base_type) == + TYPE_MAIN_VARIANT (long_unsigned_type_node)) + name_ptr = "ULONG"; + else if (type == unsigned_char_type_node + || TYPE_MAIN_VARIANT(base_type) == + TYPE_MAIN_VARIANT (unsigned_char_type_node)) + name_ptr = "UBYTE"; + else if (type == duration_timing_type_node + || TYPE_MAIN_VARIANT (base_type) == + TYPE_MAIN_VARIANT (duration_timing_type_node)) + name_ptr = "DURATION"; + else if (type == abs_timing_type_node + || TYPE_MAIN_VARIANT (base_type) == + TYPE_MAIN_VARIANT (abs_timing_type_node)) + name_ptr = "TIME"; + else + name_ptr = "UINT"; + } + else + { + if (base_type == chill_integer_type_node + || TYPE_MAIN_VARIANT (base_type) == + TYPE_MAIN_VARIANT (chill_integer_type_node)) + name_ptr = "INT"; + else if (base_type == long_integer_type_node + || TYPE_MAIN_VARIANT (base_type) == + TYPE_MAIN_VARIANT (long_integer_type_node)) + name_ptr = "LONG"; + else if (type == signed_char_type_node + || TYPE_MAIN_VARIANT (base_type) == + TYPE_MAIN_VARIANT (signed_char_type_node)) + name_ptr = "BYTE"; + else + name_ptr = "INT"; + } + + APPEND (result, name_ptr); + + /* see if we have a range */ + if (TREE_TYPE (type) != NULL) + { + mode_string = decode_constant (TYPE_MIN_VALUE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + APPEND (result, ":"); + mode_string = decode_constant (TYPE_MAX_VALUE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + } + + return result; +} + +static tree +find_enum_parent (enumname, all_decls) + tree enumname; + tree all_decls; +{ + tree wrk; + + for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk)) + { + if (TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (wrk) != CONST_DECL && + TREE_CODE (TREE_TYPE (wrk)) == ENUMERAL_TYPE) + { + tree list; + for (list = TYPE_VALUES (TREE_TYPE (wrk)); list != NULL_TREE; list = TREE_CHAIN (list)) + { + if (DECL_NAME (TREE_VALUE (list)) == enumname) + return wrk; + } + } + } + return NULL_TREE; +} + +static MYSTRING * +print_integer_selective (type, all_decls) + tree type; + tree all_decls; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + + if (TREE_TYPE (type)) + { + mode_string = decode_mode_selective (TREE_TYPE (type), all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + + if (TREE_TYPE (type) == ridpointers[(int)RID_RANGE] && + TREE_CODE (TYPE_MIN_VALUE (type)) == IDENTIFIER_NODE && + TREE_CODE (TYPE_MAX_VALUE (type)) == IDENTIFIER_NODE) + { + /* we have a range of a set. Find parant mode and write it + to SPEC MODULE. This will loose if the parent mode was SEIZED from + another file.*/ + tree minparent = find_enum_parent (TYPE_MIN_VALUE (type), all_decls); + tree maxparent = find_enum_parent (TYPE_MAX_VALUE (type), all_decls); + + if (minparent != NULL_TREE) + { + if (! CH_ALREADY_GRANTED (minparent)) + { + mode_string = decode_decl (minparent); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + CH_ALREADY_GRANTED (minparent) = 1; + } + } + if (minparent != maxparent && maxparent != NULL_TREE) + { + if (!CH_ALREADY_GRANTED (maxparent)) + { + mode_string = decode_decl (maxparent); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + CH_ALREADY_GRANTED (maxparent) = 1; + } + } + } + else + { + mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + + mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + return result; + } + + /* see if we have a range */ + if (TREE_TYPE (type) != NULL) + { + mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + + mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + + return result; +} + +static MYSTRING * +print_struct (type) + tree type; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + tree fields; + + if (chill_varying_type_p (type)) + { + mode_string = grant_array_type (type); + APPEND (result, mode_string->str); + FREE (mode_string); + } + else + { + fields = TYPE_FIELDS (type); + + APPEND (result, "STRUCT ("); + while (fields != NULL_TREE) + { + if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE) + { + tree variants; + /* Format a tagged variant record type. */ + APPEND (result, " CASE "); + if (TYPE_TAGFIELDS (TREE_TYPE (fields)) != NULL_TREE) + { + tree tag_list = TYPE_TAGFIELDS (TREE_TYPE (fields)); + for (;;) + { + tree tag_name = DECL_NAME (TREE_VALUE (tag_list)); + APPEND (result, IDENTIFIER_POINTER (tag_name)); + tag_list = TREE_CHAIN (tag_list); + if (tag_list == NULL_TREE) + break; + APPEND (result, ", "); + } + } + APPEND (result, " OF\n"); + variants = TYPE_FIELDS (TREE_TYPE (fields)); + + /* Each variant is a FIELD_DECL whose type is an anonymous + struct within the anonymous union. */ + while (variants != NULL_TREE) + { + tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants)); + tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants)); + + while (tag_list != NULL_TREE) + { + tree tag_values = TREE_VALUE (tag_list); + APPEND (result, " ("); + while (tag_values != NULL_TREE) + { + mode_string = get_tag_value (TREE_VALUE (tag_values)); + APPEND (result, mode_string->str); + FREE (mode_string); + if (TREE_CHAIN (tag_values) != NULL_TREE) + { + APPEND (result, ",\n "); + tag_values = TREE_CHAIN (tag_values); + } + else break; + } + APPEND (result, ")"); + tag_list = TREE_CHAIN (tag_list); + if (tag_list) + APPEND (result, ","); + else + break; + } + APPEND (result, " : "); + + while (struct_elts != NULL_TREE) + { + mode_string = decode_decl (struct_elts); + APPEND (result, mode_string->str); + FREE (mode_string); + + if (TREE_CHAIN (struct_elts) != NULL_TREE) + APPEND (result, ",\n "); + struct_elts = TREE_CHAIN (struct_elts); + } + + variants = TREE_CHAIN (variants); + if (variants != NULL_TREE + && TREE_CHAIN (variants) == NULL_TREE + && DECL_NAME (variants) == ELSE_VARIANT_NAME) + { + tree else_elts = TYPE_FIELDS (TREE_TYPE (variants)); + APPEND (result, "\n ELSE "); + while (else_elts != NULL_TREE) + { + mode_string = decode_decl (else_elts); + APPEND (result, mode_string->str); + FREE (mode_string); + if (TREE_CHAIN (else_elts) != NULL_TREE) + APPEND (result, ",\n "); + else_elts = TREE_CHAIN (else_elts); + } + break; + } + if (variants != NULL_TREE) + APPEND (result, ",\n"); + } + + APPEND (result, "\n ESAC"); + } + else + { + mode_string = decode_decl (fields); + APPEND (result, mode_string->str); + FREE (mode_string); + } + + fields = TREE_CHAIN (fields); + if (fields != NULL_TREE) + APPEND (result, ",\n "); + } + APPEND (result, ")"); + } + return result; +} + +static MYSTRING * +print_struct_selective (type, all_decls) + tree type; + tree all_decls; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + tree fields; + + if (chill_varying_type_p (type)) + { + mode_string = grant_array_type_selective (type, all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + } + else + { + fields = TYPE_FIELDS (type); + + while (fields != NULL_TREE) + { + if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE) + { + tree variants; + /* Format a tagged variant record type. */ + + variants = TYPE_FIELDS (TREE_TYPE (fields)); + + /* Each variant is a FIELD_DECL whose type is an anonymous + struct within the anonymous union. */ + while (variants != NULL_TREE) + { + tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants)); + tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants)); + + while (tag_list != NULL_TREE) + { + tree tag_values = TREE_VALUE (tag_list); + while (tag_values != NULL_TREE) + { + mode_string = get_tag_value_selective (TREE_VALUE (tag_values), + all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + if (TREE_CHAIN (tag_values) != NULL_TREE) + tag_values = TREE_CHAIN (tag_values); + else break; + } + tag_list = TREE_CHAIN (tag_list); + if (!tag_list) + break; + } + + while (struct_elts != NULL_TREE) + { + mode_string = decode_decl_selective (struct_elts, all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + + struct_elts = TREE_CHAIN (struct_elts); + } + + variants = TREE_CHAIN (variants); + if (variants != NULL_TREE + && TREE_CHAIN (variants) == NULL_TREE + && DECL_NAME (variants) == ELSE_VARIANT_NAME) + { + tree else_elts = TYPE_FIELDS (TREE_TYPE (variants)); + while (else_elts != NULL_TREE) + { + mode_string = decode_decl_selective (else_elts, all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + else_elts = TREE_CHAIN (else_elts); + } + break; + } + } + } + else + { + mode_string = decode_decl_selective (fields, all_decls); + APPEND (result, mode_string->str); + FREE (mode_string); + } + + fields = TREE_CHAIN (fields); + } + } + return result; +} + +static MYSTRING * +print_proc_exceptions (ex) + tree ex; +{ + MYSTRING *result = newstring (""); + + if (ex != NULL_TREE) + { + APPEND (result, "\n EXCEPTIONS ("); + for ( ; ex != NULL_TREE; ex = TREE_CHAIN (ex)) + { + APPEND (result, IDENTIFIER_POINTER (TREE_VALUE (ex))); + if (TREE_CHAIN (ex) != NULL_TREE) + APPEND (result, ",\n "); + } + APPEND (result, ")"); + } + return result; +} + +static MYSTRING * +print_proc_tail (type, args, print_argnames) + tree type; + tree args; + int print_argnames; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + int count = 0; + int stopat = list_length (args) - 3; + + /* do the argument modes */ + for ( ; args != NULL_TREE; + args = TREE_CHAIN (args), count++) + { + char buf[20]; + tree argmode = TREE_VALUE (args); + tree attribute = TREE_PURPOSE (args); + + if (argmode == void_type_node) + continue; + + /* if we have exceptions don't print last 2 arguments */ + if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat) + break; + + if (count) + APPEND (result, ",\n "); + if (print_argnames) + { + sprintf(buf, "arg%d ", count); + APPEND (result, buf); + } + + if (attribute == ridpointers[(int) RID_LOC]) + argmode = TREE_TYPE (argmode); + mode_string = get_type (argmode); + APPEND (result, mode_string->str); + FREE (mode_string); + + if (attribute != NULL_TREE) + { + sprintf (buf, " %s", IDENTIFIER_POINTER (attribute)); + APPEND (result, buf); + } + } + APPEND (result, ")"); + + /* return type */ + { + tree retn_type = TREE_TYPE (type); + + if (retn_type != NULL_TREE + && TREE_CODE (retn_type) != VOID_TYPE) + { + mode_string = get_type (retn_type); + APPEND (result, "\n RETURNS ("); + APPEND (result, mode_string->str); + FREE (mode_string); + if (TREE_CODE (retn_type) == REFERENCE_TYPE) + APPEND (result, " LOC"); + APPEND (result, ")"); + } + } + + mode_string = print_proc_exceptions (TYPE_RAISES_EXCEPTIONS (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + + return result; +} + +static MYSTRING * +print_proc_tail_selective (type, args, all_decls) + tree type; + tree args; + tree all_decls; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + int count = 0; + int stopat = list_length (args) - 3; + + /* do the argument modes */ + for ( ; args != NULL_TREE; + args = TREE_CHAIN (args), count++) + { + tree argmode = TREE_VALUE (args); + tree attribute = TREE_PURPOSE (args); + + if (argmode == void_type_node) + continue; + + /* if we have exceptions don't process last 2 arguments */ + if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat) + break; + + if (attribute == ridpointers[(int) RID_LOC]) + argmode = TREE_TYPE (argmode); + mode_string = get_type_selective (argmode, all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + + /* return type */ + { + tree retn_type = TREE_TYPE (type); + + if (retn_type != NULL_TREE + && TREE_CODE (retn_type) != VOID_TYPE) + { + mode_string = get_type_selective (retn_type, all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + } + + return result; +} + +/* output a mode (or type). */ + +static MYSTRING * +decode_mode (type) + tree type; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + + switch ((enum chill_tree_code)TREE_CODE (type)) + { + case TYPE_DECL: + if (DECL_NAME (type)) + { + APPEND (result, IDENTIFIER_POINTER (DECL_NAME (type))); + return result; + } + type = TREE_TYPE (type); + break; + + case IDENTIFIER_NODE: + APPEND (result, IDENTIFIER_POINTER (type)); + return result; + + case LANG_TYPE: + /* LANG_TYPE are only used until satisfy is done, + as place-holders for 'READ T', NEWMODE/SYNMODE modes, + parameterised modes, and old-fashioned CHAR(N). */ + if (TYPE_READONLY (type)) + APPEND (result, "READ "); + + mode_string = get_type (TREE_TYPE (type)); + APPEND (result, mode_string->str); + if (TYPE_DOMAIN (type) != NULL_TREE) + { + /* Parameterized mode, + or old-fashioned CHAR(N) string declaration.. */ + APPEND (result, "("); + mode_string = decode_constant (TYPE_DOMAIN (type)); + APPEND (result, mode_string->str); + APPEND (result, ")"); + } + FREE (mode_string); + break; + + case ARRAY_TYPE: + mode_string = grant_array_type (type); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case BOOLEAN_TYPE: + APPEND (result, "BOOL"); + break; + + case CHAR_TYPE: + APPEND (result, "CHAR"); + break; + + case ENUMERAL_TYPE: + mode_string = print_enumeral (type); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case FUNCTION_TYPE: + { + tree args = TYPE_ARG_TYPES (type); + + APPEND (result, "PROC ("); + + mode_string = print_proc_tail (type, args, 0); + APPEND (result, mode_string->str); + FREE (mode_string); + } + break; + + case INTEGER_TYPE: + mode_string = print_integer_type (type); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case RECORD_TYPE: + if (CH_IS_INSTANCE_MODE (type)) + { + APPEND (result, "INSTANCE"); + return result; + } + else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) + { tree bufsize = max_queue_size (type); + APPEND (result, CH_IS_BUFFER_MODE (type) ? "BUFFER " : "EVENT "); + if (bufsize != NULL_TREE) + { + APPEND (result, "("); + mode_string = decode_constant (bufsize); + APPEND (result, mode_string->str); + APPEND (result, ") "); + FREE (mode_string); + } + if (CH_IS_BUFFER_MODE (type)) + { + mode_string = decode_mode (buffer_element_mode (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + } + break; + } + else if (CH_IS_ACCESS_MODE (type)) + { + tree indexmode, recordmode, dynamic; + + APPEND (result, "ACCESS"); + recordmode = access_recordmode (type); + indexmode = access_indexmode (type); + dynamic = access_dynamic (type); + + if (indexmode != void_type_node) + { + mode_string = decode_mode (indexmode); + APPEND (result, " ("); + APPEND (result, mode_string->str); + APPEND (result, ")"); + FREE (mode_string); + } + if (recordmode != void_type_node) + { + mode_string = decode_mode (recordmode); + APPEND (result, " "); + APPEND (result, mode_string->str); + FREE (mode_string); + } + if (dynamic != integer_zero_node) + APPEND (result, " DYNAMIC"); + break; + } + else if (CH_IS_TEXT_MODE (type)) + { + tree indexmode, dynamic, length; + + APPEND (result, "TEXT ("); + length = text_length (type); + indexmode = text_indexmode (type); + dynamic = text_dynamic (type); + + mode_string = decode_constant (length); + APPEND (result, mode_string->str); + FREE (mode_string); + APPEND (result, ")"); + if (indexmode != void_type_node) + { + APPEND (result, " "); + mode_string = decode_mode (indexmode); + APPEND (result, mode_string->str); + FREE (mode_string); + } + if (dynamic != integer_zero_node) + APPEND (result, " DYNAMIC"); + return result; + } + mode_string = print_struct (type); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case POINTER_TYPE: + if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE) + APPEND (result, "PTR"); + else + { + if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) + { + mode_string = get_type (TREE_TYPE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + } + else + { + APPEND (result, "REF "); + mode_string = get_type (TREE_TYPE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + } + } + break; + + case REAL_TYPE: + if (TREE_INT_CST_LOW (TYPE_SIZE (type)) == 32) + APPEND (result, "REAL"); + else + APPEND (result, "LONG_REAL"); + break; + + case SET_TYPE: + if (CH_BOOLS_TYPE_P (type)) + mode_string = grant_array_type (type); + else + { + APPEND (result, "POWERSET "); + mode_string = get_type (TYPE_DOMAIN (type)); + } + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case REFERENCE_TYPE: + mode_string = get_type (TREE_TYPE (type)); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + default: + APPEND (result, "/* ---- not implemented ---- */"); + break; + } + + return (result); +} + +static tree +find_in_decls (id, all_decls) + tree id; + tree all_decls; +{ + tree wrk; + + for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk)) + { + if (DECL_NAME (wrk) == id || DECL_POSTFIX (wrk) == id) + return wrk; + } + return NULL_TREE; +} + +static int +in_ridpointers (id) + tree id; +{ + int i; + for (i = RID_UNUSED; i < RID_MAX; i++) + { + if (id == ridpointers[i]) + return 1; + } + return 0; +} + +static void +grant_seized_identifier (decl) + tree decl; +{ + seizefile_list *wrk = selective_seizes; + MYSTRING *mode_string; + + CH_ALREADY_GRANTED (decl) = 1; + + /* comes from a SPEC MODULE in the module */ + if (DECL_SEIZEFILE (decl) == NULL_TREE) + return; + + /* search file already in process */ + while (wrk != 0) + { + if (wrk->filename == DECL_SEIZEFILE (decl)) + break; + wrk = wrk->next; + } + if (!wrk) + { + wrk = (seizefile_list *)xmalloc (sizeof (seizefile_list)); + wrk->next = selective_seizes; + selective_seizes = wrk; + wrk->filename = DECL_SEIZEFILE (decl); + wrk->seizes = newstring ("<> USE_SEIZE_FILE \""); + APPEND (wrk->seizes, IDENTIFIER_POINTER (DECL_SEIZEFILE (decl))); + APPEND (wrk->seizes, "\" <>\n"); + } + APPEND (wrk->seizes, "SEIZE "); + mode_string = decode_prefix_rename (decl); + APPEND (wrk->seizes, mode_string->str); + FREE (mode_string); + APPEND (wrk->seizes, ";\n"); +} + +static MYSTRING * +decode_mode_selective (type, all_decls) + tree type; + tree all_decls; +{ + MYSTRING *result = newstring (""); + MYSTRING *mode_string; + tree decl; + + switch ((enum chill_tree_code)TREE_CODE (type)) + { + case TYPE_DECL: + /* FIXME: could this ever happen ?? */ + if (DECL_NAME (type)) + { + FREE (result); + result = decode_mode_selective (DECL_NAME (type), all_decls); + return result; + } + break; + + case IDENTIFIER_NODE: + if (in_ridpointers (type)) + /* it's a predefined, we must not search the whole list */ + return result; + + decl = find_in_decls (type, all_decls); + if (decl != NULL_TREE) + { + if (CH_ALREADY_GRANTED (decl)) + /* already processed */ + return result; + + if (TREE_CODE (decl) == ALIAS_DECL && DECL_POSTFIX (decl) != NULL_TREE) + { + /* If CH_DECL_GRANTED, decl was granted into this scope, and + so wasn't in the source code. */ + if (!CH_DECL_GRANTED (decl)) + { + grant_seized_identifier (decl); + } + } + else + { + result = decode_decl (decl); + mode_string = decode_decl_selective (decl, all_decls); + if (mode_string->len) + { + PREPEND (result, mode_string->str); + } + FREE (mode_string); + } + } + return result; + + case LANG_TYPE: + mode_string = get_type_selective (TREE_TYPE (type), all_decls); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case ARRAY_TYPE: + mode_string = grant_array_type_selective (type, all_decls); + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case BOOLEAN_TYPE: + return result; + break; + + case CHAR_TYPE: + return result; + break; + + case ENUMERAL_TYPE: + mode_string = print_enumeral_selective (type, all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case FUNCTION_TYPE: + { + tree args = TYPE_ARG_TYPES (type); + + mode_string = print_proc_tail_selective (type, args, all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + } + break; + + case INTEGER_TYPE: + mode_string = print_integer_selective (type, all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case RECORD_TYPE: + if (CH_IS_INSTANCE_MODE (type)) + { + return result; + } + else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) + { + tree bufsize = max_queue_size (type); + if (bufsize != NULL_TREE) + { + mode_string = decode_constant_selective (bufsize, all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + } + if (CH_IS_BUFFER_MODE (type)) + { + mode_string = decode_mode_selective (buffer_element_mode (type), all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + break; + } + else if (CH_IS_ACCESS_MODE (type)) + { + tree indexmode = access_indexmode (type); + tree recordmode = access_recordmode (type); + + if (indexmode != void_type_node) + { + mode_string = decode_mode_selective (indexmode, all_decls); + if (mode_string->len) + { + if (result->len && result->str[result->len - 1] != '\n') + APPEND (result, ";\n"); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + if (recordmode != void_type_node) + { + mode_string = decode_mode_selective (recordmode, all_decls); + if (mode_string->len) + { + if (result->len && result->str[result->len - 1] != '\n') + APPEND (result, ";\n"); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + break; + } + else if (CH_IS_TEXT_MODE (type)) + { + tree indexmode = text_indexmode (type); + tree length = text_length (type); + + mode_string = decode_constant_selective (length, all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + if (indexmode != void_type_node) + { + mode_string = decode_mode_selective (indexmode, all_decls); + if (mode_string->len) + { + if (result->len && result->str[result->len - 1] != '\n') + APPEND (result, ";\n"); + APPEND (result, mode_string->str); + } + FREE (mode_string); + } + break; + } + mode_string = print_struct_selective (type, all_decls); + if (mode_string->len) + { + MAYBE_NEWLINE (result); + APPEND (result, mode_string->str); + } + FREE (mode_string); + break; + + case POINTER_TYPE: + if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE) + break; + else + { + if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) + { + mode_string = get_type_selective (TREE_TYPE (type), all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + } + else + { + mode_string = get_type_selective (TREE_TYPE (type), all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + } + } + break; + + case REAL_TYPE: + return result; + break; + + case SET_TYPE: + if (CH_BOOLS_TYPE_P (type)) + mode_string = grant_array_type_selective (type, all_decls); + else + mode_string = get_type_selective (TYPE_DOMAIN (type), all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + case REFERENCE_TYPE: + mode_string = get_type_selective (TREE_TYPE (type), all_decls); + if (mode_string->len) + APPEND (result, mode_string->str); + FREE (mode_string); + break; + + default: + APPEND (result, "/* ---- not implemented ---- */"); + break; + } + + return (result); +} + +static MYSTRING * +get_type (type) + tree type; +{ + if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) + return newstring (""); + + return (decode_mode (type)); +} + +static MYSTRING * +get_type_selective (type, all_decls) + tree type; + tree all_decls; +{ + if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) + return newstring (""); + + return (decode_mode_selective (type, all_decls)); +} + +#if 0 +static int +is_forbidden (str, forbid) + tree str; + tree forbid; +{ + if (forbid == NULL_TREE) + return (0); + + if (TREE_CODE (forbid) == INTEGER_CST) + return (1); + + while (forbid != NULL_TREE) + { + if (TREE_VALUE (forbid) == str) + return (1); + forbid = TREE_CHAIN (forbid); + } + /* nothing found */ + return (0); +} +#endif + +static MYSTRING * +decode_constant (init) + tree init; +{ + MYSTRING *result = newstring (""); + MYSTRING *tmp_string; + tree type = TREE_TYPE (init); + tree val = init; + 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; +} + +/* 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 */ + } +} + +/* 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; +} + +/* 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; +} + +/* + * 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; + } +} + + diff --git a/gcc/ch/inout.c b/gcc/ch/inout.c new file mode 100644 index 0000000..2d2293b --- /dev/null +++ b/gcc/ch/inout.c @@ -0,0 +1,4675 @@ +/* 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 +#include +#include +#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; + + +/* 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; +} + + +static void +build_chill_io_list_type () +{ + tree list = NULL_TREE; + tree result, enum1, listbase; + tree io_descriptor; + tree decl1, decl2; + tree forcharstring, forset_W, forset_R, forboolrange; + + tree forintrange, intunion, forsetrange, forcharrange; + tree long_type, ulong_type, union_type; + + long_type = long_integer_type_node; + ulong_type = long_unsigned_type_node; + + if (chill_io_list_type != NULL_TREE) + /* already done */ + return; + + /* first build the enum for the desriptor */ + enum1 = start_enum (NULL_TREE); + result = build_enumerator (get_identifier ("__IO_UNUSED"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_ByteVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_UByteVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_IntVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_UIntVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_LongVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_ULongVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_ByteLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_UByteLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_IntLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_UIntLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_LongLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_ULongLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_IntRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_LongRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_BoolVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_BoolLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_SetVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_SetLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_SetRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_CharVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_CharLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_CharRangeLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_CharStrLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_BitStrLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_RealVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_RealLoc"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_LongRealVal"), + NULL_TREE); + list = chainon (result, list); + + result = build_enumerator (get_identifier ("__IO_LongRealLoc"), + NULL_TREE); + list = chainon (result, list); +#if 0 + result = build_enumerator (get_identifier ("_IO_Pointer"), + NULL_TREE); + list = chainon (result, list); +#endif + + result = finish_enum (enum1, list); + pushdecl (io_descriptor = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_enum"), + result)); + /* prevent seizing/granting of the decl */ + DECL_SOURCE_LINE (io_descriptor) = 0; + satisfy_decl (io_descriptor, 0); + + /* build type for enum_tables */ + decl1 = build_decl (FIELD_DECL, get_identifier ("value"), + long_type); + DECL_INITIAL (decl1) = NULL_TREE; + decl2 = build_decl (FIELD_DECL, get_identifier ("name"), + build_pointer_type (char_type_node)); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + result = build_chill_struct_type (decl1); + pushdecl (enum_table_type = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_enum_table_type"), + result)); + DECL_SOURCE_LINE (enum_table_type) = 0; + satisfy_decl (enum_table_type, 0); + + /* build type for writing a set mode */ + decl1 = build_decl (FIELD_DECL, get_identifier ("value"), + long_type); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), + build_pointer_type (TREE_TYPE (enum_table_type))); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forset_W = build_decl (TYPE_DECL, + get_identifier ("__tmp_WIO_set"), + result)); + DECL_SOURCE_LINE (forset_W) = 0; + satisfy_decl (forset_W, 0); + + /* build type for charrange */ + decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), + build_pointer_type (char_type_node)); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), + long_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), + long_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forcharrange = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_charrange"), + result)); + DECL_SOURCE_LINE (forcharrange) = 0; + satisfy_decl (forcharrange, 0); + + /* type for integer range */ + decl1 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("_slong"), + long_type)); + listbase = decl1; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("_ulong"), + ulong_type)); + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE); + TREE_CHAIN (decl1) = NULL_TREE; + result = build_chill_struct_type (decl1); + pushdecl (intunion = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_long"), + result)); + DECL_SOURCE_LINE (intunion) = 0; + satisfy_decl (intunion, 0); + + decl1 = build_decl (FIELD_DECL, + get_identifier ("ptr"), + ptr_type_node); + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("lower"), + TREE_TYPE (intunion)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("upper"), + TREE_TYPE (intunion)); + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forintrange = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_intrange"), + result)); + DECL_SOURCE_LINE (forintrange) = 0; + satisfy_decl (forintrange, 0); + + /* build structure for bool range */ + decl1 = build_decl (FIELD_DECL, + get_identifier ("ptr"), + ptr_type_node); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("lower"), + ulong_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("upper"), + ulong_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forboolrange = build_decl (TYPE_DECL, + get_identifier ("__tmp_RIO_boolrange"), + result)); + DECL_SOURCE_LINE (forboolrange) = 0; + satisfy_decl (forboolrange, 0); + + /* build type for reading a set */ + decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), + ptr_type_node); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, get_identifier ("length"), + long_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), + build_pointer_type (TREE_TYPE (enum_table_type))); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forset_R = build_decl (TYPE_DECL, + get_identifier ("__tmp_RIO_set"), + result)); + DECL_SOURCE_LINE (forset_R) = 0; + satisfy_decl (forset_R, 0); + + /* build type for setrange */ + decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), + ptr_type_node); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, get_identifier ("length"), + long_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), + build_pointer_type (TREE_TYPE (enum_table_type))); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), + long_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), + long_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forsetrange = build_decl (TYPE_DECL, + get_identifier ("__tmp_RIO_setrange"), + result)); + DECL_SOURCE_LINE (forsetrange) = 0; + satisfy_decl (forsetrange, 0); + + /* build structure for character string */ + decl1 = build_decl (FIELD_DECL, + get_identifier ("string"), + build_pointer_type (char_type_node)); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("string_length"), + ulong_type); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (forcharstring = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_forcharstring"), result)); + DECL_SOURCE_LINE (forcharstring) = 0; + satisfy_decl (forcharstring, 0); + + /* build the union */ + decl1 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valbyte"), + signed_char_type_node)); + listbase = decl1; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valubyte"), + unsigned_char_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valint"), + chill_integer_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valuint"), + chill_unsigned_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__vallong"), + long_type)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valulong"), + ulong_type)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locint"), + ptr_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locintrange"), + TREE_TYPE (forintrange))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valbool"), + boolean_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locbool"), + build_pointer_type (boolean_type_node))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locboolrange"), + TREE_TYPE (forboolrange))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valset"), + TREE_TYPE (forset_W))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locset"), + TREE_TYPE (forset_R))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locsetrange"), + TREE_TYPE (forsetrange))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valchar"), + char_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locchar"), + build_pointer_type (char_type_node))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__loccharrange"), + TREE_TYPE (forcharrange))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__loccharstring"), + TREE_TYPE (forcharstring))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__valreal"), + float_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__locreal"), + build_pointer_type (float_type_node))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__vallongreal"), + double_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__loclongreal"), + build_pointer_type (double_type_node))); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + +#if 0 + decl2 = build_tree_list (NULL_TREE, + build_decl (FIELD_DECL, + get_identifier ("__forpointer"), + ptr_type_node)); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; +#endif + + TREE_CHAIN (decl2) = NULL_TREE; + + decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE); + TREE_CHAIN (decl1) = NULL_TREE; + result = build_chill_struct_type (decl1); + pushdecl (union_type = build_decl (TYPE_DECL, + get_identifier ("__tmp_WIO_union"), + result)); + DECL_SOURCE_LINE (union_type) = 0; + satisfy_decl (union_type, 0); + + /* now build the final structure */ + decl1 = build_decl (FIELD_DECL, get_identifier ("__t"), + TREE_TYPE (union_type)); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"), + long_type); + + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (chill_io_list_type = build_decl (TYPE_DECL, + get_identifier ("__tmp_IO_list"), + result)); + DECL_SOURCE_LINE (chill_io_list_type) = 0; + satisfy_decl (chill_io_list_type, 0); +} + +/* build the ASSOCIATION, ACCESS and TEXT mode types */ +static void +build_io_types () +{ + tree listbase, decl1, decl2, result, association; + tree acc, txt, tloc; + tree enum1, tmp; + + /* the association mode */ + listbase = build_decl (FIELD_DECL, + get_identifier ("flags"), + long_unsigned_type_node); + DECL_INITIAL (listbase) = NULL_TREE; + decl1 = listbase; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("pathname"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("access"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("handle"), + integer_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("bufptr"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("syserrno"), + long_integer_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("usage"), + char_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("ctl_pre"), + char_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("ctl_post"), + char_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (association = build_decl (TYPE_DECL, + ridpointers[(int)RID_ASSOCIATION], + result)); + DECL_SOURCE_LINE (association) = 0; + satisfy_decl (association, 0); + association_type_node = TREE_TYPE (association); + TYPE_NAME (association_type_node) = association; + CH_NOVELTY (association_type_node) = association; + CH_TYPE_NONVALUE_P(association_type_node) = 1; + CH_TYPE_NONVALUE_P(association) = 1; + + /* initialiser for association type */ + tmp = convert (char_type_node, integer_zero_node); + association_init_value = + build_nt (CONSTRUCTOR, NULL_TREE, + tree_cons (NULL_TREE, integer_zero_node, /* flags */ + tree_cons (NULL_TREE, null_pointer_node, /* pathname */ + tree_cons (NULL_TREE, null_pointer_node, /* access */ + tree_cons (NULL_TREE, integer_minus_one_node, /* handle */ + tree_cons (NULL_TREE, null_pointer_node, /* bufptr */ + tree_cons (NULL_TREE, integer_zero_node, /* syserrno */ + tree_cons (NULL_TREE, tmp, /* usage */ + tree_cons (NULL_TREE, tmp, /* ctl_pre */ + tree_cons (NULL_TREE, tmp, /* ctl_post */ + NULL_TREE)))))))))); + + /* the type for stdin, stdout, stderr */ + /* text part */ + decl1 = build_decl (FIELD_DECL, + get_identifier ("flags"), + long_unsigned_type_node); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("text_record"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("access_sub"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("actual_index"), + long_unsigned_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + txt = build_chill_struct_type (listbase); + + /* access part */ + decl1 = build_decl (FIELD_DECL, + get_identifier ("flags"), + long_unsigned_type_node); + DECL_INITIAL (decl1) = NULL_TREE; + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("reclength"), + long_unsigned_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("lowindex"), + long_integer_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("highindex"), + long_integer_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl2 = decl1; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("association"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("base"), + long_unsigned_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("storelocptr"), + ptr_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, + get_identifier ("rectype"), + long_integer_type_node); + DECL_INITIAL (decl2) = NULL_TREE; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + acc = build_chill_struct_type (listbase); + + /* the location */ + tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0)); + tloc = build_varying_struct (tmp); + + /* now the final mode */ + decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt); + listbase = decl1; + + decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), + void_type_node); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"), + integer_type_node); + DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0); + TREE_CHAIN (decl1) = decl2; + decl1 = decl2; + + decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"), + integer_type_node); + DECL_INITIAL (decl2) = integer_zero_node; + TREE_CHAIN (decl1) = decl2; + TREE_CHAIN (decl2) = NULL_TREE; + + result = build_chill_struct_type (listbase); + pushdecl (tmp = build_decl (TYPE_DECL, + get_identifier ("__stdio_text"), + result)); + DECL_SOURCE_LINE (tmp) = 0; + satisfy_decl (tmp, 0); + stdio_type_node = TREE_TYPE (tmp); + CH_IS_TEXT_MODE (stdio_type_node) = 1; + + /* predefined usage mode */ + enum1 = start_enum (NULL_TREE); + listbase = NULL_TREE; + result = build_enumerator ( + get_identifier ((ignore_case || ! special_UC) ? "readonly" : "READONLY"), + NULL_TREE); + listbase = chainon (result, listbase); + result = build_enumerator ( + get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"), + NULL_TREE); + listbase = chainon (result, listbase); + result = build_enumerator ( + get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"), + NULL_TREE); + listbase = chainon (result, listbase); + result = finish_enum (enum1, listbase); + pushdecl (tmp = build_decl (TYPE_DECL, + get_identifier ((ignore_case || ! special_UC) ? "usage" : "USAGE"), + result)); + DECL_SOURCE_LINE (tmp) = 0; + satisfy_decl (tmp, 0); + usage_type_node = TREE_TYPE (tmp); + TYPE_NAME (usage_type_node) = tmp; + CH_NOVELTY (usage_type_node) = tmp; + + /* predefined where mode */ + enum1 = start_enum (NULL_TREE); + listbase = NULL_TREE; + result = build_enumerator ( + get_identifier ((ignore_case || ! special_UC) ? "first" : "FIRST"), + NULL_TREE); + listbase = chainon (result, listbase); + result = build_enumerator ( + get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"), + NULL_TREE); + listbase = chainon (result, listbase); + result = build_enumerator ( + get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"), + NULL_TREE); + listbase = chainon (result, listbase); + result = finish_enum (enum1, listbase); + pushdecl (tmp = build_decl (TYPE_DECL, + get_identifier ((ignore_case || ! special_UC) ? "where" : "WHERE"), + result)); + DECL_SOURCE_LINE (tmp) = 0; + satisfy_decl (tmp, 0); + where_type_node = TREE_TYPE (tmp); + TYPE_NAME (where_type_node) = tmp; + CH_NOVELTY (where_type_node) = tmp; +} + +static void +declare_predefined_file (name, assembler_name) + 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); +} + + +/* 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; +} + +/* function returns the recordmode of an ACCESS */ +tree +access_recordmode (access) + tree access; +{ + tree field; + + if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) + return NULL_TREE; + if (! CH_IS_ACCESS_MODE (access)) + return NULL_TREE; + + field = TYPE_FIELDS (access); + for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) + { + if (TREE_CODE (field) == TYPE_DECL && + DECL_NAME (field) == get_identifier ("__recordmode")) + return TREE_TYPE (field); + } + return void_type_node; +} + +/* function invalidates the recordmode of an ACCESS */ +void +invalidate_access_recordmode (access) + tree access; +{ + tree field; + + if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) + return; + if (! CH_IS_ACCESS_MODE (access)) + return; + + field = TYPE_FIELDS (access); + for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) + { + if (TREE_CODE (field) == TYPE_DECL && + DECL_NAME (field) == get_identifier ("__recordmode")) + { + TREE_TYPE (field) = error_mark_node; + return; + } + } +} + +/* function returns the index mode of an ACCESS if there is one, + otherwise NULL_TREE */ +tree +access_indexmode (access) + tree access; +{ + tree field; + + if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) + return NULL_TREE; + if (! CH_IS_ACCESS_MODE (access)) + return NULL_TREE; + + field = TYPE_FIELDS (access); + for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) + { + if (TREE_CODE (field) == TYPE_DECL && + DECL_NAME (field) == get_identifier ("__indexmode")) + return TREE_TYPE (field); + } + return void_type_node; +} + +/* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */ +tree +access_dynamic (access) + tree access; +{ + tree field; + + if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) + return NULL_TREE; + if (! CH_IS_ACCESS_MODE (access)) + return NULL_TREE; + + field = TYPE_FIELDS (access); + for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) + { + if (TREE_CODE (field) == CONST_DECL) + return DECL_INITIAL (field); + } + return integer_zero_node; +} + +#if 0 + returns a structure like + STRUCT (data STRUCT (flags ULONG, + reclength ULONG, + lowindex LONG, + highindex LONG, + association PTR, + base ULONG, + store_loc PTR, + rectype LONG), + this is followed by a + TYPE_DECL __recordmode recordmode ? recordmode : void_type_node + TYPE_DECL __indexmode indexmode ? indexmode : void_type_node + CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node +#endif + +static tree +build_access_part () +{ + tree listbase, decl; + + listbase = build_decl (FIELD_DECL, get_identifier ("flags"), + long_unsigned_type_node); + decl = build_decl (FIELD_DECL, get_identifier ("reclength"), + long_unsigned_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("lowindex"), + long_unsigned_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("highindex"), + long_integer_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("association"), + ptr_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("base"), + long_unsigned_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"), + ptr_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("rectype"), + long_integer_type_node); + listbase = chainon (listbase, decl); + return build_chill_struct_type (listbase); +} + +tree +build_access_mode (indexmode, recordmode, dynamic) + tree indexmode; + tree recordmode; + int dynamic; +{ + tree type, listbase, decl, datamode; + + if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK) + return error_mark_node; + if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK) + return error_mark_node; + + datamode = build_access_part (); + + type = make_node (RECORD_TYPE); + listbase = build_decl (FIELD_DECL, get_identifier ("data"), + datamode); + TYPE_FIELDS (type) = listbase; + decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"), + recordmode == NULL_TREE ? void_type_node : recordmode); + chainon (listbase, decl); + decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), + indexmode == NULL_TREE ? void_type_node : indexmode); + chainon (listbase, decl); + decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), + integer_type_node); + DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node; + chainon (listbase, decl); + CH_IS_ACCESS_MODE (type) = 1; + CH_TYPE_NONVALUE_P (type) = 1; + return type; +} + +#if 0 + returns a structure like: + STRUCT (txt STRUCT (flags ULONG, + text_record PTR, + access_sub PTR, + actual_index LONG), + acc STRUCT (flags ULONG, + reclength ULONG, + lowindex LONG, + highindex LONG, + association PTR, + base ULONG, + store_loc PTR, + rectype LONG), + tloc CHARS(textlength) VARYING; + ) + followed by + TYPE_DECL __indexmode indexmode ? indexmode : void_type_node + CONST_DECL __text_length + CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node +#endif +tree +build_text_mode (textlength, indexmode, dynamic) + tree textlength; + tree indexmode; + int dynamic; +{ + tree txt, acc, listbase, decl, type, tltype; + tree savedlength = textlength; + + if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK) + return error_mark_node; + if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK) + return error_mark_node; + + /* build the structure */ + listbase = build_decl (FIELD_DECL, get_identifier ("flags"), + long_unsigned_type_node); + decl = build_decl (FIELD_DECL, get_identifier ("text_record"), + ptr_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("access_sub"), + ptr_type_node); + listbase = chainon (listbase, decl); + decl = build_decl (FIELD_DECL, get_identifier ("actual_index"), + long_integer_type_node); + listbase = chainon (listbase, decl); + txt = build_chill_struct_type (listbase); + + acc = build_access_part (); + + type = make_node (RECORD_TYPE); + listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt); + TYPE_FIELDS (type) = listbase; + decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc); + chainon (listbase, decl); + /* the text location */ + tltype = build_string_type (char_type_node, textlength); + tltype = build_varying_struct (tltype); + decl = build_decl (FIELD_DECL, get_identifier ("tloc"), + tltype); + chainon (listbase, decl); + /* the index mode */ + decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), + indexmode == NULL_TREE ? void_type_node : indexmode); + chainon (listbase, decl); + /* save dynamic */ + decl = build_decl (CONST_DECL, get_identifier ("__textlength"), + integer_type_node); + if (TREE_CODE (textlength) == COMPONENT_REF) + /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build + another one */ + savedlength = build_component_ref (TREE_OPERAND (textlength, 0), + TREE_OPERAND (textlength, 1)); + DECL_INITIAL (decl) = savedlength; + chainon (listbase, decl); + /* save dynamic */ + decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), + integer_type_node); + DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node; + chainon (listbase, decl); + CH_IS_TEXT_MODE (type) = 1; + CH_TYPE_NONVALUE_P (type) = 1; + return type; +} + +tree +check_text_length (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; +} + +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; +} + +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 + +/* 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)); +} + +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; +} + +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; +} + +/* 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); +} + +/* 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"); +} + +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; +} diff --git a/gcc/ch/lex.c b/gcc/ch/lex.c new file mode 100644 index 0000000..a3dbbb2 --- /dev/null +++ b/gcc/ch/lex.c @@ -0,0 +1,2169 @@ +/* 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. */ + +#include +#include +#include +#include +#include +#include + +#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 +#include +#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; + +/* 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); +} + +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)) + + +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 (); +} + + +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); +} + +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; +} + +/* Convert an integer INTCHARS into an INTEGER_CST. + INTCHARS is on the temporary_obstack, and is popped by this function. */ + +static tree +convert_integer (intchars) + char *intchars; +{ +#ifdef YYDEBUG + extern int yydebug; +#endif + char *p = intchars; + char *oldp = p; + int base = 10, tmp; + int valid_chars = 0; + int overflow = 0; + tree type; + HOST_WIDE_INT val_lo = 0, val_hi = 0; + tree val; + + /* determine the base */ + switch (*p) + { + case 'd': + case 'D': + p += 2; + break; + case 'o': + case 'O': + p += 2; + base = 8; + break; + case 'h': + case 'H': + p += 2; + base = 16; + break; + case 'b': + case 'B': + p += 2; + base = 2; + break; + default: + if (!isdigit (*p)) /* this test is for equal_number () */ + { + obstack_free (&temporary_obstack, intchars); + return 0; + } + break; + } + + while (*p) + { + tmp = *p++; + if ((tmp == '\'') || (tmp == '_')) + continue; + if (tmp < '0') + goto bad_char; + if (tmp >= 'a') /* uppercase the char */ + tmp -= ' '; + switch (base) /* validate the characters */ + { + case 2: + if (tmp > '1') + goto bad_char; + break; + case 8: + if (tmp > '7') + goto bad_char; + break; + case 10: + if (tmp > '9') + goto bad_char; + break; + case 16: + if (tmp > 'F') + goto bad_char; + if (tmp > '9' && tmp < 'A') + goto bad_char; + break; + default: + abort (); + } + tmp -= '0'; + if (tmp > 9) + tmp -= 7; + if (mul_double (val_lo, val_hi, base, 0, &val_lo, &val_hi)) + overflow++; + add_double (val_lo, val_hi, tmp, 0, &val_lo, &val_hi); + if (val_hi < 0) + overflow++; + valid_chars++; + } + bad_char: + obstack_free (&temporary_obstack, intchars); + if (!valid_chars) + { + if (pass == 2) + error ("invalid number format `%s'", oldp); + return 0; + } + val = build_int_2 (val_lo, val_hi); + /* We set the type to long long (or long long unsigned) so that + constant fold of literals is less likely to overflow. */ + if (int_fits_type_p (val, long_long_integer_type_node)) + type = long_long_integer_type_node; + else + { + if (! int_fits_type_p (val, long_long_unsigned_type_node)) + overflow++; + type = long_long_unsigned_type_node; + } + TREE_TYPE (val) = type; + CH_DERIVED_FLAG (val) = 1; + + if (overflow) + error ("integer literal too big"); + + return val; +} + +/* Convert a bitstring literal on the temporary_obstack to + a bitstring CONSTRUCTOR. Free the literal from the obstack. */ + +static tree +convert_bitstring (p) + char *p; +{ +#ifdef YYDEBUG + extern int yydebug; +#endif + int bl = 0, valid_chars = 0, bits_per_char = 0, c, k; + tree initlist = NULL_TREE; + tree val; + + /* Move p to stack so we can re-use temporary_obstack for result. */ + char *oldp = (char*) alloca (strlen (p) + 1); + 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; +} + +/* 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; +} + +/* 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 `# '. + In either case, it should be a line number; a digit should follow. */ + + while (c == ' ' || c == '\t') + c = getlc (finput); + + /* If the # is the only nonwhite char on the line, + just ignore it. Check the new newline. */ + if (c == '\n') + return c; + + /* Something follows the #; read a token. */ + + if (isdigit(c)) + { + int old_lineno = lineno; + int used_up = 0; + int l = 0; + extern struct obstack permanent_obstack; + + do + { + l = l * 10 + (c - '0'); /* FIXME Not portable */ + c = getlc(finput); + } while (isdigit(c)); + /* subtract one, because it is the following line that + gets the specified number */ + + l--; + + /* Is this the last nonwhite stuff on the line? */ + c = getlc (finput); + while (c == ' ' || c == '\t') + c = getlc (finput); + if (c == '\n') + { + /* No more: store the line number and check following line. */ + lineno = l; + return c; + } + + /* More follows: it must be a string constant (filename). */ + + /* Read the string constant, but don't treat \ as special. */ + ignore_escape_flag = 1; + ignore_escape_flag = 0; + + if (c != '\"') + { + error ("invalid #line"); + goto skipline; + } + + for (;;) + { + c = getc (finput); + if (c == EOF || c == '\n') + { + error ("invalid #line"); + return c; + } + if (c == '\"') + { + obstack_1grow(&permanent_obstack, 0); + input_filename = obstack_finish (&permanent_obstack); + break; + } + obstack_1grow(&permanent_obstack, c); + } + + lineno = l; + + /* Each change of file name + reinitializes whether we are now in a system header. */ + in_system_header = 0; + + if (main_input_filename == 0) + main_input_filename = input_filename; + + /* Is this the last nonwhite stuff on the line? */ + c = getlc (finput); + while (c == ' ' || c == '\t') + c = getlc (finput); + if (c == '\n') + return c; + + used_up = 0; + + /* `1' after file name means entering new file. + `2' after file name means just left a file. */ + + if (isdigit (c)) + { + if (c == '1') + { + /* Pushing to a new file. */ + struct file_stack *p + = (struct file_stack *) xmalloc (sizeof (struct file_stack)); + input_file_stack->line = old_lineno; + p->next = input_file_stack; + p->name = input_filename; + input_file_stack = p; + input_file_stack_tick++; +#ifdef DWARF_DEBUGGING_INFO + if (debug_info_level == DINFO_LEVEL_VERBOSE + && write_symbols == DWARF_DEBUG) + dwarfout_start_new_source_file (input_filename); +#endif /* DWARF_DEBUGGING_INFO */ + + used_up = 1; + } + else if (c == '2') + { + /* Popping out of a file. */ + if (input_file_stack->next) + { + struct file_stack *p = input_file_stack; + input_file_stack = p->next; + free (p); + input_file_stack_tick++; +#ifdef DWARF_DEBUGGING_INFO + if (debug_info_level == DINFO_LEVEL_VERBOSE + && write_symbols == DWARF_DEBUG) + dwarfout_resume_previous_source_file (input_file_stack->line); +#endif /* DWARF_DEBUGGING_INFO */ + } + else + error ("#-lines for entering and leaving files don't match"); + + used_up = 1; + } + } + + /* If we have handled a `1' or a `2', + see if there is another number to read. */ + if (used_up) + { + /* Is this the last nonwhite stuff on the line? */ + c = getlc (finput); + while (c == ' ' || c == '\t') + c = getlc (finput); + if (c == '\n') + return c; + used_up = 0; + } + + /* `3' after file name means this is a system header file. */ + + if (c == '3') + in_system_header = 1; + } + else + error ("invalid #-line"); + + /* skip the rest of this line. */ + skipline: + while (c != '\n' && c != EOF) + c = getc (finput); + return c; +} + + +tree +get_chill_filename () +{ + return (build_chill_string ( + strlen (input_filename) + 1, /* +1 to get a zero terminated string */ + input_filename)); +} + +tree +get_chill_linenumber () +{ + return build_int_2 ((HOST_WIDE_INT)lineno, 0); +} + + +/* Assuming '/' and '*' have been read, skip until we've + read the terminating '*' and '/'. */ + +static void +skip_c_comment () +{ + int c = input(); + int start_line = lineno; + + inside_c_comment++; + for (;;) + if (c == EOF) + { + error_with_file_and_line (input_filename, start_line, + "unterminated comment"); + break; + } + else if (c != '*') + c = input(); + else if ((c = input ()) == '/') + break; + inside_c_comment--; +} + + +/* Assuming "--" has been read, skip until '\n'. */ + +static void +skip_line_comment () +{ + for (;;) + { + int c = input (); + + if (c == EOF) + return; + if (c == '\n') + break; + } + unput ('\n'); +} + + +static int +skip_whitespace () +{ + for (;;) + { + int c = input (); + + if (c == EOF) + return c; + if (c == ' ' || c == '\t' || c == '\r' || c == '\n' || c == '\v') + continue; + if (c == '/') + { + c = input (); + if (c == '*') + { + skip_c_comment (); + continue; + } + else + { + unput (c); + return '/'; + } + } + if (c == '-') + { + c = input (); + if (c == '-') + { + skip_line_comment (); + continue; + } + else + { + unput (c); + return '-'; + } + } + return c; + } +} + +/* + * avoid recursive calls to yylex to parse the ' = digits' or + * ' = SYNvalue' which are supposed to follow certain compiler + * directives. Read the input stream, and return the value parsed. + */ + /* FIXME: overflow check in here */ + /* FIXME: check for EOF around here */ +static tree +equal_number () +{ + int c, result; + char *tokenbuf; + char *cursor; + tree retval = integer_zero_node; + + c = skip_whitespace(); + if ((char)c != '=') + { + if (pass == 2) + error ("missing `=' in compiler directive"); + return integer_zero_node; + } + c = skip_whitespace(); + + /* collect token into tokenbuf for later analysis */ + while (TRUE) + { + if (isspace (c) || c == '<') + break; + obstack_1grow (&temporary_obstack, c); + c = input (); + } + unput (c); /* put uninteresting char back */ + obstack_1grow (&temporary_obstack, '\0'); /* terminate token */ + tokenbuf = obstack_finish (&temporary_obstack); + maybe_downcase (tokenbuf); + + if (*tokenbuf == '-') + /* will fail in the next test */ + result = BITSTRING; + else if (maybe_number (tokenbuf)) + { + if (pass == 1) + return integer_zero_node; + push_obstacks_nochange (); + end_temporary_allocation (); + yylval.ttype = convert_integer (tokenbuf); + tokenbuf = 0; /* Was freed by convert_integer. */ + result = yylval.ttype ? NUMBER : 0; + pop_obstacks (); + } + else + result = 0; + + if (result == NUMBER) + { + retval = yylval.ttype; + } + else if (result == BITSTRING) + { + if (pass == 1) + error ("invalid value follows `=' in compiler directive"); + goto finish; + } + else /* not a number */ + { + cursor = tokenbuf; + c = *cursor; + if (!isalpha (c) && c != '_') + { + if (pass == 1) + error ("invalid value follows `=' in compiler directive"); + goto finish; + } + + for (cursor = &tokenbuf[1]; *cursor != '\0'; cursor++) + if (isalpha (*cursor) || *cursor == '_' || isdigit (*cursor)) + continue; + else + { + if (pass == 1) + error ("invalid `%c' character in name", *cursor); + goto finish; + } + if (pass == 1) + goto finish; + else + { + tree value = lookup_name (get_identifier (tokenbuf)); + if (value == NULL_TREE + || TREE_CODE (value) != CONST_DECL + || TREE_CODE (DECL_INITIAL (value)) != INTEGER_CST) + { + if (pass == 2) + error ("`%s' not integer constant synonym ", + tokenbuf); + goto finish; + } + obstack_free (&temporary_obstack, tokenbuf); + tokenbuf = 0; + push_obstacks_nochange (); + end_temporary_allocation (); + retval = convert (chill_taskingcode_type_node, DECL_INITIAL (value)); + pop_obstacks (); + } + } + + /* check the value */ + if (TREE_CODE (retval) != INTEGER_CST) + { + if (pass == 2) + error ("invalid value follows `=' in compiler directive"); + } + else if (TREE_INT_CST_HIGH (retval) != 0 || + TREE_INT_CST_LOW (retval) > TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_unsigned_type_node))) + { + if (pass == 2) + error ("value out of range in compiler directive"); + } + finish: + if (tokenbuf) + obstack_free (&temporary_obstack, tokenbuf); + return retval; +} + +/* + * add a possible grant-file path to the list + */ +void +register_seize_path (path) + 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; +} diff --git a/gcc/ch/nloop.c b/gcc/ch/nloop.c new file mode 100644 index 0000000..ddd4aad --- /dev/null +++ b/gcc/ch/nloop.c @@ -0,0 +1,1244 @@ +/* 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 +#include +#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)); + +/* In terms of the parameters passed to build_loop_iterator, + * there are several types of loops. They are encoded by + * the ITER_TYPE enumeration. + * + * 1) DO FOR EVER; ... OD + * indicated by a NULL_TREE start_exp, step_exp and end_exp, + * condition == NULL, in_flag = 0, and ever_flag == 1 in the + * first ITERATOR. + * + * 2) DO WHILE cond; ... OD + * indicated by NULL_TREE start_exp, step_exp and end_exp, + * in_flag = 0, and condition != NULL. + * + * 3) DO; ... OD + * indicated by NULL_TREEs in start_exp, step_exp and end_exp, + * condition != NULL, in_flag == 0 and ever_flag == 0. This + * is not really a loop, but a compound statement. + * + * 4) DO FOR user_var := start_exp + * [DOWN] TO end_exp BY step_exp; ... DO + * indicated by non-NULL_TREE start_exp, step_exp and end_exp. + * + * 5) DO FOR user_var [DOWN] IN discrete_mode; ... OD + * indicated by in_flag == 1. start_exp is a non-NULL_TREE + * discrete mode, with an optional down_flag. + * + * 6) DO FOR user_var [DOWN] IN powerset_expr; ... OD + * indicated by in_flag == 1. start_exp is a non-NULL_TREE + * powerset mode, with an optional down_flag. + * + * 7) DO FOR user_var [DOWN] IN location; ... OD + * indicated by in_flag == 1. start_exp is a non-NULL_TREE + * location mode, with an optional down_flag. + */ +typedef enum +{ + DO_UNUSED, + DO_FOREVER, + DO_WHILE, + DO_OD, + DO_STEP, + DO_RANGE, + DO_POWERSET, + DO_LOC, + DO_LOC_VARYING +} ITER_TYPE; + + +typedef struct iterator +{ +/* These variables only have meaning in the first ITERATOR structure. */ + ITER_TYPE itype; /* type of this iterator */ + int error_flag; /* TRUE if no loop was started due to + user error */ + tree condition; /* WHILE condition expression */ + int down_flag; /* TRUE if DOWN was coded */ + +/* These variables have meaning in every ITERATOR structure. */ + tree user_var; /* user's explicit iteration variable */ + tree start_exp; /* user's start expression + or IN expression of a FOR .. IN*/ + tree step_exp; /* user's step expression */ + tree end_exp; /* user's end expression */ + tree start_temp; /* temp holding evaluated start_exp */ + tree end_temp; /* temp holding evaluated end_exp */ + tree step_temp; /* temp holding evaluated step_exp */ + tree powerset_temp; /* temp holding user's initial powerset expression */ + tree loc_ptr_temp; /* temp holding count for LOC enumeration ptr */ + tree iter_var; /* hidden variable for the loop */ + tree iter_type; /* hidden variable's type */ + tree base_type; /* LOC enumeration base type */ + struct iterator *next; /* ptr to next iterator for this loop */ +} ITERATOR; + +/* + * There's an entry like this for each nested DO loop. + * The list is maintained by push_loop_block + * and pop_loop_block. + */ +typedef struct loop { + struct loop *nxt_level; /* pointer to enclosing loop */ + ITERATOR *iter_list; /* iterators for the current loop */ +} LOOP; + +static LOOP *loop_stack = (LOOP *)0; + +#if 0 + +Here is a CHILL DO FOR statement: + +DO FOR user_var := start_exp BY step_exp [DOWN] TO end_exp + WHILE condition; + +For this loop to be 'safe', like a Pascal FOR loop, the start, +end, and increment expressions are computed once, before the +assignment to the iteration variable and saved in temporaries, +before the first assignment of the iteration variable, so the +following works: + + FOR i := (i+1) TO (i+10) DO + +To prevent changes to the start/end/step expressions from +effecting the loop''s termination, and to make the loop end-check +as simple as possible, we evaluate the step expression into +a temporary and compute a hidden iteration count before entering +the loop''s body. User code cannot effect the counter, and the +end-loop check simply decrements the counter and checks for zero. + +The whole phrase FOR iter := ... TO end_exp can be repeated +multiple times, with different user-iteration variables. This +is discussed later. + +The loop counter calculations need careful design since a loop +from MININT TO MAXINT must work, in the precision of integers. + +Here''s how it works, in C: + + 0) The DO ... OD loop is simply a block with + its own scope. + + 1) The DO FOR EVER is simply implemented: + + loop_top: + . + . body of loop + . + goto loop_top + end_loop: + + 2) The DO WHILE is also simple: + + + loop_top: + if (!condition) goto end_loop + . + . body of loop + . + goto loop_top + end_loop: + + + 3) The DO FOR [while condition] loop (no DOWN) + + push a new scope, + decl iter_var + + step_temp = step_exp + start_temp = start_exp + end_temp = end_exp + if (end_exp < start_exp) goto end_loop + /* following line is all unsigned arithmetic */ + iter_var = (end_exp - start_exp + step_exp) / step_exp + user_var = start_temp + loop_top: + if (!condition) goto end_loop + . + . body of loop + . + iter_var-- + if (iter_var == 0) goto end_loop + user_var += step_temp + goto loop_top + end_loop: + pop scope + + 4) The proposed CHILL for [while condition] loop (with DOWN) + + push a new scope, + decl iter + step_temp = step_exp + start_temp = start_exp + end_temp = end_exp + if (end_exp > start_exp) goto end_loop + /* following line is all unsigned arithmetic */ + iter_var = (start_exp - end_exp + step_exp) / step_exp + user_var = start_temp + loop_top: + if (!condition) goto end_loop + . + . body of loop + . + iter_var-- + if (iter_var == 0) goto end_loop + user_var -= step_temp + goto loop_top + end_loop: + pop scope + + + 5) The range loop, which iterates over a mode''s possible + values, works just like the above step loops, but with + the start and end values taken from the mode''s lower + and upper domain values. + + + 6) The FOR IN loop, where a location enumeration is + specified (see spec on page 81 of Z.200, bottom + of page 186): + + push a new scope, + decl iter_var as an unsigned integer + loc_ptr_temp as pointer to a composite base type + + if array is varying + iter_var = array''s length field + else + iter_var = sizeof array / sizeof base_type + loc_ptr_temp = &of highest or lowest indexable entry + loop_top: + if (!condition) goto end_loop + . + . body of loop + . + iter_var-- + if (iter_var == 0) goto end_loop + loc_ptr_temp +/-= sizeof array base_type + goto loop_top + end_loop: + pop scope + + 7) The DO FOR (DOWN) IN powerset_exp + + push a new scope, + decl powerset_temp + decl iterator as basetype of powerset + + powerset_temp := start_exp + loop_top: + /* if DOWN */ + if (__flsetclrpowerset () == 0) goto end_loop; + /* not DOWN */ + if (__ffsetclrpowerset () == 0) goto end_loop; + if (!condition) goto end_loop + . + . body of loop + . + goto loop_top + end_loop: + pop scope + + +So, here''s the general DO FOR schema, as implemented here: + + classify_loop -- what type of loop have we? + -- build_iterator does some of this, also + expand_start_loop -- start the loop''s control scope + -- start scope for synthesized loop variables + declare_temps -- create, initialize temporary variables + maybe_skip_loop -- skip loop if end conditions unsatisfiable + initialize_iter_var -- initialize the iteration counter + -- initialize user''s loop variable + expand_start_loop -- generate top-of-loop label + top_loop_end_check -- generate while code and/or + powerset find-a-bit function call + . + . + . user''s loop body code + . + . + bottom_loop_end_check -- exit if counter has become zero + increment_temps -- update temps for next iteration + expand_end_loop -- generate jump back to top of loop + expand_end_cond -- generate label for end of conditional + -- end of scope for synthesized loop variables + free_iterators -- free up iterator space + +When there are two or more iterator phrases, each of the +above loop steps must act upon all iterators. For example, +the 'increment_temps' step must increment all temporaries +(associated with all iterators). + + NOTE: Z.200, section 10.1 says that a block is ... + "the actions statement list in a do action, including any + loop counter and while control". This means that an exp- + ression in a WHILE control can include references to the + loop counters created for the loop''s exclusive use. + Example: + + DCL a (1:10) INT; + DCL j INT; + DO FOR j IN a WHILE j > 0; + ... + OD; + The 'j' referenced in the while is the loc-identity 'j' + created inside the loop''s scope, and NOT the 'j' declared + before the loop. +#endif + +/* + * The following routines are called directly by the + * CHILL parser. + */ +void +push_loop_block () +{ + LOOP *temp = (LOOP *)xmalloc (sizeof (LOOP)); + + /* push a new loop onto the stack */ + temp->nxt_level = loop_stack; + temp->iter_list = (ITERATOR *)0; + loop_stack = temp; +} + +void +pop_loop_block () +{ + LOOP *do_temp = loop_stack; + ITERATOR *ip; + + /* pop loop block off the list */ + loop_stack = do_temp->nxt_level; + + /* free the loop's iterator blocks */ + ip = do_temp->iter_list; + while (ip != NULL) + { + ITERATOR *temp = ip->next; + free (ip); + ip = temp; + } + free (do_temp); +} + +void +begin_loop_scope () +{ + ITERATOR *firstp = loop_stack->iter_list; + + if (pass < 2) + return; + + /* + * We need to classify the loop and declare its temporaries + * here, so as to define them before the WHILE condition + * (if any) is parsed. The WHILE expression may refer to + * a temporary. + */ + if (classify_loop ()) + return; + + if (firstp->itype != DO_OD) + declare_temps (); + + clear_last_expr (); + push_momentary (); + expand_start_bindings (0); +} + + +void +end_loop_scope (opt_label) + tree opt_label; +{ + if (opt_label) + possibly_define_exit_label (opt_label); + poplevel (0, 0, 0); + + if (pass < 2) + return; + + expand_end_bindings (getdecls (), kept_level_p (), 0); + pop_momentary (); +} + +/* The iterator structure records all aspects of a + * 'FOR i := start [DOWN] TO end' clause or + * 'FOR i IN modename' or 'FOR i IN powerset' clause. + * It's saved on the iter_list of the current LOOP. + */ +void +build_loop_iterator (user_var, start_exp, step_exp, end_exp, + down_flag, in_flag, ever_flag) + tree user_var, start_exp, step_exp, end_exp; + int down_flag, in_flag, ever_flag; +{ + ITERATOR *ip = (ITERATOR *)xmalloc (sizeof (ITERATOR)); + + /* chain this iterator onto the current loop */ + if (loop_stack->iter_list == NULL) + loop_stack->iter_list = ip; + else + { + ITERATOR *temp = loop_stack->iter_list; + while (temp->next != NULL) + temp = temp->next; + temp->next = ip; + } + + ip->itype = DO_UNUSED; + ip->user_var = user_var; + ip->start_exp = start_exp; + ip->step_exp = step_exp; + ip->end_exp = end_exp; + ip->condition = NULL_TREE; + ip->start_temp = NULL_TREE; + ip->end_temp = NULL_TREE; + ip->step_temp = NULL_TREE; + ip->down_flag = down_flag; + ip->powerset_temp = NULL_TREE; + ip->iter_var = NULL_TREE; + ip->iter_type = NULL_TREE; + ip->loc_ptr_temp = NULL_TREE; + ip->error_flag = 1; /* assume error will be found */ + ip->next = (ITERATOR *)0; + + if (ever_flag) + ip->itype = DO_FOREVER; + else if (in_flag && start_exp != NULL_TREE) + { + if (TREE_CODE (start_exp) == ERROR_MARK) + return; + if (TREE_CODE (TREE_TYPE (start_exp)) == SET_TYPE) + ip->itype = DO_POWERSET; + else if (discrete_type_p (TREE_TYPE (ip->start_exp))) + ip->itype = DO_RANGE; + else if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ARRAY_TYPE) + ip->itype = DO_LOC; + else if (chill_varying_type_p (TREE_TYPE (ip->start_exp))) + ip->itype = DO_LOC_VARYING; + else + { + error ("Loop's IN expression is not a composite object"); + return; + } + } + else if (start_exp == NULL_TREE && end_exp == NULL_TREE + && step_exp == NULL_TREE && !down_flag) + ip->itype = DO_OD; + else + { + /* FIXME: Move this to the lexer? */ +#define CST_FITS_INT(NODE) (TREE_CODE(NODE) == INTEGER_CST &&\ + int_fits_type_p (NODE, integer_type_node)) + + tree max_prec_type = integer_type_node; + + if (! discrete_type_p (TREE_TYPE (ip->start_exp))) + { + error ("start expr must have discrete mode"); + return; + } + if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ENUMERAL_TYPE + && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->start_exp))) + { + error ("DO FOR start expression is a numbered SET"); + return; + } + if (TREE_CODE (TREE_TYPE (ip->end_exp)) == ENUMERAL_TYPE + && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->end_exp))) + { + error ("TO expression is a numbered SET"); + return; + } + /* Convert all three expressions to a common precision, + which is the largest precision they exhibit, but + INTEGER_CST nodes are built in the lexer as + long_integer_type nodes. We'll treat convert them to + integer_type_nodes if possible, for faster loop times. */ + + if (TYPE_PRECISION (max_prec_type) < + TYPE_PRECISION (TREE_TYPE (ip->start_exp)) + && !CST_FITS_INT (ip->start_exp)) + max_prec_type = TREE_TYPE (ip->start_exp); + if (! discrete_type_p (TREE_TYPE (ip->end_exp))) + { + error ("TO expr must have discrete mode"); + return; + } + if (! CH_COMPATIBLE (ip->start_exp, + TREE_TYPE (ip->end_exp))) + { + error ("start expr and TO expr must be compatible"); + return; + } + if (TYPE_PRECISION (max_prec_type) < + TYPE_PRECISION (TREE_TYPE (ip->end_exp)) + && !CST_FITS_INT (ip->end_exp)) + max_prec_type = TREE_TYPE (ip->end_exp); + if (ip->step_exp != NULL_TREE) + { + /* assure that default 'BY 1' gets a useful type */ + if (ip->step_exp == integer_one_node) + ip->step_exp = convert (TREE_TYPE (ip->start_exp), + ip->step_exp); + if (! discrete_type_p (TREE_TYPE (ip->step_exp))) + { + error ("BY expr must have discrete mode"); + return; + } + if (! CH_COMPATIBLE (ip->start_exp, + TREE_TYPE (ip->step_exp))) + { + error ("start expr and BY expr must be compatible"); + return; + } + if (TYPE_PRECISION (max_prec_type) < + TYPE_PRECISION (TREE_TYPE (ip->step_exp)) + && !CST_FITS_INT (ip->step_exp)) + max_prec_type = TREE_TYPE (ip->step_exp); + } + if (TREE_CODE (ip->start_exp) == INTEGER_CST + && TREE_CODE (ip->end_exp) == INTEGER_CST + && compare_int_csts (ip->down_flag ? LT_EXPR : GT_EXPR, + ip->start_exp, ip->end_exp)) + warning ("body of DO FOR will never execute"); + + ip->start_exp = + convert (max_prec_type, ip->start_exp); + ip->end_exp = + convert (max_prec_type, ip->end_exp); + + if (ip->step_exp != NULL_TREE) + { + ip->step_exp = + convert (max_prec_type, ip->step_exp); + + if (TREE_CODE (ip->step_exp) != INTEGER_CST) + { + /* generate runtime check for negative BY expr */ + ip->step_exp = + check_range (ip->step_exp, ip->step_exp, + integer_zero_node, NULL_TREE); + } + else if (compare_int_csts (LE_EXPR, ip->step_exp, integer_zero_node)) + { + error ("BY expression is negative or zero"); + return; + } + } + ip->itype = DO_STEP; + } + + ip->error_flag = 0; /* no errors! */ +} + +void +build_loop_start (while_control, start_label) + tree while_control, start_label; +{ + ITERATOR *firstp = loop_stack->iter_list; + + firstp->condition = while_control; + + if (firstp->error_flag) + return; + + /* We didn't know at begin_loop_scope time about the condition; + adjust iterator type now. */ + if (firstp->itype == DO_OD && firstp->condition) + firstp->itype = DO_WHILE; + + if (initialize_iter_var ()) + return; + + if (maybe_skip_loop ()) + return; + + /* use the label as an 'exit' label, + 'goto' needs another sort of label */ + expand_start_loop (start_label != NULL_TREE); + + if (top_loop_end_check ()) + return; + emit_line_note (input_filename, lineno); +} + +/* + * Called after the last action of the loop body + * has been parsed. + */ +void +build_loop_end () +{ + ITERATOR *ip = loop_stack->iter_list; + + emit_line_note (input_filename, lineno); + + if (ip->error_flag) + return; + + if (bottom_loop_end_check ()) + return; + + if (increment_temps ()) + return; + + if (ip->itype != DO_OD) + { + expand_end_loop (); + + for (; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_LOC_VARYING: + case DO_STEP: + expand_end_cond (); + break; + default: + break; + } + } + } +} + +/* + * The rest of the routines in this file are called from + * the above three routines. + */ +static int +classify_loop () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + + firstp->error_flag = 0; + if (firstp->itype == DO_UNUSED || firstp->itype == DO_OD) + { + /* if we have just DO .. OD, do nothing - this is just a + BEGIN .. END without creating a new scope, and no looping */ + if (firstp->condition != NULL_TREE) + firstp->itype = DO_WHILE; + else + firstp->itype = DO_OD; + } + + /* Issue a warning if the any loop counter is mentioned more + than once in the iterator list. */ + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_FOREVER: + case DO_WHILE: + break; + case DO_STEP: + case DO_RANGE: + case DO_POWERSET: + case DO_LOC: + case DO_LOC_VARYING: + /* FIXME: check for name uniqueness */ + break; + default: + ; + } + } + return firstp->error_flag; +} + +/* + * Reserve space for any loop-control temporaries, initialize them + */ +static int +declare_temps () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + tree start_ptr; + + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_FOREVER: + case DO_WHILE: + break; + case DO_STEP: + ip->iter_type = chill_unsigned_type (TREE_TYPE (ip->start_exp)); + + /* create, initialize temporaries if expressions aren't constant */ + ip->start_temp = maybe_make_for_temp (ip->start_exp, "for_start", + ip->iter_type); + ip->end_temp = maybe_make_for_temp (ip->end_exp, "for_end", + ip->iter_type); + /* this is just the step-expression */ + ip->step_temp = maybe_make_for_temp (ip->step_exp, "for_step", + ip->iter_type); + goto do_step_range; + + case DO_RANGE: + ip->iter_type = chill_unsigned_type_node; + + ip->start_temp = + (ip->down_flag ? build_chill_upper : build_chill_lower)(TREE_TYPE (ip->start_exp)); + ip->end_temp = + (ip->down_flag ? build_chill_lower : build_chill_upper)(TREE_TYPE (ip->start_exp)); + + ip->step_temp = integer_one_node; + + do_step_range: + if (flag_local_loop_counter) + { + /* (re-)declare the user's iteration variable in the + loop's scope. */ + tree id_node = ip->user_var; + IDENTIFIER_LOCAL_VALUE (id_node) = ip->user_var = + decl_temp1 (id_node, ip->iter_type, 0, NULL_TREE, + 0, 0); + } + else + { + /* in this case, it's a previously-declared + VAR_DECL node, checked in build_loop_iterator. */ + if (TREE_CODE (ip->user_var) == IDENTIFIER_NODE) + ip->user_var = lookup_name (ip->user_var); + if (ip->user_var == NULL_TREE) + { + error ("loop identifier undeclared"); + ip->error_flag = 1; + return 1; + } + } + ip->iter_var = + decl_temp1 (get_unique_identifier ("iter_var"), + ip->iter_type, 0, NULL_TREE, 0, 0); + break; + + case DO_POWERSET: + ip->iter_type = chill_unsigned_type ( + TYPE_DOMAIN (TREE_TYPE (ip->start_exp))); + if (flag_local_loop_counter) + { + /* declare the user's iteration variable in the loop's scope. */ + /* in this case, it's just an IDENTIFIER_NODE */ + ip->user_var = + decl_temp1 (ip->user_var, ip->iter_type, 0, NULL_TREE, 0, 0); + } + else + { + /* in this case, it's a previously-declared VAR_DECL node */ + ip->user_var = lookup_name (ip->user_var); + } + /* the user's powerset-expression, evaluated and saved in a temp */ + ip->powerset_temp = maybe_make_for_temp (ip->start_exp, "for_set", + TREE_TYPE (ip->start_exp)); + mark_addressable (ip->powerset_temp); + break; + + case DO_LOC: + case DO_LOC_VARYING: + ip->iter_type = chill_unsigned_type_node; + /* create the counter temp */ + ip->iter_var = + build_temporary_variable ("iter_var", ip->iter_type); + + if (!CH_LOCATION_P (ip->start_exp)) + ip->start_exp + = decl_temp1 (get_unique_identifier ("iter_loc"), + TREE_TYPE (ip->start_exp), 0, + ip->start_exp, 0, 0); + + if (ip->itype == DO_LOC) + { + tree array_type = TREE_TYPE (ip->start_exp); + tree ptr_type; + tree temp; + + if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE) + { + error ("Can't iterate through array of BOOL"); + ip->error_flag = 1; + return ip->error_flag; + } + + /* FIXME: check for array type in ip->start_exp */ + + /* create pointer temporary */ + ip->base_type = TREE_TYPE (array_type); + ptr_type = build_pointer_type (ip->base_type); + ip->loc_ptr_temp = + build_temporary_variable ("loc_ptr_tmp", ptr_type); + + /* declare the user's iteration variable in + the loop's scope, as an expression, to be + passed to build_component_ref later */ + save_expr_under_name (ip->user_var, + build1 (INDIRECT_REF, ip->base_type, + ip->loc_ptr_temp)); + + /* FIXME: see stor_layout */ + ip->step_temp = size_in_bytes (ip->base_type); + + temp = TYPE_DOMAIN (array_type); + + /* pointer to first array entry to look at */ + start_ptr = build1 (ADDR_EXPR, ptr_type, ip->start_exp); + mark_addressable (ip->start_exp); + ip->start_temp = ip->down_flag ? + fold (build (PLUS_EXPR, ptr_type, + start_ptr, + fold (build (MULT_EXPR, integer_type_node, ip->step_temp, + fold (build (MINUS_EXPR, integer_type_node, + TYPE_MAX_VALUE (temp), + TYPE_MIN_VALUE (temp))))))) + : start_ptr; + } + else + { + tree array_length = + convert (integer_type_node, + build_component_ref (ip->start_exp, var_length_id)); + tree array_type = TREE_TYPE (TREE_CHAIN ( + TYPE_FIELDS (TREE_TYPE (ip->start_exp)))); + tree array_data_ptr = + build_component_ref (ip->start_exp, var_data_id); + tree ptr_type; + + if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE) + { + error ("Can't iterate through array of BOOL"); + firstp->error_flag = 1; + return firstp->error_flag; + } + + /* create pointer temporary */ + ip->base_type = TREE_TYPE (array_type); + ptr_type = build_pointer_type (ip->base_type); + ip->loc_ptr_temp = + build_temporary_variable ("loc_ptr_temp", ptr_type); + + + /* declare the user's iteration variable in + the loop's scope, as an expression, to be + passed to build_component_ref later */ + save_expr_under_name (ip->user_var, + build1 (INDIRECT_REF, ip->base_type, + ip->loc_ptr_temp)); + + /* FIXME: see stor_layout */ + ip->step_temp = size_in_bytes (ip->base_type); + + /* pointer to first array entry to look at */ + start_ptr = build1 (ADDR_EXPR, ptr_type, array_data_ptr); + mark_addressable (array_data_ptr); + ip->start_temp = ip->down_flag ? + fold (build (PLUS_EXPR, ptr_type, + start_ptr, + fold (build (MULT_EXPR, integer_type_node, ip->step_temp, + fold (build (MINUS_EXPR, integer_type_node, + array_length, + integer_one_node)))))) + : start_ptr; + } + default: + ; + } + } + return firstp->error_flag; +} + +/* + * Initialize the hidden iteration-control variables, + * and the user's explicit loop variable. + */ +static int +initialize_iter_var () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_FOREVER: + case DO_WHILE: + break; + case DO_STEP: + case DO_RANGE: + { + tree count = + fold (build (PLUS_EXPR, ip->iter_type, integer_one_node, + fold (build (TRUNC_DIV_EXPR, ip->iter_type, + convert (ip->iter_type, + fold (build (MINUS_EXPR, ip->iter_type, + ip->down_flag ? ip->start_temp : ip->end_temp, + ip->down_flag ? ip->end_temp : ip->start_temp))), + ip->step_temp)))); + /* initialize the loop's hidden counter variable */ + expand_expr_stmt ( + build_chill_modify_expr (ip->iter_var, count)); + + /* initialize user's variable */ + expand_expr_stmt ( + build_chill_modify_expr (ip->user_var, ip->start_temp)); + } + break; + case DO_POWERSET: + break; + case DO_LOC: + { + tree array_type = TREE_TYPE (ip->start_exp); + tree array_length = + fold (build (TRUNC_DIV_EXPR, integer_type_node, + size_in_bytes (array_type), + size_in_bytes (TREE_TYPE (array_type)))); + + expand_expr_stmt ( + build_chill_modify_expr (ip->iter_var, array_length)); + goto do_loc_common; + } + + case DO_LOC_VARYING: + expand_expr_stmt ( + build_chill_modify_expr (ip->iter_var, + convert (integer_type_node, + build_component_ref (ip->start_exp, var_length_id)))); + + do_loc_common: + expand_expr_stmt ( + build_chill_modify_expr (ip->loc_ptr_temp, + ip->start_temp)); + break; + + default: + ; + } + } + return firstp->error_flag; +} + +/* Generate code to skip the whole loop, if start expression not + * <= end expression (or >= for DOWN loops). This comparison must + * *NOT* be done in unsigned mode, or it will fail. + * Also, skip processing an empty VARYING array. + */ +static int +maybe_skip_loop () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_STEP: + expand_start_cond ( + build (ip->down_flag ? GE_EXPR : LE_EXPR, + TREE_TYPE (ip->start_exp), + ip->start_exp, ip->end_exp), 0); + break; + + case DO_LOC_VARYING: + { tree array_length = + convert (integer_type_node, + build_component_ref (ip->start_exp, var_length_id)); + expand_start_cond ( + build (NE_EXPR, TREE_TYPE (array_length), + array_length, integer_zero_node), 0); + break; + } + default: + break; + } + } + return 0; +} + +/* + * Check at the top of the loop for a termination + */ +static int +top_loop_end_check () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + + /* now, exit the loop if the condition isn't TRUE. */ + if (firstp->condition) + { + expand_exit_loop_if_false (0, + chill_truthvalue_conversion (firstp->condition)); + } + + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_FOREVER: + case DO_WHILE: + case DO_STEP: + case DO_RANGE: + break; + case DO_POWERSET: + { + tree temp1; + char *func_name; + + if (ip->down_flag) + func_name = "__flsetclrpowerset"; + else + func_name = "__ffsetclrpowerset"; + + temp1 = TYPE_MIN_VALUE + (TYPE_DOMAIN (TREE_TYPE (ip->powerset_temp))); + expand_exit_loop_if_false (0, + build_chill_function_call (lookup_name (get_identifier (func_name)), + tree_cons (NULL_TREE, force_addr_of (ip->powerset_temp), + tree_cons (NULL_TREE, powersetlen (ip->powerset_temp), + tree_cons (NULL_TREE, force_addr_of (ip->user_var), + tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (ip->user_var)), + tree_cons (NULL_TREE, + convert (long_integer_type_node, temp1), + NULL_TREE))))))); + } + break; + case DO_LOC: + case DO_LOC_VARYING: + break; + default: + ; + } + } + return firstp->error_flag; +} + +/* + * Check generated temporaries for loop's end + */ +static int +bottom_loop_end_check () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + + emit_line_note (input_filename, lineno); + + /* now, generate code to check each loop counter for termination */ + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_FOREVER: + case DO_WHILE: + break; + case DO_STEP: + case DO_RANGE: + case DO_LOC: + case DO_LOC_VARYING: + /* decrement iteration counter by one */ + chill_expand_assignment (ip->iter_var, MINUS_EXPR, integer_one_node); + /* exit if it's zero */ + expand_exit_loop_if_false (0, + build (NE_EXPR, boolean_type_node, + ip->iter_var, + integer_zero_node)); + break; + case DO_POWERSET: + break; + default: + ; + } + } + + return firstp->error_flag; +} + +/* + * increment the loop-control variables. + */ +static int +increment_temps () +{ + ITERATOR *firstp = loop_stack->iter_list, *ip; + + for (ip = firstp; ip != NULL; ip = ip->next) + { + switch (ip->itype) + { + case DO_FOREVER: + case DO_WHILE: + break; + case DO_STEP: + case DO_RANGE: + { + tree delta = + fold (build (ip->down_flag ? MINUS_EXPR : PLUS_EXPR, + TREE_TYPE (ip->user_var), ip->user_var, + ip->step_temp)); + expand_expr_stmt ( + build_chill_modify_expr (ip->user_var, delta)); + } + break; + case DO_LOC: + case DO_LOC_VARYING: + /* This statement uses the C semantics, so that + the pointer is actually incremented by the + length of the object pointed to. */ +#if 1 + expand_expr_stmt ( + build_modify_expr (ip->loc_ptr_temp, + ip->down_flag ? MINUS_EXPR : PLUS_EXPR, + integer_one_node)); +#else + { + enum tree_code op = ip->down_flag ? MINUS_EXPR : PLUS_EXPR; + tree el_type = TREE_TYPE (TREE_TYPE (ip->loc_ptr_temp)); + chill_expand_assignment (ip->loc_ptr_temp, NOP_EXPR, + build (op, + TREE_TYPE (ip->loc_ptr_temp), + ip->loc_ptr_temp, + size_in_bytes (el_type))); + } +#endif + break; + case DO_POWERSET: + break; + default: + ; + } + } + return firstp->error_flag; +} + +/* + * Generate a (temporary) unique identifier_node of + * the form "__tmp_%s_%d" + */ +tree +get_unique_identifier (lead) + char *lead; +{ + char idbuf [256]; + static int idcount = 0; + + sprintf (idbuf, "__tmp_%s_%d", lead ? lead : "", idcount++); + return get_identifier (idbuf); +} + +/* + * build a temporary variable, given its NAME and TYPE. + * The name will have a number appended to assure uniqueness. + * return its DECL node. + */ +static tree +build_temporary_variable (name, type) + char *name; + tree type; +{ + return decl_temp1 (get_unique_identifier (name), type, 0, NULL_TREE, 0, 0); +} + + +/* + * If the given expression isn't a constant, build a temp for it + * and evaluate the expression into the temp. Return the tree + * representing either the original constant expression or the + * temp which now contains the expression's value. + */ +static tree +maybe_make_for_temp (exp, temp_name, exp_type) + tree exp; + char *temp_name; + tree exp_type; +{ + tree result = exp; + + if (exp != NULL_TREE) + { + /* if exp isn't constant, create a temporary for its value */ + if (TREE_CONSTANT (exp)) + { + /* FIXME: assure that TREE_TYPE (result) == ip->exp_type */ + result = convert (exp_type, exp); + } + else { + /* build temp, assign the value */ + result = decl_temp1 (get_unique_identifier (temp_name), exp_type, 0, + exp, 0, 0); + } + } + return result; +} + + +/* + * Adapt the C unsigned_type function to CHILL - we need to + * account for any CHILL-specific integer types here. So far, + * the 16-bit integer type is the only one. + */ +static tree +chill_unsigned_type (type) + tree type; +{ + extern tree chill_unsigned_type_node; + tree type1 = TYPE_MAIN_VARIANT (type); + + if (type1 == chill_integer_type_node) + return chill_unsigned_type_node; + else + return unsigned_type (type); +} diff --git a/gcc/ch/parse.h b/gcc/ch/parse.h new file mode 100644 index 0000000..6b6b159 --- /dev/null +++ b/gcc/ch/parse.h @@ -0,0 +1,76 @@ +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 +}; diff --git a/gcc/ch/runtime/concatstr.c b/gcc/ch/runtime/concatstr.c new file mode 100644 index 0000000..e4105d6 --- /dev/null +++ b/gcc/ch/runtime/concatstr.c @@ -0,0 +1,69 @@ +/* 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; +} diff --git a/gcc/ch/runtime/continue.c b/gcc/ch/runtime/continue.c new file mode 100644 index 0000000..76d457d --- /dev/null +++ b/gcc/ch/runtime/continue.c @@ -0,0 +1,83 @@ +/* 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; diff --git a/gcc/ch/runtime/convdurrtstime.c b/gcc/ch/runtime/convdurrtstime.c new file mode 100644 index 0000000..f56fc3a --- /dev/null +++ b/gcc/ch/runtime/convdurrtstime.c @@ -0,0 +1,52 @@ +/* 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; +} diff --git a/gcc/ch/runtime/ffsetclrps.c b/gcc/ch/runtime/ffsetclrps.c new file mode 100644 index 0000000..bb5b965 --- /dev/null +++ b/gcc/ch/runtime/ffsetclrps.c @@ -0,0 +1,102 @@ +/* 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 +#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; + } +} diff --git a/gcc/ch/runtime/flsetclrps.c b/gcc/ch/runtime/flsetclrps.c new file mode 100644 index 0000000..e768a47 --- /dev/null +++ b/gcc/ch/runtime/flsetclrps.c @@ -0,0 +1,99 @@ +/* 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 +#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; + } +} diff --git a/gcc/ch/runtime/leps.c b/gcc/ch/runtime/leps.c new file mode 100644 index 0000000..7c5231a --- /dev/null +++ b/gcc/ch/runtime/leps.c @@ -0,0 +1,76 @@ +/* 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 +#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; + } +} diff --git a/gcc/ch/runtime/powerset.h b/gcc/ch/runtime/powerset.h new file mode 100644 index 0000000..3ceb776 --- /dev/null +++ b/gcc/ch/runtime/powerset.h @@ -0,0 +1,106 @@ +/* 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 diff --git a/gcc/ch/runtime/queuelength.c b/gcc/ch/runtime/queuelength.c new file mode 100644 index 0000000..417d175 --- /dev/null +++ b/gcc/ch/runtime/queuelength.c @@ -0,0 +1,79 @@ +/* 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; +} diff --git a/gcc/ch/runtime/readrecord.c b/gcc/ch/runtime/readrecord.c new file mode 100644 index 0000000..03641f9 --- /dev/null +++ b/gcc/ch/runtime/readrecord.c @@ -0,0 +1,208 @@ +/* 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 +#include +#include +#include + +#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; +} diff --git a/gcc/ch/runtime/rtsdummy.c b/gcc/ch/runtime/rtsdummy.c new file mode 100644 index 0000000..cff2289 --- /dev/null +++ b/gcc/ch/runtime/rtsdummy.c @@ -0,0 +1,65 @@ +/* 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 +#include +#include +/*#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; diff --git a/gcc/ch/runtime/sequencible.c b/gcc/ch/runtime/sequencible.c new file mode 100644 index 0000000..94166ff --- /dev/null +++ b/gcc/ch/runtime/sequencible.c @@ -0,0 +1,32 @@ +/* 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; +} + diff --git a/gcc/ch/runtime/setbitps.c b/gcc/ch/runtime/setbitps.c new file mode 100644 index 0000000..f465548 --- /dev/null +++ b/gcc/ch/runtime/setbitps.c @@ -0,0 +1,89 @@ +/* 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 +#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); + } +} diff --git a/gcc/ch/runtime/setbits.c b/gcc/ch/runtime/setbits.c new file mode 100644 index 0000000..1e3045c --- /dev/null +++ b/gcc/ch/runtime/setbits.c @@ -0,0 +1,85 @@ +/* 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 +#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); + } + } +} diff --git a/gcc/ch/runtime/settextindex.c b/gcc/ch/runtime/settextindex.c new file mode 100644 index 0000000..94b9266 --- /dev/null +++ b/gcc/ch/runtime/settextindex.c @@ -0,0 +1,38 @@ +/* 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; +} + diff --git a/gcc/ch/runtime/variable.c b/gcc/ch/runtime/variable.c new file mode 100644 index 0000000..69810b3 --- /dev/null +++ b/gcc/ch/runtime/variable.c @@ -0,0 +1,31 @@ +/* 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; +} diff --git a/gcc/ch/runtime/writeable.c b/gcc/ch/runtime/writeable.c new file mode 100644 index 0000000..cf0f5cd --- /dev/null +++ b/gcc/ch/runtime/writeable.c @@ -0,0 +1,31 @@ +/* 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; +} diff --git a/gcc/ch/tasking.h b/gcc/ch/tasking.h new file mode 100644 index 0000000..31e0581 --- /dev/null +++ b/gcc/ch/tasking.h @@ -0,0 +1,26 @@ +/* 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 diff --git a/gcc/ch/tree.c b/gcc/ch/tree.c new file mode 100644 index 0000000..b1d0168 --- /dev/null +++ b/gcc/ch/tree.c @@ -0,0 +1,293 @@ +/* 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; + +/* 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; +} + +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); +} -- cgit v1.1