Пример #1
0
static void
list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
			     size_t size)
{
  if (dtp->u.p.current_unit == NULL)
    return;

  if (dtp->u.p.first_item)
    {
      dtp->u.p.first_item = 0;
      write_char (dtp, ' ');
    }
  else
    {
      if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
	dtp->u.p.current_unit->delim_status != DELIM_NONE)
      write_separator (dtp);
    }

  switch (type)
    {
    case BT_INTEGER:
      write_integer (dtp, p, kind);
      break;
    case BT_LOGICAL:
      write_logical (dtp, p, kind);
      break;
    case BT_CHARACTER:
      write_character (dtp, p, kind, size);
      break;
    case BT_REAL:
      write_real (dtp, p, kind);
      break;
    case BT_COMPLEX:
      write_complex (dtp, p, kind, size);
      break;
    default:
      internal_error (&dtp->common, "list_formatted_write(): Bad type");
    }

  dtp->u.p.char_flag = (type == BT_CHARACTER);
}
Пример #2
0
static namelist_info *
nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
	       namelist_info * base, char * base_name)
{
  int rep_ctr;
  int num;
  int nml_carry;
  int len;
  index_type obj_size;
  index_type nelem;
  size_t dim_i;
  size_t clen;
  index_type elem_ctr;
  size_t obj_name_len;
  void * p ;
  char cup;
  char * obj_name;
  char * ext_name;
  char rep_buff[NML_DIGITS];
  namelist_info * cmp;
  namelist_info * retval = obj->next;
  size_t base_name_len;
  size_t base_var_name_len;
  size_t tot_len;
  unit_delim tmp_delim;
  
  /* Set the character to be used to separate values
     to a comma or semi-colon.  */

  char semi_comma =
	dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';

  /* Write namelist variable names in upper case. If a derived type,
     nothing is output.  If a component, base and base_name are set.  */

  if (obj->type != GFC_DTYPE_DERIVED)
    {
      namelist_write_newline (dtp);
      write_character (dtp, " ", 1, 1);

      len = 0;
      if (base)
	{
	  len = strlen (base->var_name);
	  base_name_len = strlen (base_name);
	  for (dim_i = 0; dim_i < base_name_len; dim_i++)
            {
	      cup = toupper (base_name[dim_i]);
	      write_character (dtp, &cup, 1, 1);
            }
	}
      clen = strlen (obj->var_name);
      for (dim_i = len; dim_i < clen; dim_i++)
	{
	  cup = toupper (obj->var_name[dim_i]);
	  write_character (dtp, &cup, 1, 1);
	}
      write_character (dtp, "=", 1, 1);
    }

  /* Counts the number of data output on a line, including names.  */

  num = 1;

  len = obj->len;

  switch (obj->type)
    {

    case GFC_DTYPE_REAL:
      obj_size = size_from_real_kind (len);
      break;

    case GFC_DTYPE_COMPLEX:
      obj_size = size_from_complex_kind (len);
      break;

    case GFC_DTYPE_CHARACTER:
      obj_size = obj->string_length;
      break;

    default:
      obj_size = len;      
    }

  if (obj->var_rank)
    obj_size = obj->size;

  /* Set the index vector and count the number of elements.  */

  nelem = 1;
  for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
    {
      obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
      nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
    }

  /* Main loop to output the data held in the object.  */

  rep_ctr = 1;
  for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
    {

      /* Build the pointer to the data value.  The offset is passed by
	 recursive calls to this function for arrays of derived types.
	 Is NULL otherwise.  */

      p = (void *)(obj->mem_pos + elem_ctr * obj_size);
      p += offset;

      /* Check for repeat counts of intrinsic types.  */

      if ((elem_ctr < (nelem - 1)) &&
	  (obj->type != GFC_DTYPE_DERIVED) &&
	  !memcmp (p, (void*)(p + obj_size ), obj_size ))
	{
	  rep_ctr++;
	}

      /* Execute a repeated output.  Note the flag no_leading_blank that
	 is used in the functions used to output the intrinsic types.  */

      else
	{
	  if (rep_ctr > 1)
	    {
	      sprintf(rep_buff, " %d*", rep_ctr);
	      write_character (dtp, rep_buff, 1, strlen (rep_buff));
	      dtp->u.p.no_leading_blank = 1;
	    }
	  num++;

	  /* Output the data, if an intrinsic type, or recurse into this
	     routine to treat derived types.  */

	  switch (obj->type)
	    {

	    case GFC_DTYPE_INTEGER:
	      write_integer (dtp, p, len);
              break;

	    case GFC_DTYPE_LOGICAL:
	      write_logical (dtp, p, len);
              break;

	    case GFC_DTYPE_CHARACTER:
	      tmp_delim = dtp->u.p.current_unit->delim_status;
	      if (dtp->u.p.nml_delim == '"')
		dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
	      if (dtp->u.p.nml_delim == '\'')
		dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
	      write_character (dtp, p, 1, obj->string_length);
		dtp->u.p.current_unit->delim_status = tmp_delim;
              break;

	    case GFC_DTYPE_REAL:
	      write_real (dtp, p, len);
              break;

	   case GFC_DTYPE_COMPLEX:
	      dtp->u.p.no_leading_blank = 0;
	      num++;
              write_complex (dtp, p, len, obj_size);
              break;

	    case GFC_DTYPE_DERIVED:

	      /* To treat a derived type, we need to build two strings:
		 ext_name = the name, including qualifiers that prepends
			    component names in the output - passed to
			    nml_write_obj.
		 obj_name = the derived type name with no qualifiers but %
			    appended.  This is used to identify the
			    components.  */

	      /* First ext_name => get length of all possible components  */

	      base_name_len = base_name ? strlen (base_name) : 0;
	      base_var_name_len = base ? strlen (base->var_name) : 0;
	      ext_name = (char*)get_mem ( base_name_len
					+ base_var_name_len
					+ strlen (obj->var_name)
					+ obj->var_rank * NML_DIGITS
					+ 1);

	      memcpy (ext_name, base_name, base_name_len);
	      clen = strlen (obj->var_name + base_var_name_len);
	      memcpy (ext_name + base_name_len, 
		      obj->var_name + base_var_name_len, clen);
	      
	      /* Append the qualifier.  */

	      tot_len = base_name_len + clen;
	      for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
		{
		  if (!dim_i)
		    {
		      ext_name[tot_len] = '(';
		      tot_len++;
		    }
		  sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
		  tot_len += strlen (ext_name + tot_len);
		  ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
		  tot_len++;
		}

	      ext_name[tot_len] = '\0';

	      /* Now obj_name.  */

	      obj_name_len = strlen (obj->var_name) + 1;
	      obj_name = get_mem (obj_name_len+1);
	      memcpy (obj_name, obj->var_name, obj_name_len-1);
	      memcpy (obj_name + obj_name_len-1, "%", 2);

	      /* Now loop over the components. Update the component pointer
		 with the return value from nml_write_obj => this loop jumps
		 past nested derived types.  */

	      for (cmp = obj->next;
		   cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
		   cmp = retval)
		{
		  retval = nml_write_obj (dtp, cmp,
					  (index_type)(p - obj->mem_pos),
					  obj, ext_name);
		}

	      free_mem (obj_name);
	      free_mem (ext_name);
	      goto obj_loop;

            default:
	      internal_error (&dtp->common, "Bad type for namelist write");
            }

	  /* Reset the leading blank suppression, write a comma (or semi-colon)
	     and, if 5 values have been output, write a newline and advance
	     to column 2. Reset the repeat counter.  */

	  dtp->u.p.no_leading_blank = 0;
	  write_character (dtp, &semi_comma, 1, 1);
	  if (num > 5)
	    {
	      num = 0;
	      namelist_write_newline (dtp);
	      write_character (dtp, " ", 1, 1);
	    }
	  rep_ctr = 1;
	}

    /* Cycle through and increment the index vector.  */

obj_loop:

    nml_carry = 1;
    for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
      {
	obj->ls[dim_i].idx += nml_carry ;
	nml_carry = 0;
 	if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
	  {
 	    obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
	    nml_carry = 1;
	  }
       }
    }

  /* Return a pointer beyond the furthest object accessed.  */

  return retval;
}
Пример #3
0
static namelist_info *
nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
	       namelist_info * base, char * base_name)
{
  int rep_ctr;
  int num;
  int nml_carry;
  index_type len;
  index_type obj_size;
  index_type nelem;
  index_type dim_i;
  index_type clen;
  index_type elem_ctr;
  index_type obj_name_len;
  void * p ;
  char cup;
  char * obj_name;
  char * ext_name;
  char rep_buff[NML_DIGITS];
  namelist_info * cmp;
  namelist_info * retval = obj->next;

  /* Write namelist variable names in upper case. If a derived type,
     nothing is output.  If a component, base and base_name are set.  */

  if (obj->type != GFC_DTYPE_DERIVED)
    {
#ifdef HAVE_CRLF
      write_character (dtp, "\r\n ", 3);
#else
      write_character (dtp, "\n ", 2);
#endif
      len = 0;
      if (base)
	{
	  len =strlen (base->var_name);
	  for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
            {
	      cup = toupper (base_name[dim_i]);
	      write_character (dtp, &cup, 1);
            }
	}
      for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
	{
	  cup = toupper (obj->var_name[dim_i]);
	  write_character (dtp, &cup, 1);
	}
      write_character (dtp, "=", 1);
    }

  /* Counts the number of data output on a line, including names.  */

  num = 1;

  len = obj->len;

  switch (obj->type)
    {

    case GFC_DTYPE_REAL:
      obj_size = size_from_real_kind (len);
      break;

    case GFC_DTYPE_COMPLEX:
      obj_size = size_from_complex_kind (len);
      break;

    case GFC_DTYPE_CHARACTER:
      obj_size = obj->string_length;
      break;

    default:
      obj_size = len;      
    }

  if (obj->var_rank)
    obj_size = obj->size;

  /* Set the index vector and count the number of elements.  */

  nelem = 1;
  for (dim_i=0; dim_i < obj->var_rank; dim_i++)
    {
      obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
      nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
    }

  /* Main loop to output the data held in the object.  */

  rep_ctr = 1;
  for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
    {

      /* Build the pointer to the data value.  The offset is passed by
	 recursive calls to this function for arrays of derived types.
	 Is NULL otherwise.  */

      p = (void *)(obj->mem_pos + elem_ctr * obj_size);
      p += offset;

      /* Check for repeat counts of intrinsic types.  */

      if ((elem_ctr < (nelem - 1)) &&
	  (obj->type != GFC_DTYPE_DERIVED) &&
	  !memcmp (p, (void*)(p + obj_size ), obj_size ))
	{
	  rep_ctr++;
	}

      /* Execute a repeated output.  Note the flag no_leading_blank that
	 is used in the functions used to output the intrinsic types.  */

      else
	{
	  if (rep_ctr > 1)
	    {
	      st_sprintf(rep_buff, " %d*", rep_ctr);
	      write_character (dtp, rep_buff, strlen (rep_buff));
	      dtp->u.p.no_leading_blank = 1;
	    }
	  num++;

	  /* Output the data, if an intrinsic type, or recurse into this
	     routine to treat derived types.  */

	  switch (obj->type)
	    {

	    case GFC_DTYPE_INTEGER:
	      write_integer (dtp, p, len);
              break;

	    case GFC_DTYPE_LOGICAL:
	      write_logical (dtp, p, len);
              break;

	    case GFC_DTYPE_CHARACTER:
	      if (dtp->u.p.nml_delim)
		write_character (dtp, &dtp->u.p.nml_delim, 1);
	      write_character (dtp, p, obj->string_length);
	      if (dtp->u.p.nml_delim)
		write_character (dtp, &dtp->u.p.nml_delim, 1);
              break;

	    case GFC_DTYPE_REAL:
	      write_real (dtp, p, len);
              break;

	    case GFC_DTYPE_COMPLEX:
	      dtp->u.p.no_leading_blank = 0;
	      num++;
              write_complex (dtp, p, len, obj_size);
              break;

	    case GFC_DTYPE_DERIVED:

	      /* To treat a derived type, we need to build two strings:
		 ext_name = the name, including qualifiers that prepends
			    component names in the output - passed to
			    nml_write_obj.
		 obj_name = the derived type name with no qualifiers but %
			    appended.  This is used to identify the
			    components.  */

	      /* First ext_name => get length of all possible components  */

	      ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
					+ (base ? strlen (base->var_name) : 0)
					+ strlen (obj->var_name)
					+ obj->var_rank * NML_DIGITS
					+ 1);

	      strcpy(ext_name, base_name ? base_name : "");
	      clen = base ? strlen (base->var_name) : 0;
	      strcat (ext_name, obj->var_name + clen);

	      /* Append the qualifier.  */

	      for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
		{
		  strcat (ext_name, dim_i ? "" : "(");
		  clen = strlen (ext_name);
		  st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
		  strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
		}

	      /* Now obj_name.  */

	      obj_name_len = strlen (obj->var_name) + 1;
	      obj_name = get_mem (obj_name_len+1);
	      strcpy (obj_name, obj->var_name);
	      strcat (obj_name, "%");

	      /* Now loop over the components. Update the component pointer
		 with the return value from nml_write_obj => this loop jumps
		 past nested derived types.  */

	      for (cmp = obj->next;
		   cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
		   cmp = retval)
		{
		  retval = nml_write_obj (dtp, cmp,
					  (index_type)(p - obj->mem_pos),
					  obj, ext_name);
		}

	      free_mem (obj_name);
	      free_mem (ext_name);
	      goto obj_loop;

            default:
	      internal_error (&dtp->common, "Bad type for namelist write");
            }

	  /* Reset the leading blank suppression, write a comma and, if 5
	     values have been output, write a newline and advance to column
	     2. Reset the repeat counter.  */

	  dtp->u.p.no_leading_blank = 0;
	  write_character (dtp, ",", 1);
	  if (num > 5)
	    {
	      num = 0;
#ifdef HAVE_CRLF
	      write_character (dtp, "\r\n ", 3);
#else
	      write_character (dtp, "\n ", 2);
#endif
	    }
	  rep_ctr = 1;
	}

    /* Cycle through and increment the index vector.  */

obj_loop:

    nml_carry = 1;
    for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
      {
	obj->ls[dim_i].idx += nml_carry ;
	nml_carry = 0;
	if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
	  {
	    obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
	    nml_carry = 1;
	  }
       }
    }

  /* Return a pointer beyond the furthest object accessed.  */

  return retval;
}