/*
     libscheme	
     Copyright (C) 1994 Brent Benson

     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.
*/

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

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

/* local function prototypes */

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

Scheme_Object *
scheme_read (FILE *fp)
{
  int ch;

 start_over:
  ch = getc (fp);
  while (isspace(ch))
    {
      ch = getc (fp);
    }
  switch ( ch )
    {
    case EOF: return (scheme_eof);
    case ')': scheme_signal_error ("read: unexpected ')'");
    case '(': return (read_list (fp));
    case '"': return (read_string (fp));
    case '\'': return (read_quote (fp));
    case '`': return (read_quasiquote (fp));
    case ',':
      if (peek_char (fp) == '@')
	{
	  ch = getc (fp);
	  return (read_unquote_splicing (fp));
	}
      else
	{
	  return (read_unquote (fp));
	}
    case ';':
      while ((ch = getc (fp)) != '\n')
	{
	  if (ch == EOF)
	    {
	      return (scheme_eof);
	    }
	}
      goto start_over;
    case '+':
    case '-':
      if (isdigit (peek_char (fp)))
	{
	  ungetc (ch, fp);
	  return (read_number (fp));
	}
      else
	{
	  ungetc (ch, fp);
	  return (read_symbol (fp));
	}
    case '#':
      ch = getc (fp);
      switch ( ch )
	{
	case '(': return (read_vector (fp));
	case '\\': return (read_character (fp));
	case 't': return (scheme_true);
	case 'f': return (scheme_false);
	case 'x': return (read_hex_number (fp));
	case 'b': return (read_binary_number (fp));
	case 'o': return (read_octal_number (fp));
	case '|':
	  do
	    {
	      ch = getc (fp);
	      if (ch == EOF)
		{
		  scheme_signal_error ("read: end of file in #| comment");
		}
	      if ((ch == '|') && (peek_char(fp) == '#'))
		{
		  ch = getc (fp);
		  goto start_over;
		}
	    }
	  while ( 1 );
	  break;
	default:
	  scheme_signal_error ("read: unexpected `#'");
	}
    default:
      if (isdigit (ch))
	{
	  ungetc (ch, fp);
	  return (read_number (fp));
	}
      else
	{
	  ungetc (ch, fp);
	  return (read_symbol (fp));
	}
    }
}

static Scheme_Object *
read_char (FILE *fp)
{
  int ch;

  ch = getc (fp);
  if (ch == EOF)
    {
      return (scheme_eof);
    }
  else
    {
      return (scheme_make_char (ch));
    }
}

/* "(" has already been read */
static Scheme_Object *
read_list (FILE *fp)
{
  Scheme_Object *obj, *car, *cdr;
  int ch;

  skip_whitespace_comments (fp);
  if (peek_char(fp) == ')')
    {
      ch = getc (fp);
      return (scheme_null);
    }
  car = scheme_read (fp);
  skip_whitespace_comments (fp);
  if (peek_char(fp) == ')')
    {
      ch = getc (fp);
      cdr = scheme_null;
    }
  else if ((peek_char(fp) == '.') && isspace (double_peek_char(fp)))
    {
      ch = getc (fp);
      cdr = scheme_read (fp);
      skip_whitespace_comments (fp);
      if (peek_char(fp) != ')')
	{
	  scheme_signal_error ("read: malformed list");
	}
      ch = getc (fp);
    }
  else
    {
      cdr = read_list (fp);
    }
  return (scheme_make_pair (car, cdr));
}

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

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

/* "'" has been read */
static Scheme_Object *
read_quote (FILE *fp)
{
  Scheme_Object *obj;

  obj = scheme_read (fp);
  return (scheme_make_pair (scheme_quote_symbol, 
			    scheme_make_pair (obj, scheme_null)));
}

/* "#(" has been read */
static Scheme_Object *
read_vector (FILE *fp)
{
  Scheme_Object *obj, *vec;
  int len, i;
  
  obj = read_list (fp);
  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 (FILE *fp)
{
  char buf[MAX_NUMBER_SIZE];
  int i, is_float, ch;

  i = 0;
  is_float = 0;
  ch = getc (fp);
  if (ch == '+')
    {
      ch = getc (fp);
    }
  else if (ch == '-')
    {
      ch = getc (fp);
      buf[i++] = '-';
    }
  do
    {
      if (i > MAX_NUMBER_SIZE)
	{
	  scheme_signal_error ("read: number too long for reader");
	}
      if ((ch == '.') || (ch == 'e') || (ch == 'E'))
	{
	  is_float = 1;
	}
      buf[i++] = ch;
    }
  while (isdigit (ch = getc (fp)) || (ch == '.') || (ch == 'e') || (ch == 'E'));
  ungetc (ch, fp);
  buf[i] = '\0';
  if (!is_float && (ch == ',' || ch == ':'))
    {
      return read_coord (fp, buf);
    }
  else
    {
      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 (FILE *fp)
{
  int ch, i;

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

static Scheme_Object *
read_binary_number (FILE *fp)
{
  int ch, i;

  i = 0;
  while ( 1 )
    {
      ch = getc (fp);
      if (ch == '0' || ch == '1')
	{
	  i *= 2;
	  i += ch - '0';
	}
      else
	{
	  ungetc (ch, fp);
	  return (scheme_make_integer (i));
	}
    }
}

static Scheme_Object *
read_octal_number (FILE *fp)
{
  int ch, i;

  i = 0;
  while ( 1 )
    {
      ch = getc (fp);
      if (ch >= '0' && ch <= '7')
	{
	  i *= 8;
	  i += ch - '0';
	}
      else
	{
	  ungetc (ch, fp);
	  return (scheme_make_integer (i));
	}
    }
}

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

  i = 0;
  while ((!isspace (ch = getc (fp)))
	 && (ch != '(')
	 && (ch != ')')
	 && (ch != '"')
	 && (ch != ';')
	 && (ch != EOF))
    {
      buf[i++] = ch;
    }
  if (ch != EOF)
    {
      ungetc (ch, fp);
    }
  buf[i] = '\0';
  return (scheme_intern_symbol ((char *)&buf));
}

/* "#\" has been read */
static Scheme_Object *
read_character (FILE *fp)
{
  int ch;

  ch = getc (fp);
  switch (ch)
    {
    case 'n': /* maybe `newline' */
    case 'N':
      if ((peek_char(fp) == 'e') || (peek_char(fp) == 'E'))
	{
	  if (! match_chars (fp, "ewline"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\n'));
	    }
	}
      else
	{
	    return (scheme_make_char (ch));
	}
    case 's': /* maybe `space' */
    case 'S':
      if ((peek_char(fp) == 'p') || (peek_char(fp) == 'P'))
	{
	  if (! match_chars (fp, "pace"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char (' '));
	    }
	}
      else
	{
	  return (scheme_make_char (ch));
	}
    case 'r': /* maybe `rubout' */
    case 'R':
      if ((peek_char(fp) == 'u') || (peek_char(fp) == 'U'))
	{
	  if (! match_chars (fp, "ubout"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char (0x7f));
	    }
	}
      else if ((peek_char(fp) == 'e') || (peek_char(fp) == 'E'))
	{
	  if (! match_chars (fp, "eturn"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\r'));
	    }
	}
      else
	{
	  return (scheme_make_char (ch));
	}
    case 'p': /* maybe `page' */
    case 'P':
      if ((peek_char(fp) == 'a') || (peek_char(fp) == 'A'))
	{
	  if (! match_chars (fp, "age"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\f'));
	    }
	}
      else
	{
	  return (scheme_make_char (ch));
	}
    case 't': /* maybe `tab' */
    case 'T':
      if ((peek_char(fp) == 'e') || (peek_char(fp) == 'E'))
	{
	  if (! match_chars (fp, "ab"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\t'));
	    }
	}
      else
	{
	  return (scheme_make_char (ch));
	}
    case 'b': /* maybe `backspace' */
    case 'B':
      if ((peek_char(fp) == 'e') || (peek_char(fp) == 'e'))
	{
	  if (! match_chars (fp, "ackspace"))
	    {
	      scheme_signal_error ("read: bad character constant", NULL);
	    }
	  else
	    {
	      return (scheme_make_char ('\b'));
	    }
	}
      else
	{
	  return (scheme_make_char (ch));
	}
    case 'l': /* maybe `linefeed' */
    case 'L':
      if ((peek_char(fp) == 'e') || (peek_char(fp) == 'E'))
	{
	  if (! match_chars (fp, "inefeed"))
	    {
	      scheme_signal_error ("read: bad character constant");
	    }
	  else
	    {
	      return (scheme_make_char ('\n'));
	    }
	}
      else
	{
	  return (scheme_make_char (ch));
	}
    default:
      return (scheme_make_char (ch));
    }
}

/* "`" has been read */
static Scheme_Object *
read_quasiquote (FILE *fp)
{
  Scheme_Object *quoted_obj, *ret;
  
  quoted_obj = scheme_read (fp);
  ret = scheme_make_pair (scheme_quasiquote_symbol, 
			  scheme_make_pair (quoted_obj, scheme_null));
  return (ret);
}

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

  obj = scheme_read (fp);
  ret = scheme_make_pair (scheme_unquote_symbol, 
			  scheme_make_pair (obj, scheme_null));
  return (ret);
}

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

  obj = scheme_read (fp);
  ret = scheme_make_pair (scheme_unquote_splicing_symbol, 
			  scheme_make_pair (obj, scheme_null));
  return (ret);
}

static Scheme_Object *
read_coord (FILE *fp, char *buf)
{
  int x1, x2, y1, y2;
  Scheme_Object *ret;
  char *cp = buf;
  int ch;

  while (*++cp);
  while (isdigit(ch = getc(fp)) || (ch == ':') || (ch == ',') ||
	 (ch == '+') || (ch == '-')) {
      *cp++ = ch;
  }
  ungetc(ch,fp);
  *cp = '\0';

  if (!strToRange(&buf, &x1, &y1, &x2, &y2)) return scheme_eof;

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

  return (ret);
}

/* utilities */

static void
skip_whitespace_comments (FILE *fp)
{
  int ch;

 start_over:
  while (isspace(ch = getc (fp)));
  if ( ch == ';' )
    {
      while ((ch = getc (fp)) != '\n');
      goto start_over;
    }
  ungetc (ch, fp);
}

static int
peek_char (FILE *fp)
{
  int ch;

  ch = getc (fp);
  ungetc (ch, fp);
  return (ch);
}

static int 
double_peek_char (FILE *fp)
{
  int ch1, ch2;

  ch1 = getc (fp);
  ch2 = getc (fp);
  ungetc (ch2, fp);
  ungetc (ch1, fp);
  return (ch2);
}

static int
match_chars (FILE *fp, char *str)
{
  int i;
  int ch;

  i = 0;
  while (str[i])
    {
      ch = getc (fp);
      if (tolower(ch) != tolower(str[i]))
	{
	  return (0);
	}
      i++;
    }
  return (1);
}
