/* A Scheme reader compiler for Guile.

   Copyright (C) 2008, 2012, 2016, 2020 Ludovic Courtès <ludo@gnu.org>

   This program 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 3 of the License, or
   (at your option) any later version.

   This program 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 program; if not, write to the Free Software
   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA  */

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

#include <libguile.h>
#include <compat.h>
#include <string.h>
#include <stdio.h>

extern void scm_guile_reader_unused (void);

void
scm_guile_reader_unused ()
{
  /* Just to make sure we don't produce an empty object file.  */
}

#if defined HAVE_SCM_GET_BYTE_OR_EOF && !defined HAVE_SCM_UNGET_BYTE

/* Guile 2.0.[0-5] leaves `scm_unget_byte' internal.  */

void
scm_unget_byte (int c, SCM port)
#define FUNC_NAME "scm_unget_byte"
{
  scm_t_port *pt = SCM_PORT (port);

  if (pt->read_buf == pt->putback_buf)
    /* already using the put-back buffer.  */
    {
      /* enlarge putback_buf if necessary.  */
      if (pt->read_end == pt->read_buf + pt->read_buf_size
	  && pt->read_buf == pt->read_pos)
	{
	  size_t new_size = pt->read_buf_size * 2;
	  unsigned char *tmp = (unsigned char *)
	    scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
			    "putback buffer");

	  pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
	  pt->read_end = pt->read_buf + pt->read_buf_size;
	  pt->read_buf_size = pt->putback_buf_size = new_size;
	}

      /* shift any existing bytes to buffer + 1.  */
      if (pt->read_pos == pt->read_end)
	pt->read_end = pt->read_buf + 1;
      else if (pt->read_pos != pt->read_buf + 1)
	{
	  int count = pt->read_end - pt->read_pos;

	  memmove (pt->read_buf + 1, pt->read_pos, count);
	  pt->read_end = pt->read_buf + 1 + count;
	}

      pt->read_pos = pt->read_buf;
    }
  else
    /* switch to the put-back buffer.  */
    {
      if (pt->putback_buf == NULL)
	{
	  pt->putback_buf
	    = (unsigned char *) scm_gc_malloc_pointerless
	    (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer");
	  pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
	}

      pt->saved_read_buf = pt->read_buf;
      pt->saved_read_pos = pt->read_pos;
      pt->saved_read_end = pt->read_end;
      pt->saved_read_buf_size = pt->read_buf_size;

      pt->read_pos = pt->read_buf = pt->putback_buf;
      pt->read_end = pt->read_buf + 1;
      pt->read_buf_size = pt->putback_buf_size;
    }

  *pt->read_buf = c;

  if (pt->rw_random)
    pt->rw_active = SCM_PORT_READ;
}
#undef FUNC_NAME

#endif

#ifndef HAVE_SCM_I_INPUT_ERROR

/* Definition copied from Guile 1.8.5.  */

void
scm_i_input_error (char const *function,
		   SCM port, const char *message, SCM arg)
{
  SCM fn = (scm_is_string (scm_port_filename (port))
	    ? scm_port_filename (port)
	    : scm_from_locale_string ("#<unknown port>"));

  SCM string_port = scm_open_output_string ();
  SCM string = SCM_EOL;
  scm_simple_format (string_port,
		     scm_from_locale_string ("~A:~S:~S: ~A"),
		     scm_list_4 (fn,
				 scm_port_line (port),
				 scm_port_column (port),
				 scm_from_locale_string (message)));

  string = scm_get_output_string (string_port);
  scm_close_output_port (string_port);
  scm_error_scm (scm_from_locale_symbol ("read-error"),
		 function? scm_from_locale_string (function) : SCM_BOOL_F,
		 string,
		 arg,
		 SCM_BOOL_F);
}

#endif /* HAVE_SCM_I_INPUT_ERROR */

#ifndef HAVE_SCM_GET_BYTE_OR_EOF

/* Guile 2.0's `scm_get_byte_or_eof' doesn't update PORT's position,
   whereas `scm_getc' in 1.8 and 2.0 does.  */
int
scm_get_byte_or_eof (SCM port)
{
  int c;
  long line;
  int col;

  line = SCM_LINUM (port);
  col = SCM_COL (port);

  c = scm_getc (port);

  SCM_LINUM (port) = line;
  SCM_COL (port) = col;

  return c;
}

/* Likewise.  */
void
scm_unget_byte (int c, SCM port)
{
  long line;
  int col;

  line = SCM_LINUM (port);
  col = SCM_COL (port);

  scm_ungetc (c, port);

  SCM_LINUM (port) = line;
  SCM_COL (port) = col;
}

#endif /* !HAVE_SCM_GET_BYTE_OR_EOF */

#ifndef HAVE_SCM_FROM_UTF32_STRINGN

/* On Guile 1.8, return a plain 8-bit string.  */
SCM
scm_from_utf32_stringn (const scm_t_wchar *str, size_t len)
{
  size_t i;
  char *c_str;

  c_str = alloca (len);
  for (i = 0; i < len; i++)
    c_str[i] = (char) str[i];

  return scm_from_locale_stringn (c_str, len);
}

#endif /* HAVE_SCM_FROM_UTF32_STRINGN */

#ifndef HAVE_SCM_I_READ_ARRAY

/* Definitions copied from Guile 1.8.5.  */

static SCM
tag_to_type (const char *tag, SCM port)
{
#if SCM_ENABLE_DEPRECATED
  {
    /* Recognize the old syntax.
     */
    const char *instead;
    switch (tag[0])
      {
      case 'u':
	instead = "u32";
	break;
      case 'e':
	instead = "s32";
	break;
      case 's':
	instead = "f32";
	break;
      case 'i':
	instead = "f64";
	break;
      case 'y':
	instead = "s8";
	break;
      case 'h':
	instead = "s16";
	break;
      case 'l':
	instead = "s64";
	break;
      case 'c':
	instead = "c64";
	break;
      default:
	instead = NULL;
	break;
      }
    
    if (instead && tag[1] == '\0')
      {
	scm_c_issue_deprecation_warning_fmt
	  ("The tag '%c' is deprecated for uniform vectors. "
	   "Use '%s' instead.", tag[0], instead);
	return scm_from_locale_symbol (instead);
      }
  }
#endif
  
  if (*tag == '\0')
    return SCM_BOOL_T;
  else
    return scm_from_locale_symbol (tag);
}

static int
read_decimal_integer (SCM port, int c, ssize_t *resp)
{
  ssize_t sign = 1;
  ssize_t res = 0;
  int got_it = 0;

  if (c == '-')
    {
      sign = -1;
      c = scm_getc (port);
    }

  while ('0' <= c && c <= '9')
    {
      res = 10*res + c-'0';
      got_it = 1;
      c = scm_getc (port);
    }

  if (got_it)
    *resp = sign * res;
  return c;
}

SCM
scm_i_read_array (SCM port, int c)
{
  ssize_t rank;
  char tag[80];
  int tag_len;

  SCM shape = SCM_BOOL_F, elements;

  /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
     the array code can not deal with zero-length dimensions yet, and
     we want to allow zero-length vectors, of course.
  */
  if (c == '(')
    {
      scm_ungetc (c, port);
      return scm_vector (scm_read (port));
    }

  /* Disambiguate between '#f' and uniform floating point vectors.
   */
  if (c == 'f')
    {
      c = scm_getc (port);
      if (c != '3' && c != '6')
	{
	  if (c != EOF)
	    scm_ungetc (c, port);
	  return SCM_BOOL_F;
	}
      rank = 1;
      tag[0] = 'f';
      tag_len = 1;
      goto continue_reading_tag;
    }

  /* Read rank. 
   */
  rank = 1;
  c = read_decimal_integer (port, c, &rank);
  if (rank < 0)
    scm_i_input_error (NULL, port, "array rank must be non-negative",
		       SCM_EOL);

  /* Read tag. 
   */
  tag_len = 0;
 continue_reading_tag:
  while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
    {
      tag[tag_len++] = c;
      c = scm_getc (port);
    }
  tag[tag_len] = '\0';
  
  /* Read shape. 
   */
  if (c == '@' || c == ':')
    {
      shape = SCM_EOL;
      
      do
	{
	  ssize_t lbnd = 0, len = 0;
	  SCM s;

	  if (c == '@')
	    {
	      c = scm_getc (port);
	      c = read_decimal_integer (port, c, &lbnd);
	    }
	  
	  s = scm_from_ssize_t (lbnd);

	  if (c == ':')
	    {
	      c = scm_getc (port);
	      c = read_decimal_integer (port, c, &len);
	      if (len < 0)
		scm_i_input_error (NULL, port,
				   "array length must be non-negative",
				   SCM_EOL);

	      s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
	    }

	  shape = scm_cons (s, shape);
	} while (c == '@' || c == ':');

      shape = scm_reverse_x (shape, SCM_EOL);
    }

  /* Read nested lists of elements.
   */
  if (c != '(')
    scm_i_input_error (NULL, port,
		       "missing '(' in vector or array literal",
		       SCM_EOL);
  scm_ungetc (c, port);
  elements = scm_read (port);

  if (scm_is_false (shape))
    shape = scm_from_ssize_t (rank);
  else if (scm_ilength (shape) != rank)
    scm_i_input_error 
      (NULL, port,
       "the number of shape specifications must match the array rank",
       SCM_EOL);

  /* Handle special print syntax of rank zero arrays; see
     scm_i_print_array for a rationale.
  */
  if (rank == 0)
    {
      if (!scm_is_pair (elements))
	scm_i_input_error (NULL, port,
			   "too few elements in array literal, need 1",
			   SCM_EOL);
      if (!scm_is_null (SCM_CDR (elements)))
	scm_i_input_error (NULL, port,
			   "too many elements in array literal, want 1",
			   SCM_EOL);
      elements = SCM_CAR (elements);
    }

  /* Construct array. 
   */
  return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
}

#endif /* HAVE_SCM_I_READ_ARRAY */

#ifdef SCM_COL					  /* Guile < 2.1.4 */

void
increase_port_column (SCM port, size_t increment)
{
  SCM_COL (port) += increment;
}

#else  /* !defined SCM_COL */

void
increase_port_column (SCM port, size_t increment)
{
  size_t column = scm_to_size_t (scm_port_column (port));

  scm_set_port_column_x (port,
			 scm_from_size_t (column + increment));
}

const char *
port_encoding (SCM port)
{
  /* XXX: A lot of overhead just to get the encoding as a C string.  */
  char *encoding, *result;

  encoding = scm_to_locale_string (scm_port_encoding (port));
  result = scm_gc_malloc_pointerless (strlen (encoding) + 1, "encoding");
  strcpy (result, encoding);
  free (encoding);

  return result;
}

scm_t_string_failed_conversion_handler
port_conversion_strategy (SCM port)
{
  /* XXX: libguile should provide this function.  */
  SCM strategy = scm_port_conversion_strategy (port);

  if (scm_is_eq (strategy, scm_from_locale_symbol ("substitute")))
    return SCM_FAILED_CONVERSION_QUESTION_MARK;
  if (scm_is_eq (strategy, scm_from_locale_symbol ("escape")))
    return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;

  return SCM_FAILED_CONVERSION_ERROR;
}

#endif	/* !define SCM_COL */
