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

/* globals */
Scheme_Object *scheme_eof;
Scheme_Object *scheme_eof_type;
Scheme_Object *scheme_input_port_type, *scheme_output_port_type;

/* locals */
static Scheme_Object *cur_in_port;
static Scheme_Object *cur_out_port;

static Scheme_Object *scheme_make_eof (void);
static Scheme_Object *call_with_input_file (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_output_file (int argc, Scheme_Object *argv[]);
static Scheme_Object *input_port_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *output_port_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *current_input_port (int argc, Scheme_Object *argv[]);
static Scheme_Object *current_output_port (int argc, Scheme_Object *argv[]);
static Scheme_Object *with_input_from_file (int argc, Scheme_Object *argv[]);
static Scheme_Object *with_output_to_file (int argc, Scheme_Object *argv[]);
static Scheme_Object *open_input_file (int argc, Scheme_Object *argv[]);
static Scheme_Object *open_output_file (int argc, Scheme_Object *argv[]);
static Scheme_Object *close_input_port (int argc, Scheme_Object *argv[]);
static Scheme_Object *close_output_port (int argc, Scheme_Object *argv[]);
static Scheme_Object *read (int argc, Scheme_Object *argv[]);
static Scheme_Object *read_char (int argc, Scheme_Object *argv[]);
static Scheme_Object *peek_char (int argc, Scheme_Object *argv[]);
static Scheme_Object *eof_object_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_ready_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *write (int argc, Scheme_Object *argv[]);
static Scheme_Object *newline (int argc, Scheme_Object *argv[]);
static Scheme_Object *write_char (int argc, Scheme_Object *argv[]);
static Scheme_Object *load (int argc, Scheme_Object *argv[]);
/* non-standard */
static Scheme_Object *flush_output (int argc, Scheme_Object *argv[]);

void 
scheme_init_port (Scheme_Env *env)
{
  scheme_eof_type = scheme_make_type ("<eof>");
  scheme_add_global ("<eof>", scheme_eof_type, env);
  scheme_eof = scheme_make_eof ();
  scheme_input_port_type = scheme_make_type ("<input-port>");
  scheme_add_global ("<input-port>", scheme_input_port_type, env);
  scheme_output_port_type = scheme_make_type ("<output-port>");
  cur_in_port = scheme_make_input_port (stdin);
  cur_out_port = scheme_make_output_port (stdout);
  scheme_add_global ("<output-port>", scheme_output_port_type, env);
  scheme_add_global ("call-with-input-file", scheme_make_prim (call_with_input_file), env);
  scheme_add_global ("call-with-output-file", scheme_make_prim (call_with_output_file), env);
  scheme_add_global ("input-port?", scheme_make_prim (input_port_p), env);
  scheme_add_global ("output-port?", scheme_make_prim (output_port_p), env);
  scheme_add_global ("current-input-port", scheme_make_prim (current_input_port), env);
  scheme_add_global ("current-output-port", scheme_make_prim (current_output_port), env);
  scheme_add_global ("with-input-from-file", scheme_make_prim (with_input_from_file), env);
  scheme_add_global ("with-output-to-file", scheme_make_prim (with_output_to_file), env);
  scheme_add_global ("open-input-file", scheme_make_prim (open_input_file), env);
  scheme_add_global ("open-output-file", scheme_make_prim (open_output_file), env);
  scheme_add_global ("close-input-port", scheme_make_prim (close_input_port), env);
  scheme_add_global ("close-output-port", scheme_make_prim (close_output_port), env);
  scheme_add_global ("read", scheme_make_prim (read), env);
  scheme_add_global ("read-char", scheme_make_prim (read_char), env);
  scheme_add_global ("peek-char", scheme_make_prim (peek_char), env);
  scheme_add_global ("eof-object?", scheme_make_prim (eof_object_p), env);
  scheme_add_global ("char-ready?", scheme_make_prim (char_ready_p), env);
  scheme_add_global ("write", scheme_make_prim (write), env);
  scheme_add_global ("display", scheme_make_prim (display), env);
  scheme_add_global ("newline", scheme_make_prim (newline), env);
  scheme_add_global ("write-char", scheme_make_prim (write_char), env);
  scheme_add_global ("load", scheme_make_prim (load), env);
  scheme_add_global ("flush-output", scheme_make_prim (flush_output), env);
}

static Scheme_Object *
scheme_make_eof (void)
{
  Scheme_Object *eof;

  eof = scheme_alloc_object ();
  SCHEME_TYPE (eof) = scheme_eof_type;
  return (eof);
}

Scheme_Object *
scheme_make_input_port (FILE *fp)
{
  Scheme_Object *port;

  port = scheme_alloc_object ();
  SCHEME_TYPE(port) = scheme_input_port_type;
  SCHEME_PTR_VAL(port) = fp;
  return (port);
}

Scheme_Object *
scheme_make_output_port (FILE *fp)
{
  Scheme_Object *port;

  port = scheme_alloc_object ();
  SCHEME_TYPE(port) = scheme_output_port_type;
  SCHEME_PTR_VAL(port) = fp;
  return (port);
}

static Scheme_Object *
call_with_input_file (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  char *filename;
  Scheme_Object *ret, *port;

  SCHEME_ASSERT ((argc == 2), "call-with-input-file: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP (argv[0]), 
		 "call-with-input-file: first arg must be a string");
  SCHEME_ASSERT (SCHEME_PROCP (argv[1]),
		 "call-with-input-file: second arg must be a procedure");
  filename = SCHEME_STR_VAL (argv[0]);
  fp = fopen (filename, "r");
  if (! fp)
    {
      scheme_signal_error ("cannot open file for input: %s", filename);
    }
  port = scheme_make_input_port (fp);
  ret = scheme_apply (argv[1], scheme_make_pair (port, scheme_null));
  fclose (fp);
  return (ret);
}

static Scheme_Object *
call_with_output_file (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  char *filename;
  Scheme_Object *ret, *port;

  SCHEME_ASSERT ((argc == 2), "call-with-output-file: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP (argv[0]), 
		 "call-with-output-file: first arg must be a string");
  SCHEME_ASSERT (SCHEME_PROCP (argv[1]),
		 "call-with-output-file: second arg must be a procedure");
  filename = SCHEME_STR_VAL (argv[0]);
  fp = fopen (filename, "w");
  if (! fp)
    {
      scheme_signal_error ("cannot open file for output: %s", filename);
    }
  port = scheme_make_output_port (fp);
  ret = scheme_apply (argv[1], scheme_make_pair (port, scheme_null));
  fclose (fp);
  return (ret);
}

static Scheme_Object *
input_port_p (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "input-port?: wrong number of args");
  return (SCHEME_INPORTP(argv[0]) ? scheme_true : scheme_false);
}

static Scheme_Object *
output_port_p (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "output-port?: wrong number of args");
  return (SCHEME_OUTPORTP(argv[0]) ? scheme_true : scheme_false);
}

static Scheme_Object *
current_input_port (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 0), "current-input-port: wrong number of args");
  return (cur_in_port);
}

static Scheme_Object *
current_output_port (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 0), "current-output-port: wrong number of args");
  return (cur_out_port);
}

static Scheme_Object *
with_input_from_file (int argc, Scheme_Object *argv[])
{
  FILE *fp, *old;
  char *filename;
  Scheme_Object *ret;

  SCHEME_ASSERT ((argc == 2), "with-input-from-file: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP (argv[0]), 
		 "with-input-from-file: first arg must be a string");
  SCHEME_ASSERT (SCHEME_PROCP (argv[1]),
		 "with-input-from-file: second arg must be a procedure");
  filename = SCHEME_STR_VAL (argv[0]);
  fp = fopen (filename, "r");
  if (! fp)
    {
      scheme_signal_error ("cannot open file for input: %s", filename);
    }
  old = (FILE *)SCHEME_PTR_VAL (cur_in_port);
  SCHEME_PTR_VAL (cur_in_port) = fp;
  ret = scheme_apply (argv[1], scheme_null);
  SCHEME_PTR_VAL (cur_in_port) = old;
  fclose (fp);
  return (ret);
}

static Scheme_Object *
with_output_to_file (int argc, Scheme_Object *argv[])
{
  FILE *fp, *old;
  char *filename;
  Scheme_Object *ret;

  SCHEME_ASSERT ((argc == 2), "with-output-to-file: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP (argv[0]), 
		 "with-output-to-file: first arg must be a string");
  SCHEME_ASSERT (SCHEME_PROCP (argv[1]),
		 "with-output-to-file: second arg must be a procedure");
  filename = SCHEME_STR_VAL (argv[0]);
  fp = fopen (filename, "w");
  if (! fp)
    {
      scheme_signal_error ("cannot open file for output: %s", filename);
    }
  old = (FILE *)SCHEME_PTR_VAL (cur_out_port);
  SCHEME_PTR_VAL (cur_out_port) = fp;
  ret = scheme_apply (argv[1], scheme_null);
  SCHEME_PTR_VAL (cur_out_port) = old;
  fclose (fp);
  return (ret);
}

static Scheme_Object *
open_input_file (int argc, Scheme_Object *argv[])
{
  FILE *fp;

  SCHEME_ASSERT ((argc == 1), "open-input-file: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP(argv[0]), "open-input-file: arg must be a filename");
  fp = fopen (SCHEME_STR_VAL(argv[0]), "r");
  if (!fp)
    {
      scheme_signal_error ("Cannot open input file %s", SCHEME_STR_VAL(argv[0]));
    }
  return (scheme_make_input_port (fp));
}

static Scheme_Object *
open_output_file (int argc, Scheme_Object *argv[])
{
  FILE *fp;

  SCHEME_ASSERT ((argc == 1), "open-output-file: wrong number of args");
  SCHEME_ASSERT (SCHEME_STRINGP(argv[0]), "open-output-file: arg must be a filename");
  fp = fopen (SCHEME_STR_VAL(argv[0]), "w");
  if (!fp)
    {
      scheme_signal_error ("Cannot open output file %s", SCHEME_STR_VAL(argv[0]));
    }
  return (scheme_make_output_port (fp));
}

static Scheme_Object *
close_input_port (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "close-input-port: wrong number of args");
  SCHEME_ASSERT (SCHEME_INPORTP(argv[0]), "close-input-port: arg must be an input port");
  fclose ((FILE *)SCHEME_PTR_VAL (argv[0]));
  return (scheme_true);
}

static Scheme_Object *
close_output_port (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "close-output-port: wrong number of args");
  SCHEME_ASSERT (SCHEME_OUTPORTP(argv[0]), "close-output-port: arg must be an output port");
  fclose ((FILE *)SCHEME_PTR_VAL (argv[0]));
  return (scheme_true);
}

static Scheme_Object *
read (int argc, Scheme_Object *argv[])
{
  FILE *fp;

  SCHEME_ASSERT ((argc==0 || argc==1), "read: wrong number of args");
  if (argc == 1)
    {
      SCHEME_ASSERT (SCHEME_INPORTP(argv[0]), "read: arg must be an input port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[0]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_in_port);
    }
  return (scheme_read (fp));
}

static Scheme_Object *
read_char (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  int ch;

  SCHEME_ASSERT ((argc==0 || argc==1), "read-char: wrong number of args");
  if (argc == 1)
    {
      SCHEME_ASSERT (SCHEME_INPORTP(argv[0]), "read-char: arg must be an input port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[0]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_in_port);
    }
  ch = fgetc (fp);
  if (ch == EOF)
    {
      return (scheme_eof);
    }
  else
    {
      return (scheme_make_char (ch));
    }
}

static Scheme_Object *
peek_char (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  int ch;

  SCHEME_ASSERT ((argc==0 || argc==1), "peek-char: wrong number of args");
  if (argc == 1)
    {
      SCHEME_ASSERT (SCHEME_INPORTP(argv[0]), "peek-char: arg must be an input port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[0]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_in_port);
    }
  ch = fgetc (fp);
  if (ch == EOF)
    {
      return (scheme_eof);
    }
  else
    {
      ungetc (ch, fp);
      return (scheme_make_char (ch));
    }
}

static Scheme_Object *
eof_object_p (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "eof-object?: wrong number of args");
  return (SCHEME_EOFP(argv[0]) ? scheme_true : scheme_false);
}

static Scheme_Object *
char_ready_p (int argc, Scheme_Object *argv[])
{
  FILE *fp;

  SCHEME_ASSERT ((argc==0 || argc==1), "char-ready?: wrong number of args");
  if (argc == 1)
    {
      SCHEME_ASSERT (SCHEME_INPORTP(argv[0]), "char-ready?: arg must be an input port");
      fp = (FILE *)SCHEME_PTR_VAL(argv[0]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_in_port);
    }
#if _STDIO_USES_IOSTREAM
  /* esp for linux */
  return (fp->_IO_read_end > fp->_IO_read_ptr) ? scheme_true : scheme_false;
#else
  return ((fp->_cnt) ? scheme_true : scheme_false);
#endif
}

static Scheme_Object *
write (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]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_out_port);
    }
  scheme_write (fp, argv[0]);
  return (scheme_true);
}

Scheme_Object *
display (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]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_out_port);
    }
  scheme_display (fp, argv[0]);
  return (scheme_true);
}

static Scheme_Object *
newline (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]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_out_port);
    }
  fprintf (fp, "\n"); 
  return (scheme_true);
}

static Scheme_Object *
write_char (int argc, Scheme_Object *argv[])
{
  FILE *fp;
  
  SCHEME_ASSERT ((argc==1 || argc==2), "write-char: wrong number of args");
  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]);
    }
  else
    {
      fp = (FILE *)SCHEME_PTR_VAL(cur_out_port);
    }
  SCHEME_ASSERT (SCHEME_CHARP(argv[0]), "write-char: first arg must be a character");
  fprintf (fp, "%c", SCHEME_CHAR_VAL (argv[0]));
  return (scheme_true);
}

static Scheme_Object *
load (int argc, Scheme_Object *argv[])
{
  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]);
  printf ("; loading %s\n", filename);
  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);
    }
  printf ("; done loading %s\n", filename);
  return (ret);
}

static Scheme_Object *
flush_output (int argc, Scheme_Object *argv[])
{
  SCHEME_ASSERT ((argc == 1), "flush-output: wrong number of args");
  SCHEME_ASSERT (SCHEME_OUTPORTP (argv[0]), "flush-output: arg must be an output port");
  fflush ((FILE *)SCHEME_PTR_VAL (argv[0]));
  return (scheme_true);
}
