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

/* locals */
static void print (FILE *fp, Scheme_Object *obj, int escaped);
static void print_string (FILE *fp, Scheme_Object *string, int escaped);
static void print_pair (FILE *fp, Scheme_Object *pair, int escaped);
static void print_vector (FILE *fp, Scheme_Object *vec, int escaped);
static void print_char (FILE *fp, Scheme_Object *chobj, int escaped);

void
scheme_debug_print (Scheme_Object *obj)
{
  print (stdout, obj, 1);
  fflush (stdout);
}

void
scheme_write (FILE *fp, Scheme_Object *obj)
{
  print (fp, obj, 1);
}

void
scheme_display (FILE *fp, Scheme_Object *obj)
{
  print (fp, obj, 0);
}

static void
print (FILE *fp, Scheme_Object *obj, int escaped)
{
  Scheme_Object *type;

  type = SCHEME_TYPE (obj);
  if (type==scheme_type_type || type==scheme_symbol_type)
    {
      fprintf (fp, "%s", SCHEME_STR_VAL (obj));
    }
  else if (type==scheme_string_type)
    {
      print_string (fp, obj, escaped);
    }
  else if (type==scheme_char_type)
    {
      print_char (fp, obj, escaped);
    }
  else if (type==scheme_integer_type)
    {
      fprintf (fp, "%d", SCHEME_INT_VAL (obj));
    }
  else if (type==scheme_double_type)
    {
      fprintf (fp, "%f", SCHEME_DBL_VAL (obj));
    }
  else if (type==scheme_null_type)
    {
      fprintf (fp, "()");
    }
  else if (type==scheme_pair_type)
    {
      print_pair (fp, obj, escaped);
    }
  else if (type==scheme_vector_type)
    {
      print_vector (fp, obj, escaped);
    }
  else if (type==scheme_true_type)
    {
      fprintf (fp, "#t");
    }
  else if (type==scheme_false_type)
    {
      fprintf (fp, "#f");
    }
  else
    {
      fprintf (fp, "#%s", SCHEME_STR_VAL(SCHEME_TYPE(obj)));
    }
}

static void 
print_string (FILE *fp, Scheme_Object *string, int escaped)
{
  char *str;

  str = SCHEME_STR_VAL (string);
  if ( escaped )
    {
      fputc ('"', fp);
    }
  while ( *str )
    {
      if (escaped && ((*str == '"') || (*str == '\\')))
	{
	  fputc ('\\', fp);
	}
      fputc (*str, fp);
      *str++;
    }
  if ( escaped )
    {
      fputc ('"', fp);
    }
}

static void
print_pair (FILE *fp, Scheme_Object *pair, int escaped)
{
  Scheme_Object *cdr;

  fprintf (fp, "(");
  print (fp, SCHEME_CAR (pair), escaped);
  cdr = SCHEME_CDR (pair);
  while ((cdr != scheme_null) && (SCHEME_TYPE(cdr) == scheme_pair_type))
    {
      fprintf (fp, " ");
      print (fp, SCHEME_CAR (cdr), escaped);
      cdr = SCHEME_CDR (cdr);
    }
  if (cdr != scheme_null)
    {
      fprintf (fp, " . ");
      print (fp, cdr, escaped);
    }
  fprintf (fp, ")");
}

static void
print_vector (FILE *fp, Scheme_Object *vec, int escaped)
{
  int i;

  fprintf (fp, "#(");
  for ( i=0 ; i<SCHEME_VEC_SIZE(vec) ; ++i )
    {
      print (fp, SCHEME_VEC_ELS(vec)[i], escaped);
      if (i<SCHEME_VEC_SIZE(vec)-1)
	{
	  fprintf (fp, " ");
	}
    }
  fprintf (fp, ")");
}

static void 
print_char (FILE *fp, Scheme_Object *charobj, int escaped)
{
  char ch;

  ch = SCHEME_CHAR_VAL (charobj);
  if (escaped)
    {
      switch ( ch )
	{
	case '\n':
	  fprintf (fp, "#\\newline");
	  break;
	case '\t':
	  fprintf (fp, "#\\tab");
	case ' ':
	  fprintf (fp, "#\\space");
	  break;
	case '\r':
	  fprintf (fp, "#\\return");
	  break;
	case '\f':
	  fprintf (fp, "#\\page");
	  break;
	case '\b':
	  fprintf (fp, "#\\backspace");
	  break;
	default:
	  fprintf (fp, "#\\%c", ch);
	}
    }
  else
    {
      fprintf (fp, "%c", ch);
    }
}
