/*
 *                    S C H E M E _ B U F F E R . C
 *
 *  Implements reading scheme expression from buffers and strings.
 *
 *  Version      : $Revision: 1.2 $
 *
 *  Created      : Sun Jul 17 23:37:38 1994
 *  Author       : Ulrich Drepper <drepper@mydec>
 *
 *  Last modified: Sun Jul 17 23:38:59 1994
 *  Author       : Ulrich Drepper <drepper@mydec>
 *
 *  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 1, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 */
#if !defined(lint)
static const char *vcid = "$Id: scheme_buffer.c,v 1.2 1994/07/17 22:39:08 drepper Exp $";
#endif /* lint */

#include "scheme.h"
#include <stdlib.h>
#include <ctype.h>

#define MAX_STRING_SIZE 1024
#define MAX_NUMBER_SIZE 64
#define MAX_SYMBOL_SIZE 255

/* globals */
Scheme_Object *scheme_eos;
Scheme_Object *scheme_eos_type;

/* local function prototypes */

static Scheme_Object *read_char (char **CP);
static Scheme_Object *read_list (char **CP);
static Scheme_Object *read_string (char **CP);
static Scheme_Object *read_quote (char **CP);
static Scheme_Object *read_vector (char **CP);
static Scheme_Object *read_number (char **CP);
static Scheme_Object *read_hex_number (char **CP);
static Scheme_Object *read_binary_number (char **CP);
static Scheme_Object *read_octal_number (char **CP);
static Scheme_Object *read_symbol (char **CP);
static Scheme_Object *read_character (char **CP);
static Scheme_Object *read_quasiquote (char **CP);
static Scheme_Object *read_unquote (char **CP);
static Scheme_Object *read_unquote_splicing (char **CP);
static Scheme_Object *read_coord (char **CP);
static void skip_whitespace_comments (char **CP);
static int match_chars (char **CP, char *str);
static Scheme_Object *scheme_make_eos (void);

void
scheme_init_buffer (Scheme_Env *env)
{
  scheme_eos_type = scheme_make_type ("<eos>");
  scheme_add_global ("<eos>", scheme_eos_type, env);
  scheme_eos = scheme_make_eos ();
}

Scheme_Object *
scheme_read_str (char **CP)
#define cp (*CP)
{
 start_over:
  while (isspace(*cp))
    {
      cp++;
    }
  switch ( *cp++ )
    {
    case ')': /* scheme_signal_error ("read_str: unexpected ')'"); */
    case '\0': return (scheme_eos);
    case '(': return (read_list (CP));
    case '"': return (read_string (CP));
    case '\'': return (read_quote (CP));
    case '`': return (read_quasiquote (CP));
    case ',':
      if (*cp == '@')
	{
	  cp++;
	  return (read_unquote_splicing (CP));
	}
      else
	{
	  return (read_unquote (CP));
	}
    case ';':
      while (*cp != '\n')
	{
	  if (*cp == '\0')
	    {
	      return (scheme_eos);
	    }
	  cp++;
	}
      goto start_over;
    case '+':
    case '-':
      if (isdigit (*cp--))
	{
	  return (read_number (CP));
	}
      else
	{
	  return (read_symbol (CP));
	}
    case '#':
      switch ( *cp++ )
	{
	case '(': return (read_vector (CP));
	case '\\': return (read_character (CP));
	case 't': return (scheme_true);
	case 'f': return (scheme_false);
	case 'x': return (read_hex_number (CP));
	case 'b': return (read_binary_number (CP));
	case 'o': return (read_octal_number (CP));
	case '|':
	  do
	    {
	      if (*cp == '\0')
		{
		  scheme_signal_error ("read_str: end of file in #| comment");
		}
	      if ((*cp == '|') && (*(cp+1) == '#'))
		{
		  cp += 2;
		  goto start_over;
		}
	      cp++;
	    }
	  while ( 1 );
	  break;
	default:
	  scheme_signal_error ("read_str: unexpected `#'");
	}
    default:
      cp--;
      if (isdigit (*cp))
	{
	  return (read_number (CP));
	}
      else
	{
	  return (read_symbol (CP));
	}
    }
}

static Scheme_Object *
read_char (char **CP)
{
  if (*cp == '\0')
    {
      return (scheme_eos);
    }
  else
    {
      return (scheme_make_char (*cp++));
    }
}

/* "(" has already been read */
static Scheme_Object *
read_list (char **CP)
{
  Scheme_Object *obj, *car, *cdr;

  skip_whitespace_comments (CP);
  if (*cp == ')')
    {
      cp++;
      return (scheme_null);
    }
  car = scheme_read_str (CP);
  if (car==scheme_eos) return scheme_eos;
  skip_whitespace_comments (CP);
  if (*cp == ')')
    {
      cp++;
      cdr = scheme_null;
    }
  else if ((*cp == '.') && isspace (*(cp+1)))
    {
      cp += 2;
      cdr = scheme_read_str (CP);
      if (cdr==scheme_eos) return scheme_eos;
      skip_whitespace_comments (CP);
      if (*cp != ')')
	{
	  scheme_signal_error ("read_str: malformed list");
	}
      cp++;
    }
  else
    {
      cdr = read_list (CP);
      if (cdr==scheme_eos) return scheme_eos;
    }
  return (scheme_make_pair (car, cdr));
}

/* '"' has already been read */
static Scheme_Object *
read_string (char **CP)
{
  char buf[MAX_STRING_SIZE];
  int i;

  i = 0;
  while (*cp != '"')
    {
      if (*cp == '\\')
	{
	  cp++;
	}
      if (i > MAX_STRING_SIZE)
	{
	  scheme_signal_error ("read_str: string too long for reader");
	}
      buf[i++] = *cp++;
    }
  cp++;
  buf[i] = '\0';
  return (scheme_make_string (buf));
}

/* "'" has been read */
static Scheme_Object *
read_quote (char **CP)
{
  Scheme_Object *obj;

  obj = scheme_read_str (CP);
  if (obj==scheme_eos) return scheme_eos;
  return (scheme_make_pair (scheme_quote_symbol, 
			    scheme_make_pair (obj, scheme_null)));
}

/* "#(" has been read */
static Scheme_Object *
read_vector (char **CP)
{
  Scheme_Object *obj, *vec;
  int len, i;
  
  obj = read_list (CP);
  if (obj==scheme_eos) return scheme_eos;
  len = scheme_list_length (obj);
  vec = scheme_make_vector (len, NULL);
  for ( i=0 ; i<len ; ++i )
    {
      SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(obj);
      obj = SCHEME_CDR(obj);
    }
  return (vec);
}

/* nothing has been read */
static Scheme_Object  *
read_number (char **CP)
{
  char buf[MAX_NUMBER_SIZE];
  char *pStart = cp;
  int i, is_float;

  i = 0;
  is_float = 0;
  if (*cp == '+')
    {
      cp++;
    }
  else if (*cp == '-')
    {
      buf[i++] = *cp++;
    }
  do
    {
      if (i > MAX_NUMBER_SIZE)
	{
	  scheme_signal_error ("read_str: number too long for reader");
	}
      if ((*cp == '.') || (*cp == 'e') || (*cp == 'E'))
	{
	  is_float = 1;
	}
      buf[i++] = *cp++;
    }
  while (isdigit (*cp) || (*cp == '.') || (*cp == 'e') || (*cp == 'E'));
  if (!is_float && (*cp == ',' || *cp == ':'))
    {
      cp = pStart;
      return read_coord(CP);
    }
  else
    {
      buf[i] = '\0';
      if ( is_float )
        {
          double d;
	  d = strtod (buf, NULL);
	  return (scheme_make_double (d));
        }
      else
        {
	  int i;

	  i = atoi (buf);
	  return (scheme_make_integer (i));
        }
    }
}

static Scheme_Object *
read_hex_number (char **CP)
{
  int i;

  i = 0;
  while ( 1 )
    {
      if (*cp >= '0' && *cp <= '9')
	{
	  i *= 16;
	  i += *cp++ - '0';
	}
      else if ((*cp >= 'a' && *cp <= 'f') || (*cp >= 'A' && *cp <= 'F'))
	{
	  i *= 16;
	  if (*cp >= 'a' && *cp <= 'f')
	    i += *cp++ - 'a' + 10;
	  else
	    i += *cp++ - 'A' + 10;
	}
      else
	{
	  return (scheme_make_integer (i));
	}
    }
}

static Scheme_Object *
read_binary_number (char **CP)
{
  int i;

  i = 0;
  while ( 1 )
    {
      if (*cp == '0' || *cp == '1')
	{
	  i *= 2;
	  i += *cp++ - '0';
	}
      else
	{
	  return (scheme_make_integer (i));
	}
    }
}

static Scheme_Object *
read_octal_number (char **CP)
{
  int i;

  i = 0;
  while ( 1 )
    {
      if (*cp >= '0' && *cp <= '7')
	{
	  i *= 8;
	  i += *cp++ - '0';
	}
      else
	{
	  return (scheme_make_integer (i));
	}
    }
}

/* nothing has been read */
static Scheme_Object *
read_symbol (char **CP)
{
  char buf[MAX_SYMBOL_SIZE];
  int i;

  i = 0;
  while ((!isspace (*cp))
	 && (*cp != '(')
	 && (*cp != ')')
	 && (*cp != '"')
	 && (*cp != ';')
	 && (*cp != '\0'))
    {
      buf[i++] = *cp++;
    }
  if (i==0) return scheme_eos;
  buf[i] = '\0';
  return (scheme_intern_symbol ((char *)&buf));
}

/* #\ has been read */
static Scheme_Object *
read_character (char **CP)
{
  switch (*cp++)
    {
    case 'n': /* maybe `newline' */
    case 'N':
      if ((*cp == 'e') || (*cp == 'E'))
	{
	  if (! match_chars (CP, "ewline"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\n'));
	    }
	}
      else
	{
	    return (scheme_make_char (*(cp-1)));
	}
    case 's': /* maybe `space' */
    case 'S':
      if ((*cp == 'p') || (*cp == 'P'))
	{
	  if (! match_chars (CP, "pace"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char (' '));
	    }
	}
      else
	{
	  return (scheme_make_char (*(cp-1)));
	}
    case 'r': /* maybe `rubout' */
    case 'R':
      if ((*cp == 'u') || (*cp == 'U'))
	{
	  if (! match_chars (CP, "ubout"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char (0x7f));
	    }
	}
      else if ((*cp == 'e') || (*cp == 'E'))
	{
	  if (! match_chars (CP, "eturn"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\r'));
	    }
	}
      else
	{
	  return (scheme_make_char (*(cp-1)));
	}
    case 'p': /* maybe `page' */
    case 'P':
      if ((*cp == 'a') || (*cp == 'A'))
	{
	  if (! match_chars (CP, "age"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\f'));
	    }
	}
      else
	{
	  return (scheme_make_char (*(cp-1)));
	}
    case 't': /* maybe `tab' */
    case 'T':
      if ((*cp == 'a') || (*cp == 'A'))
	{
	  if (! match_chars (CP, "ab"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\t'));
	    }
	}
      else
	{
	  return (scheme_make_char (*(cp-1)));
	}
    case 'b': /* maybe `backspace' */
    case 'B':
      if ((*cp == 'a') || (*cp == 'A'))
	{
	  if (! match_chars (CP, "ackspace"))
	    {
	      scheme_signal_error ("read_str: bad character constant", NULL);
	    }
	  else
	    {
	      return (scheme_make_char ('\b'));
	    }
	}
      else
	{
	  return (scheme_make_char (*(cp-1)));
	}
    case 'l': /* maybe `linefeed' */
    case 'L':
      if ((*cp == 'i') || (*cp == 'I'))
	{
	  if (! match_chars (CP, "inefeed"))
	    {
	      scheme_signal_error ("read_str: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\n'));
	    }
	}
      else
	{
	  return (scheme_make_char (*(cp-1)));
	}
    default:
      return (scheme_make_char (*(cp-1)));
    }
}

/* "`" has been read */
static Scheme_Object *
read_quasiquote (char **CP)
{
  Scheme_Object *quoted_obj, *ret;
  
  quoted_obj = scheme_read_str (CP);
  if (quoted_obj==scheme_eos) return scheme_eos;
  ret = scheme_make_pair (scheme_quasiquote_symbol, 
			  scheme_make_pair (quoted_obj, scheme_null));
  return (ret);
}

/* "," has been read */
static Scheme_Object *
read_unquote (char **CP)
{
  Scheme_Object *obj, *ret;

  obj = scheme_read_str (CP);
  if (obj==scheme_eos) return scheme_eos;
  ret = scheme_make_pair (scheme_unquote_symbol, 
			  scheme_make_pair (obj, scheme_null));
  return (ret);
}

/* ",@" has been read */
static Scheme_Object *
read_unquote_splicing (char **CP)
{
  Scheme_Object *obj, *ret;

  obj = scheme_read_str (CP);
  if (obj==scheme_eos) return scheme_eos;
  ret = scheme_make_pair (scheme_unquote_splicing_symbol, 
			  scheme_make_pair (obj, scheme_null));
  return (ret);
}

static Scheme_Object *
read_coord (char **CP)
{
  int x1, x2, y1, y2;
  Scheme_Object *ret;

  if (!strToRange(CP, &x1, &y1, &x2, &y2)) return scheme_eos;

  ret = scheme_make_range (x1, y1, x2, y2);

  return (ret);
}

/* utilities */

static void
skip_whitespace_comments (char **CP)
{
 start_over:
  while (isspace(*cp)) cp++;
  if ( *cp == ';' )
    {
      while (*++cp != '\n');
      goto start_over;
    }
}

static int
match_chars (char **CP, char *str)
{
  int i;

  i = 0;
  while (str[i])
    {
      if (tolower(*cp++) != tolower(str[i]))
	{
	  return (0);
	}
      i++;
    }
  return (1);
}

static Scheme_Object *
scheme_make_eos (void)
{
  Scheme_Object *eos;

  eos = scheme_alloc_object ();
  SCHEME_TYPE (eos) = scheme_eos_type;
  return (eos);
}

/*
 * Local Variables:
 *  mode:c
 *  c-indent-level:4
 *  c-continued-statement-offset:4
 *  c-continued-brace-offset:0
 *  c-brace-offset:0
 *  c-imaginary-offset:0
 *  c-argdecl-indent:4
 *  c-label-offset:-2
 * End:
 */
