gcc/libgfortran/io/list_read.c

/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran 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.

Libgfortran 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 Libgfortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */


#include "config.h"
#include <string.h>
#include <ctype.h>
#include "libgfortran.h"
#include "io.h"


/* List directed input.  Several parsing subroutines are practically
 * reimplemented from formatted input, the reason being that there are
 * all kinds of small differences between formatted and list directed
 * parsing. */


/* Subroutines for reading characters from the input.  Because a
 * repeat count is ambiguous with an integer, we have to read the
 * whole digit string before seeing if there is a '*' which signals
 * the repeat count.  Since we can have a lot of potential leading
 * zeros, we have to be able to back up by arbitrary amount.  Because
 * the input might not be seekable, we have to buffer the data
 * ourselves.  Data is buffered in scratch[] until it becomes too
 * large, after which we start allocating memory on the heap.  */

static int repeat_count, saved_length, saved_used, input_complete, at_eol;
static int comma_flag, namelist_mode;

static char last_char, *saved_string;
static bt saved_type;



/* Storage area for values except for strings.  Must be large enough
 * to hold a complex value (two reals) of the largest kind */

static char value[20];

#define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
                      case '5': case '6': case '7': case '8': case '9'

#define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t'

/* This macro assumes that we're operating on a variable */

#define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
                         || c == '\t')

/* Maximum repeat count.  Less than ten times the maximum signed int32. */

#define MAX_REPEAT 200000000


/* push_char()-- Save a character to a string buffer, enlarging it as
 * necessary. */

static void
push_char (char c)
{
  char *new;

  if (saved_string == NULL)
    {
      saved_string = scratch;
      memset (saved_string,0,SCRATCH_SIZE);
      saved_length = SCRATCH_SIZE;
      saved_used = 0;
    }

  if (saved_used >= saved_length)
    {
      saved_length = 2 * saved_length;
      new = get_mem (2 * saved_length);

      memset (new,0,2 * saved_length);

      memcpy (new, saved_string, saved_used);
      if (saved_string != scratch)
	free_mem (saved_string);

      saved_string = new;
    }

  saved_string[saved_used++] = c;
}


/* free_saved()-- Free the input buffer if necessary. */

static void
free_saved (void)
{

  if (saved_string == NULL)
    return;

  if (saved_string != scratch)
    free_mem (saved_string);

  saved_string = NULL;
}


static char
next_char (void)
{
  int length;
  char c, *p;

  if (last_char != '\0')
    {
      at_eol = 0;
      c = last_char;
      last_char = '\0';
      goto done;
    }

  length = 1;

  p = salloc_r (current_unit->s, &length);
  if (p == NULL)
    {
      generate_error (ERROR_OS, NULL);
      return '\0';
    }

  if (length == 0)
    longjmp (g.eof_jump, 1);
  c = *p;

done:
  at_eol = (c == '\n');
  return c;
}


/* unget_char()-- Push a character back onto the input */

static void
unget_char (char c)
{

  last_char = c;
}


/* eat_spaces()-- Skip over spaces in the input.  Returns the nonspace
 * character that terminated the eating and also places it back on the
 * input. */

static char
eat_spaces (void)
{
  char c;

  do
    {
      c = next_char ();
    }
  while (c == ' ' || c == '\t');

  unget_char (c);
  return c;
}


/* eat_separator()-- Skip over a separator.  Technically, we don't
 * always eat the whole separator.  This is because if we've processed
 * the last input item, then a separator is unnecessary.  Plus the
 * fact that operating systems usually deliver console input on a line
 * basis.
 *
 * The upshot is that if we see a newline as part of reading a
 * separator, we stop reading.  If there are more input items, we
 * continue reading the separator with finish_separator() which takes
 * care of the fact that we may or may not have seen a comma as part
 * of the separator. */

static void
eat_separator (void)
{
  char c;

  eat_spaces ();
  comma_flag = 0;

  c = next_char ();
  switch (c)
    {
    case ',':
      comma_flag = 1;
      eat_spaces ();
      break;

    case '/':
      input_complete = 1;
      next_record (0);
      break;

    case '\n':
      break;

    case '!':
      if (namelist_mode)
	{			/* Eat a namelist comment */
	  do
	    c = next_char ();
	  while (c != '\n');

	  break;
	}

      /* Fall Through */

    default:
      unget_char (c);
      break;
    }
}


/* finish_separator()-- Finish processing a separator that was
 * interrupted by a newline.  If we're here, then another data item is
 * present, so we finish what we started on the previous line. */

static void
finish_separator (void)
{
  char c;

restart:
  eat_spaces ();

  c = next_char ();
  switch (c)
    {
    case ',':
      if (comma_flag)
	unget_char (c);
      else
	{
	  c = eat_spaces ();
	  if (c == '\n')
	    goto restart;
	}

      break;

    case '/':
      input_complete = 1;
      next_record (0);
      break;

    case '\n':
      goto restart;

    case '!':
      if (namelist_mode)
	{
	  do
	    c = next_char ();
	  while (c != '\n');

	  goto restart;
	}

    default:
      unget_char (c);
      break;
    }
}


/* convert_integer()-- Convert an unsigned string to an integer.  The
 * length value is -1 if we are working on a repeat count.  Returns
 * nonzero if we have a range problem.  As a side effect, frees the
 * saved_string. */

static int
convert_integer (int length, int negative)
{
  char c, *buffer, message[100];
  int m;
  int64_t v, max, max10;

  buffer = saved_string;
  v = 0;

  max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
  max10 = max / 10;

  for (;;)
    {
      c = *buffer++;
      if (c == '\0')
	break;
      c -= '0';

      if (v > max10)
	goto overflow;
      v = 10 * v;

      if (v > max - c)
	goto overflow;
      v += c;
    }

  m = 0;

  if (length != -1)
    {
      if (negative)
	v = -v;
      set_integer (value, v, length);
    }
  else
    {
      repeat_count = v;

      if (repeat_count == 0)
	{
	  st_sprintf (message, "Zero repeat count in item %d of list input",
		      g.item_count);

	  generate_error (ERROR_READ_VALUE, message);
	  m = 1;
	}
    }

  free_saved ();
  return m;

overflow:
  if (length == -1)
    st_sprintf (message, "Repeat count overflow in item %d of list input",
		g.item_count);
  else
    st_sprintf (message, "Integer overflow while reading item %d",
		g.item_count);

  free_saved ();
  generate_error (ERROR_READ_VALUE, message);

  return 1;
}


/* parse_repeat()-- Parse a repeat count for logical and complex
 * values which cannot begin with a digit.  Returns nonzero if we are
 * done, zero if we should continue on. */

static int
parse_repeat (void)
{
  char c, message[100];
  int repeat;

  c = next_char ();
  switch (c)
    {
    CASE_DIGITS:
      repeat = c - '0';
      break;

    CASE_SEPARATORS:
      unget_char (c);
      eat_separator ();
      return 1;

    default:
      unget_char (c);
      return 0;
    }

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  repeat = 10 * repeat + c - '0';

	  if (repeat > MAX_REPEAT)
	    {
	      st_sprintf (message,
			  "Repeat count overflow in item %d of list input",
			  g.item_count);

	      generate_error (ERROR_READ_VALUE, message);
	      return 1;
	    }

	  break;

	case '*':
	  if (repeat == 0)
	    {
	      st_sprintf (message,
			  "Zero repeat count in item %d of list input",
			  g.item_count);

	      generate_error (ERROR_READ_VALUE, message);
	      return 1;
	    }

	  goto done;

	default:
	  goto bad_repeat;
	}
    }

done:
  repeat_count = repeat;
  return 0;

bad_repeat:
  st_sprintf (message, "Bad repeat count in item %d of list input",
	      g.item_count);

  generate_error (ERROR_READ_VALUE, message);
  return 1;
}


/* read_logical()-- Read a logical character on the input */

static void
read_logical (int length)
{
  char c, message[100];
  int v;

  if (parse_repeat ())
    return;

  c = next_char ();
  switch (c)
    {
    case 't':
    case 'T':
      v = 1;
      break;
    case 'f':
    case 'F':
      v = 0;
      break;

    case '.':
      c = next_char ();
      switch (c)
	{
	case 't':
	case 'T':
	  v = 1;
	  break;
	case 'f':
	case 'F':
	  v = 0;
	  break;
	default:
	  goto bad_logical;
	}

      break;

    CASE_SEPARATORS:
      unget_char (c);
      eat_separator ();
      return;			/* Null value */

    default:
      goto bad_logical;
    }

  saved_type = BT_LOGICAL;
  saved_length = length;

  /* Eat trailing garbage */

  do
    {
      c = next_char ();
    }
  while (!is_separator (c));

  unget_char (c);
  eat_separator ();
  free_saved ();
  set_integer ((int *) value, v, length);

  return;

bad_logical:
  st_sprintf (message, "Bad logical value while reading item %d",
	      g.item_count);

  generate_error (ERROR_READ_VALUE, message);
}


/* read_integer()-- Reading integers is tricky because we can actually
 * be reading a repeat count.  We have to store the characters in a
 * buffer because we could be reading an integer that is larger than the
 * default int used for repeat counts.  */

static void
read_integer (int length)
{
  char c, message[100];
  int negative;

  negative = 0;

  c = next_char ();
  switch (c)
    {
    case '-':
      negative = 1;
      /* Fall through */

    case '+':
      c = next_char ();
      goto get_integer;

    CASE_SEPARATORS:		/* Single null */
      unget_char (c);
      eat_separator ();
      return;

    CASE_DIGITS:
      push_char (c);
      break;

    default:
      goto bad_integer;
    }

  /* Take care of what may be a repeat count */

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	case '*':
	  push_char ('\0');
	  goto repeat;

	CASE_SEPARATORS:	/* Not a repeat count */
	  goto done;

	default:
	  goto bad_integer;
	}
    }

repeat:
  if (convert_integer (-1, 0))
    return;

/* Get the real integer */

  c = next_char ();
  switch (c)
    {
    CASE_DIGITS:
      break;

    CASE_SEPARATORS:
      unget_char (c);
      eat_separator ();
      return;

    case '-':
      negative = 1;
      /* Fall through */

    case '+':
      c = next_char ();
      break;
    }

get_integer:
  if (!isdigit (c))
    goto bad_integer;
  push_char (c);

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	CASE_SEPARATORS:
	  goto done;

	default:
	  goto bad_integer;
	}
    }

bad_integer:
  free_saved ();

  st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
  generate_error (ERROR_READ_VALUE, message);

  return;

done:
  unget_char (c);
  eat_separator ();

  push_char ('\0');
  if (convert_integer (length, negative))
    {
       free_saved ();
       return;
    }

  free_saved ();
  saved_type = BT_INTEGER;
}


/* read_character()-- Read a character variable */

static void
read_character (int length)
{
  char c, quote, message[100];

  quote = ' ';			/* Space means no quote character */

  c = next_char ();
  switch (c)
    {
    CASE_DIGITS:
      push_char (c);
      break;

    CASE_SEPARATORS:
      unget_char (c);		/* NULL value */
      eat_separator ();
      return;

    case '"':
    case '\'':
      quote = c;
      goto get_string;

    default:
      push_char (c);
      goto get_string;
    }

/* Deal with a possible repeat count */

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	CASE_SEPARATORS:
	  unget_char (c);
	  goto done;		/* String was only digits! */

	case '*':
	  push_char ('\0');
	  goto got_repeat;

	default:
	  push_char (c);
	  goto get_string;	/* Not a repeat count after all */
	}
    }

got_repeat:
  if (convert_integer (-1, 0))
    return;

  /* Now get the real string */

  c = next_char ();
  switch (c)
    {
    CASE_SEPARATORS:
      unget_char (c);		/* repeated NULL values */
      eat_separator ();
      return;

    case '"':
    case '\'':
      quote = c;
      break;

    default:
      push_char (c);
      break;
    }

get_string:
  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	case '"':
	case '\'':
	  if (c != quote)
	    {
	      push_char (c);
	      break;
	    }

	  /* See if we have a doubled quote character or the end of the string */

	  c = next_char ();
	  if (c == quote)
	    {
	      push_char (quote);
	      break;
	    }

	  unget_char (c);
	  goto done;

	CASE_SEPARATORS:
	  if (quote == ' ')
	    {
	      unget_char (c);
	      goto done;
	    }

	  if (c != '\n')
	    push_char (c);
	  break;

	default:
	  push_char (c);
	  break;
	}
    }

/* At this point, we have to have a separator, or else the string is invalid */

done:
  c = next_char ();
  if (is_separator (c))
    {
      unget_char (c);
      eat_separator ();
      saved_type = BT_CHARACTER;
    }
  else
    {
      free_saved ();
      st_sprintf (message, "Invalid string input in item %d", g.item_count);
      generate_error (ERROR_READ_VALUE, message);
    }
}


/* parse_real()-- Parse a component of a complex constant or a real
 * number that we are sure is already there.  This is a straight real
 * number parser. */

static int
parse_real (void *buffer, int length)
{
  char c, message[100];
  int m, seen_dp;

  c = next_char ();
  if (c == '-' || c == '+')
    {
      push_char (c);
      c = next_char ();
    }

  if (!isdigit (c) && c != '.')
    goto bad;

  push_char (c);

  seen_dp = (c == '.') ? 1 : 0;

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	case '.':
	  if (seen_dp)
	    goto bad;

	  seen_dp = 1;
	  push_char (c);
	  break;

	case 'e':
	case 'E':
	case 'd':
	case 'D':
	  push_char ('e');
	  goto exp1;

	case '-':
	case '+':
	  push_char ('e');
	  push_char (c);
	  c = next_char ();
	  goto exp2;

	CASE_SEPARATORS:
	  unget_char (c);
	  goto done;

	default:
	  goto done;
	}
    }

exp1:
  c = next_char ();
  if (c != '-' && c != '+')
    push_char ('+');
  else
    {
      push_char (c);
      c = next_char ();
    }

exp2:
  if (!isdigit (c))
    goto bad;
  push_char (c);

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	CASE_SEPARATORS:
	  unget_char (c);
	  goto done;

	default:
	  goto done;
	}
    }

done:
  unget_char (c);
  push_char ('\0');

  m = convert_real (buffer, saved_string, length);
  free_saved ();

  return m;

bad:
  free_saved ();
  st_sprintf (message, "Bad floating point number for item %d", g.item_count);
  generate_error (ERROR_READ_VALUE, message);

  return 1;
}


/* read_complex()-- Reading a complex number is straightforward
 * because we can tell what it is right away. */

static void
read_complex (int length)
{
  char message[100];
  char c;

  if (parse_repeat ())
    return;

  c = next_char ();
  switch (c)
    {
    case '(':
      break;

    CASE_SEPARATORS:
      unget_char (c);
      eat_separator ();
      return;

    default:
      goto bad_complex;
    }

  eat_spaces ();
  if (parse_real (value, length))
    return;

  eat_spaces ();
  if (next_char () != ',')
    goto bad_complex;

  eat_spaces ();
  if (parse_real (value + length, length))
    return;

  eat_spaces ();
  if (next_char () != ')')
    goto bad_complex;

  c = next_char ();
  if (!is_separator (c))
    goto bad_complex;

  unget_char (c);
  eat_separator ();

  free_saved ();
  saved_type = BT_COMPLEX;
  return;

bad_complex:
  st_sprintf (message, "Bad complex value in item %d of list input",
	      g.item_count);

  generate_error (ERROR_READ_VALUE, message);
}


/* read_real()-- Parse a real number with a possible repeat count. */

static void
read_real (int length)
{
  char c, message[100];
  int seen_dp;

  seen_dp = 0;

  c = next_char ();
  switch (c)
    {
    CASE_DIGITS:
      push_char (c);
      break;

    case '.':
      push_char (c);
      seen_dp = 1;
      break;

    case '+':
    case '-':
      goto got_sign;

    CASE_SEPARATORS:
      unget_char (c);		/* Single null */
      eat_separator ();
      return;

    default:
      goto bad_real;
    }

  /* Get the digit string that might be a repeat count */

  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	case '.':
          if (seen_dp)
            goto bad_real;

	  seen_dp = 1;
	  push_char (c);
	  goto real_loop;

	case 'E':
	case 'e':
	case 'D':
	case 'd':
	  goto exp1;

	case '+':
	case '-':
	  push_char ('e');
	  push_char (c);
	  c = next_char ();
	  goto exp2;

	case '*':
	  push_char ('\0');
	  goto got_repeat;

	CASE_SEPARATORS:
          if (c != '\n')
            unget_char (c);        /* Real number that is just a digit-string */
	  goto done;

	default:
	  goto bad_real;
	}
    }

got_repeat:
  if (convert_integer (-1, 0))
    return;

/* Now get the number itself */

  c = next_char ();
  if (is_separator (c))
    {				/* Repeated null value */
      unget_char (c);
      eat_separator ();
      return;
    }

  if (c != '-' && c != '+')
    push_char ('+');
  else
    {
    got_sign:
      push_char (c);
      c = next_char ();
    }

  if (!isdigit (c) && c != '.')
    goto bad_real;

  if (c == '.')
    {
      if (seen_dp)
        goto bad_real;
      else
        seen_dp = 1;
    }

  push_char (c);

real_loop:
  for (;;)
    {
      c = next_char ();
      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	CASE_SEPARATORS:
	  goto done;

	case '.':
	  if (seen_dp)
	    goto bad_real;

	  seen_dp = 1;
	  push_char (c);
	  break;

	case 'E':
	case 'e':
	case 'D':
	case 'd':
	  goto exp1;

	case '+':
	case '-':
	  push_char ('e');
	  push_char (c);
	  c = next_char ();
	  goto exp2;

	default:
	  goto bad_real;
	}
    }

exp1:
  push_char ('e');

  c = next_char ();
  if (c != '+' && c != '-')
    push_char ('+');
  else
    {
      push_char (c);
      c = next_char ();
    }

exp2:
  if (!isdigit (c))
    goto bad_real;
  push_char (c);

  for (;;)
    {
      c = next_char ();

      switch (c)
	{
	CASE_DIGITS:
	  push_char (c);
	  break;

	CASE_SEPARATORS:
	  unget_char (c);
	  eat_separator ();
	  goto done;

	default:
	  goto bad_real;
	}
    }

done:
  push_char ('\0');
  if (convert_real (value, saved_string, length))
    return;

  free_saved ();
  saved_type = BT_REAL;
  return;

bad_real:
  st_sprintf (message, "Bad real number in item %d of list input",
	      g.item_count);

  generate_error (ERROR_READ_VALUE, message);
}


/* check_type()-- Check the current type against the saved type to
 * make sure they are compatible.  Returns nonzero if incompatible.  */

static int
check_type (bt type, int len)
{
  char message[100];

  if (saved_type != BT_NULL && saved_type != type)
    {
      st_sprintf (message, "Read type %s where %s was expected for item %d",
		  type_name (saved_type), type_name (type), g.item_count);

      generate_error (ERROR_READ_VALUE, message);
      return 1;
    }

  if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
    return 0;

  if (saved_length != len)
    {
      st_sprintf (message,
		  "Read kind %d %s where kind %d is required for item %d",
		  saved_length, type_name (saved_type), len, g.item_count);
      generate_error (ERROR_READ_VALUE, message);
      return 1;
    }

  return 0;
}


/* list_formatted_read()-- Top level data transfer subroutine for list
 * reads.  Because we have to deal with repeat counts, the data item
 * is always saved after reading, usually in the value[] array.  If a
 * repeat count is greater than one, we copy the data item multiple
 * times. */

void
list_formatted_read (bt type, void *p, int len)
{
  char c;
  int m;

  namelist_mode = 0;

  if (setjmp (g.eof_jump))
    {
      generate_error (ERROR_END, NULL);
      return;
    }

  if (g.first_item)
    {
      g.first_item = 0;
      input_complete = 0;
      repeat_count = 1;
      at_eol = 0;

      c = eat_spaces ();
      if (is_separator (c))
	{			/* Found a null value */
	  eat_separator ();
	  repeat_count = 0;
	  if (at_eol)
            finish_separator ();
          else
            return;
	}

    }
  else
    {
      if (input_complete)
	return;

      if (repeat_count > 0)
	{
	  if (check_type (type, len))
	    return;
	  goto set_value;
	}

      if (at_eol)
        finish_separator ();
      else
        eat_spaces ();

      saved_type = BT_NULL;
      repeat_count = 1;
    }


  switch (type)
    {
    case BT_INTEGER:
      read_integer (len);
      break;
    case BT_LOGICAL:
      read_logical (len);
      break;
    case BT_CHARACTER:
      read_character (len);
      break;
    case BT_REAL:
      read_real (len);
      break;
    case BT_COMPLEX:
      read_complex (len);
      break;
    default:
      internal_error ("Bad type for list read");
    }

  if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
    saved_length = len;

  if (ioparm.library_return != LIBRARY_OK)
    return;

set_value:
  switch (saved_type)
    {
    case BT_COMPLEX:
      len = 2 * len;
      /* Fall through */

    case BT_INTEGER:
    case BT_REAL:
    case BT_LOGICAL:
      memcpy (p, value, len);
      break;

    case BT_CHARACTER:
      if (saved_string)
       { 
          m = (len < saved_used) ? len : saved_used;
          memcpy (p, saved_string, m);
       }
      else    /* just delimiters encountered, nothing to copy but SPACE */
        m = 0;

      if (m < len)
	memset (((char *) p) + m, ' ', len - m);
      break;

    case BT_NULL:
      break;
    }

  if (--repeat_count <= 0)
    free_saved ();
}

void
init_at_eol()
{
  at_eol = 0;
}

/* finish_list_read()-- Finish a list read */

void
finish_list_read (void)
{
  char c;

  free_saved ();

  if (at_eol)
    {
      at_eol = 0;
      return;
    }


  do
    {
      c = next_char ();
    }
  while (c != '\n');
}

static namelist_info *
find_nml_node (char * var_name)
{
   namelist_info * t = ionml;
   while (t != NULL)
     {
       if (strcmp (var_name,t->var_name) == 0)
         {
           t->value_acquired = 1;
           return t;
         }
       t = t->next;
     }
  return NULL;
}

static void
match_namelist_name (char *name, int len)
{
  int name_len;
  char c;
  char * namelist_name = name;

  name_len = 0;
  /* Match the name of the namelist */

  if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
    {
    wrong_name:
      generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
      return;
    }

  while (name_len < len)
    {
      c = next_char ();
      if (tolower (c) != tolower (namelist_name[name_len++]))
        goto wrong_name;
    }
}


/********************************************************************
      Namelist reads
********************************************************************/

/* namelist_read()-- Process a namelist read.  This subroutine
 * initializes things, positions to the first element and */

void
namelist_read (void)
{
  char c;
  int name_matched, next_name ;
  namelist_info * nl;
  int len, m;
  void * p;

  namelist_mode = 1;

  if (setjmp (g.eof_jump))
    {
      generate_error (ERROR_END, NULL);
      return;
    }

restart:
  c = next_char ();
  switch (c)
    {
    case ' ':
      goto restart;
    case '!':
      do
        c = next_char ();
      while (c != '\n');

      goto restart;

    case '&':
      break;

    default:
      generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
      return;
    }

  /* Match the name of the namelist */
  match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);

  /* Ready to read namelist elements */
  while (!input_complete)
    {
      c = next_char ();
      switch (c)
        {
        case '/':
          input_complete = 1;
          next_record (0);
          break;
        case '&':
          match_namelist_name("end",3);
          return;
        case '\\':
          return;
        case ' ':
        case '\n':
        case '\t':
          break;
        case ',':
          next_name = 1;
          break;

        case '=':
          name_matched = 1;
          nl = find_nml_node (saved_string);
          if (nl == NULL)
            internal_error ("Can not match a namelist variable");
          free_saved();

          len = nl->len;
          p = nl->mem_pos;
          switch (nl->type)
            {
            case BT_INTEGER:
              read_integer (len);
              break;
            case BT_LOGICAL:
              read_logical (len);
              break;
            case BT_CHARACTER:
              read_character (len);
              break;
            case BT_REAL:
              read_real (len);
              break;
            case BT_COMPLEX:
              read_complex (len);
              break;
            default:
              internal_error ("Bad type for namelist read");
            }

           switch (saved_type)
            {
            case BT_COMPLEX:
              len = 2 * len;
              /* Fall through */

            case BT_INTEGER:
            case BT_REAL:
            case BT_LOGICAL:
              memcpy (p, value, len);
              break;

            case BT_CHARACTER:
              m = (len < saved_used) ? len : saved_used;
              memcpy (p, saved_string, m);

              if (m < len)
                memset (((char *) p) + m, ' ', len - m);
              break;

            case BT_NULL:
              break;
            }

          break;

        default :
          push_char(tolower(c));
          break;
        }
   }
}