/*
 *                    S C H E M E _ V P R I N T . C
 *
 *  Implements printing to Athena text widget.
 *
 *  Version      : $Revision: 1.2 $
 *
 *  Created      : Sun Jul 17 23:41:26 1994
 *  Author       : Ulrich Drepper <drepper@mydec>
 *
 *  Last modified: Sun Jul 17 23:43:34 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_vprint.c,v 1.2 1994/07/17 22:43:43 drepper Exp $";
#endif /* lint */

#include <X11/Intrinsic.h>
#include <X11/StringDefs.h>
#include <X11/Xaw/Text.h>

#include "scheme.h"
#include "empire.h"
#include "config.h"

/* locals */
static void print (char *cp, Scheme_Object *obj, int escaped);
static void print_string (char *cp, Scheme_Object *string, int escaped);
static void print_pair (char *cp, Scheme_Object *pair, int escaped);
static void print_vector (char *cp, Scheme_Object *vec, int escaped);
static void print_char (char *cp, Scheme_Object *chobj, int escaped);
static Scheme_Object* vtprint (int argc, Scheme_Object *argv[]);
static Scheme_Object* vtdisplay (int argc, Scheme_Object *argv[]);
static Scheme_Object* vtnewline (int argc, Scheme_Object *argv[]);
static Scheme_Object* vtwrite_char (int argc, Scheme_Object *argv[]);
static Scheme_Object* vtload (int argc, Scheme_Object *argv[]);

void 
scheme_init_vtport (Scheme_Env *env)
{
  scheme_add_global ("write", scheme_make_prim (vtprint), env);
  scheme_add_global ("display", scheme_make_prim (vtdisplay), env);
  scheme_add_global ("newline", scheme_make_prim (vtnewline), env);
  scheme_add_global ("write-char", scheme_make_prim (vtwrite_char), env);
  scheme_add_global ("load", scheme_make_prim (vtload), env);
}

void
scheme_tprint (void (*editAdd)(Bool, XawTextBlock *, Bool), Scheme_Object *obj,
	       int escaped, char *postfix)
{
  static char buffer[16384];    /* should be enough */
#if XtSpecificationRelease<6 || defined(UseXaw3d)
  XawTextBlock textBlock = { 0, 0, buffer, FMT8BIT };
#else
  XawTextBlock textBlock = { 0, 0, buffer, XawFmt8Bit };
#endif

  buffer[0] = '\0';
  if (obj) {
      print(buffer, obj, escaped);
  }
  if (postfix) {
      strcat(buffer, postfix);
  }
  textBlock.length = strlen(buffer);
     
  editAdd(True, &textBlock, True);
}

Scheme_Object*
vtprint(int argc, Scheme_Object *argv[])
{
  FILE *fp;
  
  SCHEME_ASSERT ((argc==1 || argc==2), "write: wrong number of args");
  if (argc == 2)
    {
      SCHEME_ASSERT (SCHEME_OUTPORTP(argv[1]), "write: second arg must be an output port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[1]);
      scheme_write (fp, argv[0]);
    }
  else
    {
      scheme_tprint(currentEditAdd, argv[0], 1, NULL);
    }
  return (scheme_true);
}

Scheme_Object*
vtdisplay(int argc, Scheme_Object *argv[])
{
  FILE *fp;
  
  SCHEME_ASSERT ((argc==1 || argc==2), "display: wrong number of args");
  if (argc == 2)
    {
      SCHEME_ASSERT (SCHEME_OUTPORTP(argv[1]), "display: second arg must be an output port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[1]);
      scheme_display (fp, argv[0]);
    }
  else
    {
      scheme_tprint(currentEditAdd, argv[0], 0, NULL);
    }
  return (scheme_true);
}

static Scheme_Object *
vtnewline (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  
  SCHEME_ASSERT ((argc==0 || argc==1), "newline: wrong number of args");
  if (argc == 1)
    {
      SCHEME_ASSERT (SCHEME_OUTPORTP(argv[0]), "newline: arg must be an output port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[0]);
      fprintf (fp, "\n"); 
    }
  else
    {
      scheme_tprint(currentEditAdd, NULL, 0, "\n");
    }
  return (scheme_true);
}

static Scheme_Object *
vtwrite_char (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  
  SCHEME_ASSERT ((argc==1 || argc==2), "write-char: wrong number of args");
  SCHEME_ASSERT (SCHEME_CHARP(argv[0]), "write-char: first arg must be a character");
  if (argc == 2)
    {
      SCHEME_ASSERT (SCHEME_OUTPORTP(argv[1]), "write-char: second arg must be an output port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[1]);
      fprintf (fp, "%c", SCHEME_CHAR_VAL (argv[0]));
    }
  else
    {
      scheme_tprint(currentEditAdd, argv[0], 0, NULL);
    }
  return (scheme_true);
}

static Scheme_Object *
vtload (int argc, Scheme_Object *argv[])
{
  char buffer[120];
#if XtSpecificationRelease<6 || defined(UseXaw3d)
  XawTextBlock textBlock = { 0, 0, buffer, FMT8BIT };
#else
  XawTextBlock textBlock = { 0, 0, buffer, XawFmt8Bit };
#endif

  Scheme_Object *obj, *ret;
  char *filename;
  FILE *fp;

  SCHEME_ASSERT ((argc == 1), "load: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP (argv[0]), "load: arg must be a filename (string)");
  filename = SCHEME_STR_VAL (argv[0]);
  if (xIsUp) {
      sprintf (buffer, "; loading %s\n", filename);
      textBlock.length = strlen(buffer);
      currentEditAdd(True, &textBlock, True);
  }
  
  fp = fopen (filename, "r");
  if (! fp)
    {
      scheme_signal_error ("load: could not open file for input: %s",
			   filename);
    }
  while ((obj = scheme_read (fp)) != scheme_eof) {
      ret = scheme_eval (obj, scheme_env);
  }
  if (xIsUp) {
      sprintf (buffer, "; done loading %s\n", filename);
      textBlock.length = strlen(buffer);
      currentEditAdd(True, &textBlock, True);
  }
  
  return (ret);
}


static void
print (char *cp, Scheme_Object *obj, int escaped)
{
  Scheme_Object *type;

  type = SCHEME_TYPE (obj);
  if (type==scheme_type_type || type==scheme_symbol_type)
    {
      sprintf (cp, "%s", SCHEME_STR_VAL (obj));
    }
  else if (type==scheme_string_type)
    {
      print_string (cp, obj, escaped);
    }
  else if (type==scheme_char_type)
    {
      print_char (cp, obj, escaped);
    }
  else if (type==scheme_integer_type)
    {
      sprintf (cp, "%d", SCHEME_INT_VAL (obj));
    }
  else if (type==scheme_double_type)
    {
      sprintf (cp, "%f", SCHEME_DBL_VAL (obj));
    }
  else if (type==scheme_null_type)
    {
      sprintf (cp, "()");
    }
  else if (type==scheme_coord_type)
    {
      sprintf (cp, "%d,%d", SCHEME_COORD_VAL_X (obj), SCHEME_COORD_VAL_Y (obj));
    }
  else if (type==scheme_range_type)
    {
      if (SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_LU(obj)) == SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_RL(obj)))
	{
	  if (SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_LU(obj)) == SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_RL(obj)))
	    {
	      sprintf (cp, "%d,%d",
		       SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_LU(obj)),
		       SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_LU(obj)));
	    }
	  else
	    {
	      sprintf (cp, "%d,%d:%d",
		       SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_LU(obj)),
		       SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_LU(obj)),
		       SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_RL(obj)));
	    }
	}
      else
	{
	    if (SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_LU(obj)) == SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_RL(obj)))
	    {
	      sprintf (cp, "%d:%d,%d",
		       SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_LU(obj)),
		       SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_RL(obj)),
		       SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_LU(obj)));
	    }
	  else
	    {
	      sprintf (cp, "%d:%d,%d:%d",
		       SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_LU(obj)),
		       SCHEME_COORD_VAL_X(SCHEME_RANGE_VAL_RL(obj)),
		       SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_LU(obj)),
		       SCHEME_COORD_VAL_Y(SCHEME_RANGE_VAL_RL(obj)));
	    }
	}
    }
  else if (type==scheme_pair_type)
    {
      print_pair (cp, obj, escaped);
    }
  else if (type==scheme_vector_type)
    {
      print_vector (cp, obj, escaped);
    }
  else if (type==scheme_true_type)
    {
      sprintf (cp, "#t");
    }
  else if (type==scheme_false_type)
    {
      sprintf (cp, "#f");
    }
  else if (type == scheme_c_char_type)
    {
      sprintf (cp, "%c", *SCHEME_C_CHAR_VAL(obj));
    }
  else if (type == scheme_c_integer_type)
    {
      sprintf (cp, "%d", *SCHEME_C_INT_VAL(obj));
    }
  else if (type == scheme_c_double_type)
    {
      sprintf (cp, "%f", *SCHEME_C_DOUBLE_VAL(obj));
    }
  else
    {
      sprintf (cp, "#%s", SCHEME_STR_VAL(SCHEME_TYPE(obj)));
    }
}

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

  str = SCHEME_STR_VAL (string);
  if ( escaped )
    {
      *cp++ = '"';
    }
  while ( *str )
    {
      if (escaped && ((*str == '"') || (*str == '\\')))
	{
	  *cp++ = '\\';
	}
      *cp++ = *str++;
    }
  if ( escaped )
    {
      *cp++ = '"';
    }
  *cp = '\0';
}

static void
print_pair (char *cp, Scheme_Object *pair, int escaped)
{
  Scheme_Object *cdr;

  *cp++ = '(';
  print (cp, SCHEME_CAR (pair), escaped);
  while (*cp) cp++;
  cdr = SCHEME_CDR (pair);
  while ((cdr != scheme_null) && (SCHEME_TYPE(cdr) == scheme_pair_type))
    {
      *cp++ = ' ';
      print (cp, SCHEME_CAR (cdr), escaped);
      while (*cp) cp++;
      cdr = SCHEME_CDR (cdr);
    }
  if (cdr != scheme_null)
    {
      *cp++ = ' '; *cp++ = '.'; *cp++ = ' ';    /* " . " */
      print (cp, cdr, escaped);
      while (*cp) cp++;
    }
  *cp++ = ')';
  *cp = '\0';
}

static void
print_vector (char *cp, Scheme_Object *vec, int escaped)
{
  int i;

  *cp++ = '#'; *cp++ = '(';   /* "#(" */
  for ( i=0 ; i<SCHEME_VEC_SIZE(vec) ; ++i )
    {
      print (cp, SCHEME_VEC_ELS(vec)[i], escaped);
      while (*cp) cp++;
      if (i<SCHEME_VEC_SIZE(vec)-1)
	{
          *cp++ = ' ';
	}
    }
  *cp++ = ')';
  *cp = '\0';
}

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

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

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