inout.c

gcc-2.95.3 Linux下最常用的C编译器

	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 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
  arg5 = NULL_TREE, arg6, arg7;
  int had_errors = 0;
  tree result;

  /* make some checks */
  if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK)
    return error_mark_node;

  /* check the association */
  if (! check_assoc (assoc, 1, "ASSOCIATION"))
    had_errors = 1;
  else
    /* build a pointer to the association */
    arg1 = force_addr_of (assoc);

  /* check the filename, must be a string */
  if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
      (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
       TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
    {
      if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
	{
	  error ("argument 2 of ASSOCIATE must not be an empty string");
	  had_errors = 1;
	}
      else
	{
	  arg2 = force_addr_of (fname);
	  arg3 = size_in_bytes (TREE_TYPE (fname));
	}
    }
  else if (chill_varying_string_type_p (TREE_TYPE (fname)))
    {
      arg2 = force_addr_of (build_component_ref (fname, var_data_id));
      arg3 = build_component_ref (fname, var_length_id);
    }
  else
    {
      error ("argument 2 to ASSOCIATE must be a string");
      had_errors = 1;
    }

  /* check attr argument, must be a string too */
  if (attr == NULL_TREE)
    {
      arg4 = null_pointer_node;
      arg5 = integer_zero_node;
    }
  else
    {
      attr = TREE_VALUE (attr);
      if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK)
	had_errors = 1;
      else
	{
	  if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
	      (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
	       TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
	    {
	      if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
		{
		  arg4 = null_pointer_node;
		  arg5 = integer_zero_node;
		}
	      else
		{
		  arg4 = force_addr_of (attr);
		  arg5 = size_in_bytes (TREE_TYPE (attr));
		}
	    }
	  else if (chill_varying_string_type_p (TREE_TYPE (attr)))
	    {
	      arg4 = force_addr_of (build_component_ref (attr, var_data_id));
	      arg5 = build_component_ref (attr, var_length_id);
	    }
	  else
	    {
	      error ("argument 3 to ASSOCIATE must be a string");
	      had_errors = 1;
	    }
	}
    }

  if (had_errors)
    return error_mark_node;

  /* other arguments */
  arg6 = force_addr_of (get_chill_filename ());
  arg7 = get_chill_linenumber ();

  result = build_chill_function_call (
     lookup_name (get_identifier ("__associate")),
            tree_cons (NULL_TREE, arg1,
              tree_cons (NULL_TREE, arg2,
                tree_cons (NULL_TREE, arg3,
                  tree_cons (NULL_TREE, arg4,
                    tree_cons (NULL_TREE, arg5,
                      tree_cons (NULL_TREE, arg6,
                        tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
  
  TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc));
  return result;
}

static tree
assoc_call (assoc, func, name)
     tree assoc;
     tree func;
     char *name;
{
  tree arg1, arg2, arg3;
  tree result;

  if (! check_assoc (assoc, 1, name))
    return error_mark_node;

  arg1 = force_addr_of (assoc);
  arg2 = force_addr_of (get_chill_filename ());
  arg3 = get_chill_linenumber ();

  result = build_chill_function_call (func,
            tree_cons (NULL_TREE, arg1,
              tree_cons (NULL_TREE, arg2,
                tree_cons (NULL_TREE, arg3, NULL_TREE))));
  return result;
}

tree
build_chill_isassociated (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__isassociated")),
			    "ISASSOCIATED");
  return result;
}

tree
build_chill_existing (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__existing")),
			    "EXISTING");
  return result;
}

tree
build_chill_readable (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__readable")),
			    "READABLE");
  return result;
}

tree
build_chill_writeable (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__writeable")),
			    "WRITEABLE");
  return result;
}

tree
build_chill_sequencible (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__sequencible")),
			    "SEQUENCIBLE");
  return result;
}

tree
build_chill_variable (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__variable")),
			    "VARIABLE");
  return result;
}

tree
build_chill_indexable (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__indexable")),
			    "INDEXABLE");
  return result;
}

tree
build_chill_dissociate (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__dissociate")),
			    "DISSOCIATE");
  return result;
}

tree
build_chill_create (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__create")),
			    "CREATE");
  return result;
}

tree
build_chill_delete (assoc)
     tree assoc;
{
  tree result = assoc_call (assoc,
			    lookup_name (get_identifier ("__delete")),
			    "DELETE");
  return result;
}

tree
build_chill_modify (assoc, list)
     tree assoc;
     tree list;
{
  tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
  arg5 = NULL_TREE, arg6, arg7;
  int had_errors = 0, numargs;
  tree fname = NULL_TREE, attr = NULL_TREE;
  tree result;

  /* check the association */
  if (! check_assoc (assoc, 1, "MODIFY"))
    had_errors = 1;
  else
    arg1 = force_addr_of (assoc);

  /* look how much arguments we have got */
  numargs = list_length (list);
  switch (numargs)
    {
    case 0:
      break;
    case 1:
      fname = TREE_VALUE (list);
      break;
    case 2:
      fname = TREE_VALUE (list);
      attr = TREE_VALUE (TREE_CHAIN (list));
      break;
    default:
      error ("Too many arguments in call to MODIFY");
      had_errors = 1;
      break;
    }

  if (fname !=  NULL_TREE && fname != null_pointer_node)
    {
      if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
	  (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
	   TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
	{
	  if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
	    {
	      error ("argument 2 of MODIFY must not be an empty string");
	      had_errors = 1;
	    }
	  else
	    {
	      arg2 = force_addr_of (fname);
	      arg3 = size_in_bytes (TREE_TYPE (fname));
	    }
	}
      else if (chill_varying_string_type_p (TREE_TYPE (fname)))
	{
	  arg2 = force_addr_of (build_component_ref (fname, var_data_id));
	  arg3 = build_component_ref (fname, var_length_id);
	}
      else
	{
	  error ("argument 2 to MODIFY must be a string");
	  had_errors = 1;
	}
    }
  else
    {
      arg2 = null_pointer_node;
      arg3 = integer_zero_node;
    }

  if (attr != NULL_TREE && attr != null_pointer_node)
    {
      if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
	  (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
	   TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
	{
	  if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
	    {
	      arg4 = null_pointer_node;
	      arg5 = integer_zero_node;
	    }
	  else
	    {
	      arg4 = force_addr_of (attr);
	      arg5 = size_in_bytes (TREE_TYPE (attr));
	    }
	}
      else if (chill_varying_string_type_p (TREE_TYPE (attr)))
	{
	  arg4 = force_addr_of (build_component_ref (attr, var_data_id));
	  arg5 = build_component_ref (attr, var_length_id);
	}
      else
	{
	  error ("argument 3 to MODIFY must be a string");
	  had_errors = 1;
	}
    }
  else
    {
      arg4 = null_pointer_node;
      arg5 = integer_zero_node;
    }

  if (had_errors)
    return error_mark_node;

  /* other arguments */
  arg6 = force_addr_of (get_chill_filename ());
  arg7 = get_chill_linenumber ();

  result = build_chill_function_call (
     lookup_name (get_identifier ("__modify")),
            tree_cons (NULL_TREE, arg1,
              tree_cons (NULL_TREE, arg2,
                tree_cons (NULL_TREE, arg3,
                  tree_cons (NULL_TREE, arg4,
                    tree_cons (NULL_TREE, arg5,
                      tree_cons (NULL_TREE, arg6,
                        tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
  
  return result;
}

static int
check_transfer (transfer, argnum, errmsg)
     tree transfer;
     int argnum;
     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 (dec