/* libsizzle/read.c - reader module
 
  Copyright (C) 1999, 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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.
  
  This software 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 this package; see the file COPYING.  If not, write to the
  Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <errno.h>

/* Not prototyped in math.h on Linux :-( */
double rint (double);

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "node.h"
#include "vector.h"
#if ENABLE_UVECTOR
#include "uvector.h"
#include "uvector64.h"
#endif /* ENABLE_UVECTOR */
#include "port.h"
#include "fdport.h"
#include "hashtab.h"
#include "read.h"
#include "eval.h"

/* The following two macros can only be used in a context where `port'
   is a file descriptor port (fdport), and `result' is wither of type
   `zzz_scm_t *' (fdgetcr) or `zzz_scm_t' (fdgetc).  Their use in
   critical loops can speed up reading from files considerably.  

   *Use with care* */

#if 1
#define fdgetcr(VAR)						\
  do {								\
	if ((err = zzz_port_getc (port, &VAR, &result)) !=	\
	    RESULT_SUCCESS)					\
	  return EOF;						\
  } while (0)

#define fdgetc(VAR)						\
  do {								\
	if ((err = zzz_port_getc (port, &VAR, result)) !=	\
	    RESULT_SUCCESS)					\
	  return EOF;						\
  } while (0)

#else

#define fdgetcr(VAR)						\
  do {								\
    if (fdport_rptr (port) < fdport_rend (port))		\
      {								\
	VAR = *fdport_rptr (port);				\
	fdport_rptr (port)++;					\
      }								\
    else							\
      {								\
	if ((err = zzz_port_getc (port, &VAR, &result)) !=	\
	    RESULT_SUCCESS)					\
	  return EOF;						\
      }								\
  } while (0)

#define fdgetc(VAR)						\
  do {								\
    if (fdport_rptr (port) < fdport_rend (port))		\
      {								\
	VAR = *fdport_rptr (port);				\
	fdport_rptr (port)++;					\
      }								\
    else							\
      {								\
	if ((err = zzz_port_getc (port, &VAR, result)) !=	\
	    RESULT_SUCCESS)					\
	  return EOF;						\
      }								\
  } while (0)

#endif

static zzz_scm_t
get_port_position (zzz_scm_t port)
{
  if (port_filename (port))
    {
      return zzz_make_list (port_filename (port),
			    zzz_make_integer (port_line_number (port) + 1),
			    zzz_make_integer (port_col_number (port)),
			    NULL);
    }
/*    else if (zzz_state.current_input_file_name) */
/*      { */
/*        return zzz_make_list (zzz_state.current_input_file_name, */
/*  			    zzz_make_integer (port_line_number (port) + 1), */
/*  			    zzz_make_integer (port_col_number (port)), */
/*  			    NULL); */
/*      } */
  else
    return zzz_make_list (zzz_make_ro_string ("stdin", 5),
			  zzz_make_integer (port_line_number (port) + 1),
			  zzz_make_integer (port_col_number (port)),
			  NULL);
}

static zzz_scm_t
get_position (int line, int col)
{
/*    if (zzz_state.current_input_file_name) */
/*      { */
/*        return zzz_make_list (zzz_state.current_input_file_name, */
/*  			    zzz_make_integer (line + 1), */
/*  			    zzz_make_integer (col + 1), */
/*  			    NULL); */
/*      } */
/*    else */
    return zzz_make_list (zzz_make_integer (line + 1),
			  zzz_make_integer (col + 1),
			  NULL);
}

result_t
zzz_parse_scheme_number (char * s, unsigned len, int default_radix,
			 zzz_scm_t *result)
{
  int inexact = 0;
  int exact = 0;
  int radix = 0;
  char * p = s;
  char * endprefix;
  int ival = 0;
  double dval;
  int sign = 0;
  char buf[64];

  while (p < s + len && *p == '#')
    {
      p++;
      if (p >= s + len)
	return RESULT_ERROR;
      switch (*p)
	{
	case 'e':
	  if (inexact)
	    return RESULT_ERROR;
	  exact = 1;
	  break;
	case 'i':
	  if (exact)
	    return RESULT_ERROR;
	  inexact = 1;
	  break;
	case 'b':
	  if (radix)
	    return RESULT_ERROR;
	  radix = 2;
	  break;
	case 'o':
	  if (radix)
	    return RESULT_ERROR;
	  radix = 8;
	  break;
	case 'd':
	  if (radix)
	    return RESULT_ERROR;
	  radix = 10;
	  break;
	case 'x':
	  if (radix)
	    return RESULT_ERROR;
	  radix = 16;
	  break;
	default:
	  return RESULT_ERROR;
	}
      p++;
    }
  endprefix = p;
  if (!radix)
    radix = default_radix;
  if (p < s + len && *p == '-')
    {
      sign = 1;
      p++;
    }
  if (p >= s + len)
    return RESULT_ERROR;
  while (p < s + len)
    {
      switch (*p)
	{
	case '#':
	  break;
	case '0': case '1': case '2': case '3': case '4':
	case '5': case '6': case '7': case '8': case '9':
	  if (*p - '0' >= radix)
	    return RESULT_ERROR;
	  ival = ival * radix + (*p - '0');
	  break;
	case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
	  if (radix != 16)
	    return RESULT_ERROR;
	  ival = ival * radix + ((*p - 'a') + 10);
	  break;
	case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
	  if (radix != 16)
	    return RESULT_ERROR;
	  ival = ival * radix + ((*p - 'A') + 10);
	  break;
	case '.':
	  if (radix != 10)
	    return RESULT_ERROR;
	  len -= (endprefix - p);
	  if (len >= sizeof (buf))
	    return RESULT_ERROR;
	  memcpy (buf, endprefix, len);
	  buf[len] = '\0';
	  dval = strtod (buf, &p);
	  /* FIXME:mgrabmue: This hack (due to ela) allows parsing on
             platforms where strtod() only parses localized floating
             point representations, like our Itanium test
             platform. Maybe set the correct locale for category C?
             Gotta learn more about locales... */
	  if (*p == '.')
	    {
	      *p = ',';
	      dval = strtod (buf, &p);
	    }
	  if (*p)
	    return RESULT_ERROR;
	  if (exact)
	    {
	      if (rint (dval) != dval)
		return RESULT_ERROR;
	      *result = zzz_make_integer ((long) dval);
	    }
	  else
	    *result = zzz_make_float (dval);
	  return RESULT_SUCCESS;
	default:
	  return RESULT_ERROR;	
	}
      p++;
    }
  if (sign)
    ival = -ival;
  if (inexact)
    *result = zzz_make_float ((double) ival);
  else
    *result = zzz_make_integer (ival);
  return RESULT_SUCCESS;
}

static result_t read_cell (zzz_scm_t port, zzz_scm_t * result);
static result_t read_cell_internal (int c, zzz_scm_t port, zzz_scm_t * result);

/* Initialize the global string buffer variables.  Needs to be called
  before the function add_string_buf() is called are any of the string
  buffer variables are used.  */
static void
init_string_buf (void)
{
  if (!zzz_state.string_buf)
    {
      zzz_state.string_buf_size = 128;
      zzz_state.string_buf = zzz_malloc (zzz_state.string_buf_size);
    }
  zzz_state.string_buf_len = 0;
}

/* Add the character C to the global string buffer.  */
static void
add_string_buf (int c)
{
  if (zzz_state.string_buf_len >= zzz_state.string_buf_size)
    {
      int size = zzz_state.string_buf_size * 2;
      zzz_state.string_buf = zzz_realloc (zzz_state.string_buf, size,
					  zzz_state.string_buf_size);
      zzz_state.string_buf_size = size;
    }
  zzz_state.string_buf[zzz_state.string_buf_len++] = c;
}

/* Skip all input while whitespace characters are read.  */
static int
skip_whitespace (int c, zzz_scm_t port)
{
  zzz_scm_t result;
  result_t err;

  if (fdport_p (port))
    {
      while (c != EOF && (c == ' ' || c == '\n' || c == '\r' || c == '\t' ||
			  c == '\f' || c == ';' ))
	{
	  if (c == ';')
	    {
	      fdgetcr (c);
	      while (c != EOF && c != '\n')
		{
		  fdgetcr (c);
		}
	    }
	  else
	    {
	      fdgetcr (c);
	    }
	}
    }
  else
    {
      while (c != EOF && (c == ' ' || c == '\n' || c == '\r' || c == '\t' ||
			  c == '\f' || c == ';' ))
	{
	  if (c == ';')
	    {
	      if ((err = zzz_port_getc (port, &c, &result)) != RESULT_SUCCESS)
		return EOF;
	      while (c != EOF && c != '\n')
		{
		  if ((err = zzz_port_getc (port, &c, &result)) != RESULT_SUCCESS)
		    return EOF;
		}
	    }
	  else
	    {
	      if ((err = zzz_port_getc (port, &c, &result)) != RESULT_SUCCESS)
		return EOF;
	    }
	}
    }
  return c;
}

/* Read a string constant from the stream IN_FILE. C is the character
  that started the constant and is discarded.  */
static result_t
read_string (int c, zzz_scm_t port, zzz_scm_t * result)
{
  result_t err;

  init_string_buf ();
  
  if (fdport_p (port))
    fdgetc(c);
  else
    {
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
    }
  while (c != EOF && c != '"')
    {
      if (c == '\\')
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	  switch (c)
	    {
	    case '0':
	      c = '\0';
	      break;
	    case 'n':
	      c = '\n';
	      break;
	    case 'r':
	      c = '\r';
	      break;
	    case 't':
	      c = '\t';
	      break;
	    case 'f':
	      c = '\f';
	      break;
	    case 'b':
	      c = '\b';
	      break;
	    case 'a':
	      c = '\a';
	      break;
	    case 'v':
	      c = '\v';
	      break;
	    default:
	      break;
	    }
	}
      add_string_buf (c);
      if (fdport_p (port))
	fdgetc(c);
      else
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	}
    }
  if (c == EOF)
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("unterminated string constant"), -1));
      zzz_set_exception_reference (*result, get_port_position (port));
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_ro_string (zzz_state.string_buf,
				zzz_state.string_buf_len);
  return RESULT_SUCCESS;
}

/* Parse a symbol or, if it fits syntactically, an integer or floating
  point constant.  The symbol to be parsed is taken from the global
  string buffer and a cell containing the symbol or constant is
  returned.  */
static result_t
parse_symbol_or_number (zzz_scm_t * result)
{
  if (zzz_parse_scheme_number (zzz_state.string_buf,
			       zzz_state.string_buf_len - 1, 10,
			       result) != RESULT_SUCCESS)
    {
      if (zzz_state.string_buf_len > 1 &&
	  zzz_state.string_buf[0] == ':')
	*result = zzz_make_keyword (zzz_state.string_buf + 1,
				    zzz_state.string_buf_len - 2);
      else if (zzz_state.string_buf_len > 2 &&
	       zzz_state.string_buf[0] == '#' &&
	       zzz_state.string_buf[1] == ':')
	*result = zzz_make_keyword (zzz_state.string_buf + 2,
				    zzz_state.string_buf_len - 3);
      else
	*result = zzz_make_symbol (zzz_state.string_buf,
				   zzz_state.string_buf_len - 1);
    }
  return RESULT_SUCCESS;
}

/* Read a symbol or numerical constant from the stream IN_FILE. In C
  the first character of the symbol is passed. Return the cell for the
  parsed expression.  */
static result_t
read_symbol_or_number (int c, zzz_scm_t port, zzz_scm_t * result)
{
  result_t err;

  init_string_buf ();

  if (c == '\\')
    goto backslash;
  add_string_buf (c);
  if (fdport_p (port))
    fdgetc(c);
  else
    {
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
    }
  while (c != EOF)
    {
      if (c == '\\')
	{
	backslash:
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	  if (c == EOF)
	    {
	      *result = zzz_make_misc_error_exception
		(zzz_make_string (_("backslash followed by EOF in input"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	}
      else
	{
	  switch (c)
	    {
	    case '(':
	    case ')':
	    case '{':
	    case '}':
	    case '[':
	    case ']':
	    case ';':
	    case '"':
	    case ' ':
	    case '\n':
	    case '\r':
	    case '\t':
	    case '\f':
	      if ((err = zzz_port_ungetc (c, port, result)) != RESULT_SUCCESS)
		return err;
	      add_string_buf ('\0');
	      return parse_symbol_or_number (result);
	    }
	}
      add_string_buf (c);
      if (fdport_p (port))
	fdgetc(c);
      else
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	}
    }
  add_string_buf ('\0');
  return parse_symbol_or_number (result);
}

/* Read a list of sexps from file IN_FILE, getting the opening
  parentheses in C.  */
static result_t
read_list (int c, zzz_scm_t port, zzz_scm_t * result)
{
  result_t err;
  zzz_scm_t cell = NULL, ret_cell = NULL;
  zzz_scm_t * pp = &ret_cell;
  int line;
  int col;
  int closing = c == '(' ? ')' : ']';
  int source_remembered = 0;

  line = port_line_number (port);
  col = port_col_number (port);
  zzz_state.parentheses_nesting++;
  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    {
      zzz_state.parentheses_nesting--;
      return err;
    }
  c = skip_whitespace (c, port);
  while (c != EOF && c != closing)
    {
      err = read_cell_internal (c, port, &cell);
      if (err == RESULT_REPEAT)
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    {
	      zzz_state.parentheses_nesting--;
	      return err;
	    }
	  c = skip_whitespace (c, port);
	  continue;
	}
      if (err != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  *result = cell;
	  return err;
	}
      if (cell == zzz_dot_sym)
	{
	  if ((err = read_cell (port, &cell)) != RESULT_SUCCESS)
	    {
	      zzz_state.parentheses_nesting--;
	      *result = cell;
	      return err;
	    }
	  *pp = cell;
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    {
	      zzz_state.parentheses_nesting--;
	      return err;
	    }
	  c = skip_whitespace (c, port);
	  if (c != closing)
	    {
	      zzz_state.parentheses_nesting--;
	      *result = zzz_make_misc_error_exception
		(zzz_make_string (_("terminating parenthesis expected"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	  *result = ret_cell;
	  zzz_state.parentheses_nesting--;
	  return RESULT_SUCCESS;
	}
      else
	{
	  *pp = zzz_cons (cell, NULL);
	  if (zzz_state.remember_source_locations && !source_remembered)
	    {
	      source_remembered = 1;
	      zzz_hashq_set (zzz_state.source_locations, *pp,
			     zzz_make_n_list
			     (3,
			      port_filename (port),
			      zzz_make_integer (line + 1),
			      zzz_make_integer (col - 1)));
	    }
	  pp = cdr_addr (*pp);
	}
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  return err;
	}
      c = skip_whitespace (c, port);
    }
  if (c != closing)
    {
      zzz_state.parentheses_nesting--;
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("terminating parenthesis expected"), -1));
      zzz_set_exception_reference (*result, get_port_position (port));
      return RESULT_EXCEPTION;
    }
  *result = ret_cell;
  zzz_state.parentheses_nesting--;
  return RESULT_SUCCESS;
}

/* Read a hash literal from the input port PORT, receiving the
  starting hash mark in C.  */
static result_t
read_hash_table (int c, zzz_scm_t port, zzz_scm_t * result)
{
  zzz_scm_t key = NULL, arrow = NULL, value = NULL;
  zzz_scm_t keylist = NULL, valuelist = NULL, vec = NULL;
  int keycount;
  result_t err;

  zzz_state.parentheses_nesting++;
  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    {
      zzz_state.parentheses_nesting--;
      return err;
    }
  c = skip_whitespace (c, port);
  while (c != EOF && c != '}')
    {
      err = read_cell_internal (c, port, &key);
      if (err == RESULT_REPEAT)
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    {
	      zzz_state.parentheses_nesting--;
	      return err;
	    }
	  c = skip_whitespace (c, port);
	  continue;
	}
      if (err != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  *result = key;
	  return err;
	}
      keylist = zzz_cons (key, keylist);
      if ((err = read_cell (port, &value)) != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  *result = value;
	  return err;
	}
      if (value != zzz_arrow_sym)
	{
	  zzz_state.parentheses_nesting--;
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("`=>' in hash table literal expected"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;
	}
      value = NULL;
      if ((err = read_cell (port, &value)) != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  *result = value;
	  return err;
	}
      valuelist = zzz_cons (value, valuelist);
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  return err;
	}
      c = skip_whitespace (c, port);
    }
  if (c != '}')
    {
      zzz_state.parentheses_nesting--;
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("terminating `}' expected"), -1));
      zzz_set_exception_reference (*result, get_port_position (port));
      return RESULT_EXCEPTION;
    }
  keycount = 0;
  value = keylist;
  while (cons_p (value))
    {
      keycount++;
      key = cdr (value);
      while (cons_p (key))
	{
	  if (zzz_equal (car (value), car (key)))
	    {
	      zzz_state.parentheses_nesting--;
	      *result = zzz_make_misc_error_exception
		(zzz_make_string
		 (_("duplicate keys in hash table literal"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	  key = cdr (key);
	}
      value = cdr (value);
    }
  /* Try to guess a sane value for the hash table size.  Better idea,
     anyone?  Result value should be prime.  */
  if (keycount > 30)
    keycount = 71;
  else if (keycount > 20)
    keycount = 31;
  else if (keycount > 10)
    keycount = 17;
  else
    keycount = 11;
  vec = zzz_make_hashtable (keycount);
  while (cons_p (keylist))
    {
      zzz_object_t hash_val = zzz_hash_function (car (keylist)) %
	vector_len (vec);

      zzz_vector_put (vec, hash_val,
		      zzz_cons (zzz_cons (car (keylist), car (valuelist)),
				zzz_vector_get (vec, hash_val)));
      keylist = cdr (keylist);
      valuelist = cdr (valuelist);
    }
  *result = vec;
  zzz_state.parentheses_nesting--;
  return RESULT_SUCCESS;
}

/* Read a vector of sexps from file IN_FILE, getting the starting hash
  mark in C.  */
static result_t
read_vector (int c, zzz_scm_t port, zzz_scm_t * result)
{
  zzz_scm_t cell = NULL, list = NULL, vec = NULL;
  int x;
  result_t err;

  zzz_state.parentheses_nesting++;
  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    {
      zzz_state.parentheses_nesting--;
      return err;
    }
  c = skip_whitespace (c, port);
  x = 0;
  while (c != EOF && c != ')')
    {
      err = read_cell_internal (c, port, &cell);
      if (err == RESULT_REPEAT)
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    {
	      zzz_state.parentheses_nesting--;
	      return err;
	    }
	  c = skip_whitespace (c, port);
	  continue;
	}
      if (err != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  *result = cell;
	  return err;
	}
      list = zzz_cons (cell, list);
      x++;
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  return err;
	}
      c = skip_whitespace (c, port);
    }
  if (c != ')')
    {
      zzz_state.parentheses_nesting--;
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("terminating `)' expected"), -1));
      zzz_set_exception_reference (*result, get_port_position (port));
      return RESULT_EXCEPTION;
    }
  vec = zzz_make_ro_vector (x);
  cell = list;
  while (x-- > 0)
    {
      zzz_vector_put (vec, x, car (cell));
      cell = cdr (cell);
    }
  *result = vec;
  zzz_state.parentheses_nesting--;
  return RESULT_SUCCESS;
}

#if ENABLE_UVECTOR

#define UNIF_S8_VECTOR 1
#define UNIF_U8_VECTOR 2
#define UNIF_S16_VECTOR 3
#define UNIF_U16_VECTOR 4
#define UNIF_S32_VECTOR 5
#define UNIF_U32_VECTOR 6
#if HAVE_LONG_LONG
#define UNIF_S64_VECTOR 7
#define UNIF_U64_VECTOR 8
#endif /* HAVE_LONG_LONG */
#define UNIF_F32_VECTOR 9
#define UNIF_F64_VECTOR 10

/* Read a uniform numeric vector.  */
static result_t
read_uniform_vector (int tag, zzz_scm_t port, zzz_scm_t * result)
{
  zzz_scm_t cell = NULL, list = NULL, vec = NULL;
  int c, x;
  result_t err;

  zzz_state.parentheses_nesting++;
  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    {
      zzz_state.parentheses_nesting--;
      return err;
    }
  if (c != '(')
    {
      zzz_state.parentheses_nesting--;
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("`(' expected after uniform vector prefix"), -1));
      zzz_set_exception_reference (*result, get_port_position (port));
      return RESULT_EXCEPTION;
    }
  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    {
      zzz_state.parentheses_nesting--;
      return err;
    }
  c = skip_whitespace (c, port);
  x = 0;
  while (c != EOF && c != ')')
    {
      err = read_cell_internal (c, port, &cell);
      if (err == RESULT_REPEAT)
	{
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    {
	      zzz_state.parentheses_nesting--;
	      return err;
	    }
	  c = skip_whitespace (c, port);
	  continue;
	}
      if (err != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  *result = cell;
	  return err;
	}
      list = zzz_cons (cell, list);
      x++;
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	{
	  zzz_state.parentheses_nesting--;
	  return err;
	}
      c = skip_whitespace (c, port);
    }
  if (c != ')')
    {
      zzz_state.parentheses_nesting--;
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("terminating `)' expected"), -1));
      zzz_set_exception_reference (*result, get_port_position (port));
      return RESULT_EXCEPTION;
    }
  switch (tag)
    {
    case UNIF_S8_VECTOR:
      vec = zzz_make_ro_s8vector (x); break;
    case UNIF_U8_VECTOR:
      vec = zzz_make_ro_u8vector (x); break;
    case UNIF_S16_VECTOR:
      vec = zzz_make_ro_s16vector (x); break;
    case UNIF_U16_VECTOR:
      vec = zzz_make_ro_u16vector (x); break;
    case UNIF_S32_VECTOR:
      vec = zzz_make_ro_s32vector (x); break;
    case UNIF_U32_VECTOR:
      vec = zzz_make_ro_u32vector (x); break;
#if HAVE_LONG_LONG
    case UNIF_S64_VECTOR:
      vec = zzz_make_ro_s64vector (x); break;
    case UNIF_U64_VECTOR:
      vec = zzz_make_ro_u64vector (x); break;
#endif /* HAVE_LONG_LONG */
    case UNIF_F32_VECTOR:
      vec = zzz_make_ro_f32vector (x); break;
    case UNIF_F64_VECTOR:
      vec = zzz_make_ro_f64vector (x); break;
    default: 
      abort (); break;
    }
  cell = list;
  while (x-- > 0)
    {
      double f = 0.0;

      switch (tag)
	{
	case UNIF_S8_VECTOR:
	case UNIF_U8_VECTOR:
	case UNIF_S16_VECTOR:
	case UNIF_U16_VECTOR:
	case UNIF_S32_VECTOR:
	case UNIF_U32_VECTOR:
#if HAVE_LONG_LONG
	case UNIF_S64_VECTOR:
	case UNIF_U64_VECTOR:
#endif /* HAVE_LONG_LONG */
	  if (!integer_p (car (cell)))
	    {
	      zzz_state.parentheses_nesting--;
	      *result = zzz_make_misc_error_exception
		(zzz_make_string
		 (_("non-integer in integer uniform vector constant"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	  break;
	case UNIF_F32_VECTOR:
	case UNIF_F64_VECTOR:
	  if (!number_p (car (cell)))
	    {
	      zzz_state.parentheses_nesting--;
	      *result = zzz_make_misc_error_exception
		(zzz_make_string
		 (_("non-number in floating point uniform vector constant"),
		  -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	  if (integer_p (car (cell)))
	    f = (double) integer_val (car (cell));
	  else
	    f = float_val (car (cell));
	  break;
	default: 
	  abort (); break;
	}
      switch (tag)
	{
	case UNIF_S8_VECTOR:
	  {
	    signed char val = (signed char) integer_val (car (cell));
	    if (val != integer_val (car (cell)))
	      {
		zzz_state.parentheses_nesting--;
		*result = zzz_make_misc_error_exception
		  (zzz_make_string
		   (_("only signed 8-bit values allowed in s8 vector"), -1));
		return RESULT_EXCEPTION;
	      }
	    s8vector_val (vec)[x] = val; break;
	  }
	case UNIF_U8_VECTOR:
	  {
	    unsigned char val = (unsigned char) integer_val (car (cell));
	    if (val != integer_val (car (cell)))
	      {
		zzz_state.parentheses_nesting--;
		*result = zzz_make_misc_error_exception
		  (zzz_make_string
		   (_("only unsigned 8-bit values allowed in u8 vector"), -1));
		zzz_set_exception_reference (*result,
					     get_port_position (port));
		return RESULT_EXCEPTION;
	      }
	    u8vector_val (vec)[x] = val; break;
	  }
	case UNIF_S16_VECTOR:
	  {
	    signed short val = (signed short) integer_val (car (cell));
	    if (val != integer_val (car (cell)))
	      {
		zzz_state.parentheses_nesting--;
		*result = zzz_make_misc_error_exception
		  (zzz_make_string
		   (_("only signed 16-bit values allowed in s16 vector"), -1));
		zzz_set_exception_reference (*result,
					     get_port_position (port));
		return RESULT_EXCEPTION;
	      }
	    s16vector_val (vec)[x] = val; break;
	  }
	case UNIF_U16_VECTOR:
	  {
	    unsigned short val = (unsigned short) integer_val (car (cell));
	    if (val != integer_val (car (cell)))
	      {
		zzz_state.parentheses_nesting--;
		*result = zzz_make_misc_error_exception
		  (zzz_make_string
		   (_("only unsigned 16-bit values allowed in u16 vector"),
		    -1));
		zzz_set_exception_reference (*result,
					     get_port_position (port));
		return RESULT_EXCEPTION;
	      }
	    u16vector_val (vec)[x] = val; break;
	  }
	case UNIF_S32_VECTOR:
	  s32vector_val (vec)[x] = integer_val (car (cell)); break;
	case UNIF_U32_VECTOR:
	  u32vector_val (vec)[x] = integer_val (car (cell)); break;
#if HAVE_LONG_LONG
	case UNIF_S64_VECTOR:
	  s64vector_val (vec)[x] = integer_val (car (cell)); break;
	case UNIF_U64_VECTOR:
	  u64vector_val (vec)[x] = integer_val (car (cell)); break;
#endif /* HAVE_LONG_LONG */
	case UNIF_F32_VECTOR:
	  f32vector_val (vec)[x] = (float) f; break;
	case UNIF_F64_VECTOR:
	  f64vector_val (vec)[x] = f; break;
	default: 
	  abort (); break;
	}
      cell = cdr (cell);
    }
  *result = vec;
  zzz_state.parentheses_nesting--;
  return RESULT_SUCCESS;
}
#endif /* ENABLE_UVECTOR */

/* Read an sexp starting with a hashmark (#).  */
static result_t
read_hash (int c, zzz_scm_t port, zzz_scm_t * result)
{
  result_t err;

  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    return err;
  if (c == '(')
    return read_vector (c, port, result);
  else if (c == '{')
    return read_hash_table (c, port, result);
  else if (c == '!')
    {
      int lastc;
      if ((err = zzz_port_getc (port, &lastc, result)) != RESULT_SUCCESS)
	return err;
      if (lastc == EOF)
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("end of file in block comment"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;
	}
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
      if (c == EOF)
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("end of file in block comment"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;
	}
      while (lastc != '!' || c != '#')
	{
	  lastc = c;
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	  if (c == EOF)
	    {
	      *result = zzz_make_misc_error_exception
		(zzz_make_string (_("end of file in block comment"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	}
      return RESULT_REPEAT;
    }
  else if (c == '\\')
    {
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
      if (c == EOF)
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string
	     (_("end of file encountered when reading character constant "),
	      -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;
	}
      if ((c < 'a' || c > 'z') &&
	  (c < 'A' || c > 'Z'))
	{
	  *result = zzz_make_char (c);
	  return RESULT_SUCCESS;
	}
      init_string_buf ();
      
      add_string_buf (c);
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
      while (c != EOF && ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
	{
	  add_string_buf (c);
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	}
      if ((err = zzz_port_ungetc (c, port, result)) != RESULT_SUCCESS)
	return err;
      if (zzz_state.string_buf_len == 1)
	{
	  *result = zzz_make_char (zzz_state.string_buf[0]);
	}
      else
	{
	  add_string_buf ('\0');
	  if (!strcmp (zzz_state.string_buf, "newline"))
	    *result = zzz_make_char ('\n');
	  else if (!strcmp (zzz_state.string_buf, "space"))
	    *result = zzz_make_char (' ');
	  else if (!strcmp (zzz_state.string_buf, "return"))
	    *result = zzz_make_char ('\r');
	  else if (!strcmp (zzz_state.string_buf, "tab"))
	    *result = zzz_make_char ('\t');
	  else if (!strcmp (zzz_state.string_buf, "bell"))
	    *result = zzz_make_char ('\a');
	  else
	    {
	      *result = zzz_make_misc_error_exception
		(zzz_make_string (_("invalid character constant"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	}
      return RESULT_SUCCESS;
    }
  else if (c == 'e' || c == 'i' || c == 'd' || c == 'o' ||
	   c == 'x' || c == 'b')
    {
      if ((err = zzz_port_ungetc (c, port, result)) != RESULT_SUCCESS)
	return err;
      return read_symbol_or_number ('#', port, result);
    }
  else if (c == ':')
    {
      if ((err = zzz_port_ungetc (c, port, result)) != RESULT_SUCCESS)
	return err;
      return read_symbol_or_number ('#', port, result);
    }
  else
    {
      init_string_buf ();
      
      add_string_buf (c);
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
      while (c != EOF)
	{
	  switch (c)
	    {
	    case '(':
	    case ')':
	    case '[':
	    case ']':
	    case '{':
	    case '}':
	    case ';':
	    case '"':
	    case ' ':
	    case '\n':
	    case '\r':
	    case '\t':
	    case '\f':
	      if ((err = zzz_port_ungetc (c, port, result)) != RESULT_SUCCESS)
		return err;
	    check_label:
	      add_string_buf ('\0');
	      if (!strcmp (zzz_state.string_buf, "t"))
		*result = zzz_make_bool (1);
	      else if (!strcmp (zzz_state.string_buf, "f"))
		*result = zzz_make_bool (0);
#if ENABLE_UVECTOR
	      else if (!strcmp (zzz_state.string_buf, "s8"))
		return read_uniform_vector (UNIF_S8_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "u8"))
		return read_uniform_vector (UNIF_U8_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "s16"))
		return read_uniform_vector (UNIF_S16_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "u16"))
		return read_uniform_vector (UNIF_U16_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "s32"))
		return read_uniform_vector (UNIF_S32_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "u32"))
		return read_uniform_vector (UNIF_U32_VECTOR, port, result);
#if HAVE_LONG_LONG
	      else if (!strcmp (zzz_state.string_buf, "s64"))
		return read_uniform_vector (UNIF_S64_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "u64"))
		return read_uniform_vector (UNIF_U64_VECTOR, port, result);
#endif /* HAVE_LONG_LONG */
	      else if (!strcmp (zzz_state.string_buf, "f32"))
		return read_uniform_vector (UNIF_F32_VECTOR, port, result);
	      else if (!strcmp (zzz_state.string_buf, "f64"))
		return read_uniform_vector (UNIF_F64_VECTOR, port, result);
#endif /* ENABLE_UVECTOR */
	      else
		{
		  *result = zzz_make_misc_error_exception
		    (zzz_cons
		     (zzz_make_string (_("Invalid hash sexp: "), -1),
		      zzz_cons
		      (zzz_make_string (zzz_state.string_buf, -1), NULL)));
		  zzz_set_exception_reference (*result,
					       get_port_position (port));
		  return RESULT_EXCEPTION;
		}
	      return RESULT_SUCCESS;
	    }
	  add_string_buf (c);
	  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	    return err;
	}
      goto check_label;
      abort ();			/* Should never get here. */
    }  
  abort ();			/* Should never get here. */
  return RESULT_SUCCESS;;
}

/* Read an sexp from port PORT, getting the first character from the
  file in C.  Note that this function may return RESULT_REPEAT when a
  comment was read.  In this case, the caller has to call it again,
  with a fresh value for argument C.  */
static result_t 
read_cell_internal (int c, zzz_scm_t port, zzz_scm_t * result)
{
  result_t err;

  for (;;)
    {
      c = skip_whitespace (c, port);
      switch (c)
	{
	case EOF:
	  *result = zzz_eof_object;
	  return RESULT_SUCCESS;

	case '"':
	  return read_string (c, port, result);
	  
	case '(':
	  return read_list (c, port, result);
	  
	case '[':
	  if (zzz_state.support_mzscheme_brackets)
	    return read_list (c, port, result);
	  else
	    {
	      *result = zzz_make_misc_error_exception
		(zzz_make_string (_("unexpected `[' in input"), -1));
	      zzz_set_exception_reference (*result, get_port_position (port));
	      return RESULT_EXCEPTION;
	    }
	  
	case '#':
	  return read_hash (c, port, result);

	case ')':
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("unexpected `)' in input"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;

	case ']':
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("unexpected `]' in input"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;

	case '{':
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("unexpected `{' in input"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;

	case '}':
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("unexpected `}' in input"), -1));
	  zzz_set_exception_reference (*result, get_port_position (port));
	  return RESULT_EXCEPTION;

	case '\'':
	  {
	    zzz_scm_t cell = NULL, co = NULL;

	    if ((err = read_cell (port, &cell)) != RESULT_SUCCESS)
	      {
		*result = cell;
		return err;
	      }
	    co = zzz_cons (cell, NULL);
	    *result = zzz_cons (zzz_quote_sym, co);

	    return RESULT_SUCCESS;
	  }
	  break;

	case '`':
	  {
	    zzz_scm_t cell = NULL, co = NULL;

	    if ((err = read_cell (port, &cell)) != RESULT_SUCCESS)
	      {
		*result = cell;
		return err;
	      }
	    co = zzz_cons (cell, NULL);
	    *result = zzz_cons (zzz_quasiquote_sym, co);

	    return RESULT_SUCCESS;
	  }
	  break;

	case ',':
	  {
	    zzz_scm_t cell = NULL, co = NULL;
	    zzz_scm_t sym = zzz_unquote_sym;

	    if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	      return err;
	    if (c == '@')
	      sym = zzz_unquote_splicing_sym;
	    else
	      {
		if ((err = zzz_port_ungetc (c, port, result)) !=
		    RESULT_SUCCESS)
		  return err;
	      }
	    if ((err = read_cell (port, &cell)) != RESULT_SUCCESS)
	      {
		*result = cell;
		return err;
	      }
	    co = zzz_cons (cell, NULL);
	    *result = zzz_cons (sym, co);

	    return RESULT_SUCCESS;
	  }
	  break;

	default:
	  return read_symbol_or_number (c, port, result);
	}
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
    }
  abort ();			/* Should never get here. */
  return RESULT_ERROR;
}

/* Read an sexp from port PORT, which must have been opened for
  reading.  */
static result_t 
read_cell (zzz_scm_t port, zzz_scm_t * result)
{
  result_t err;
  int c;

  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    return err;
  err = read_cell_internal (c, port, result);
  while (err == RESULT_REPEAT)
    {
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
      err = read_cell_internal (c, port, result);
    }
  return err;
}

/* Read an sexp from port PORT, which must have been opened for
  reading.  */
result_t 
zzz_read_cell (zzz_scm_t port, zzz_scm_t * result)
{
  result_t err, err2;
  zzz_scm_t res;
  int c;

  if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
    return err;
  c = skip_whitespace (c, port);
  err = read_cell_internal (c, port, result);
  while (err == RESULT_REPEAT)
    {
      if ((err = zzz_port_getc (port, &c, result)) != RESULT_SUCCESS)
	return err;
      c = skip_whitespace (c, port);
      err = read_cell_internal (c, port, result);
    }
  /* FIXME: This is here to eat all whitespace after reading an
     expression. It is not very fast, nor is it beatiful.  Think up
     better solution.  */
  do 
    {
      if ((err2 = zzz_port_char_ready_p (port, &c, &res)) != RESULT_SUCCESS)
	{
	  *result = res;
	  return err2;
	}
      if (c)
	{
	  if ((err2 = zzz_port_getc (port, &c, &res)) != RESULT_SUCCESS)
	    {
	      *result = res;
	      return err2;
	    }
	  if (c != '\n' && c != '\r' && c != ' ' && c != '\t')
	    {
	      if ((err2 = zzz_port_ungetc (c, port, &res)) != RESULT_SUCCESS)
		{
		  *result = res;
		  return err2;
		}
	    }
	}
    }
  while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
  return err;
}

zzz_scm_t 
zzz_get_source_location (zzz_scm_t pair)
{
  zzz_scm_t loc = zzz_hashq_ref (zzz_state.source_locations, pair,
				 zzz_false_value);
  return loc;
}

void
zzz_init_reader (void)
{
}

/* Free all memory allocated by the reader module.  */
void
zzz_finalize_reader (void)
{
}
