io.c

/*
 * io.c -- Implementation of Scheme's input/output
 *
 * (C) m.b (Matthias Blume); May 1992, HUB; Nov 1993 PU/CS
 *         Humboldt-University of Berlin
 *         Princeton University, Dept. of Computer Science
 *
 * $Id: io.c,v 2.12 1994/11/12 22:20:21 blume Exp $
 */

# include "rcs.h"
RCSID ("$Id: io.c,v 2.12 1994/11/12 22:20:21 blume Exp $")

# include <stdio.h>
# include <stdlib.h>
# include <string.h>
# include <errno.h>

# include "io.h"
# include "Port.h"
# include "storext.h"
# include "Boolean.h"
# include "Cont.h"
# include "String.h"
# include "Numeric.h"
# include "mode.h"
# include "type.h"
# include "tmpstring.h"
# include "except.h"
# include "reader.h"

# include "builtins.tab"

# include "realloc.h"

# define ERRORSTRING (errno == 0 ? "unknown reason" : strerror (errno))

static
ScmPort *current_input_port (void)
{
  ScmPort *port;

  if ((port = ScmMode (SCM_INPUT_PORT_MODE)) == NULL)
    port = ScmStdinPort;
  return port;
}

static
ScmPort *current_output_port (void)
{
  ScmPort *port;

  if ((port = ScmMode (SCM_OUTPUT_PORT_MODE)) == NULL)
    port = ScmStdoutPort;
  return port;
}

int file_getc (void *file)
{
  return getc ((FILE *)file);
}

void file_ungetc (int c, void *file)
{
  ungetc (c, (FILE *)file);
}

void file_putc (int c, void *file)
{
  errno = 0;
  if (putc (c, (FILE *)file) == EOF)
    error ("write error (%s)", ERRORSTRING);
}

static unsigned
  input (const char *name, unsigned (*proc) (ScmPort *), unsigned argcnt)
{
  ScmPort *port;
  unsigned r;

  if (argcnt > 1)
    error ("wrong arg cnt (%u) to primitive %s", (unsigned) argcnt, name);
  if (argcnt == 1) {
    port = POP ();
    if (ScmTypeOf (port) != ScmType (Port) || !ScmPortAllowsInput (port))
      badarg (name, port);
  } else
    port = current_input_port ();
  ScmInstantInterruptHandling (1);
  r = (*proc) (port);
  ScmInstantInterruptHandling (0);
  return r;
}

unsigned ScmPrimitiveRead (unsigned argcnt)
{
  return input ("read", ScmPortRead, argcnt);
}

unsigned ScmPrimitiveReadChar (unsigned argcnt)
{
  return input ("read-char", ScmPortReadChar, argcnt);
}

unsigned ScmPrimitivePeekChar (unsigned argcnt)
{
  return input ("peek-char", ScmPortPeekChar, argcnt);
}

unsigned ScmPrimitiveCharReadyP (unsigned argcnt)
{
  return input ("char-ready?", ScmPortCharReadyP, argcnt);
}

static unsigned
  output1 (const char *name, unsigned (*proc) (ScmPort *, void *),
	   unsigned argcnt)
{
  ScmPort *port;
  void *tmp;

  if (argcnt < 1 || argcnt > 2)
    error ("wrong arg cnt (%u) to primitive %s", (unsigned) argcnt, name);
  tmp = POP ();
  if (argcnt == 2) {
    port = POP ();
    if (ScmTypeOf (port) != ScmType (Port) || !ScmPortAllowsOutput (port))
      badarg (name, port);
  } else
    port = current_output_port ();
  return (*proc) (port, tmp);
}

static unsigned
  output0 (const char *name, unsigned (*proc) (ScmPort *), unsigned argcnt)
{
  ScmPort *port;

  if (argcnt > 1)
    error ("wrong arg cnt (%u) to primitive %s", (unsigned) argcnt, name);
  if (argcnt == 1) {
    port = POP ();
    if (ScmTypeOf (port) != ScmType (Port) || !ScmPortAllowsOutput (port))
      badarg (name, port);
  } else
    port = current_output_port ();
  return (*proc) (port);
}

unsigned ScmPrimitiveWriteChar (unsigned argcnt)
{
  return output1 ("write-char", ScmPortWriteChar, argcnt);
}

unsigned ScmPrimitiveWrite (unsigned argcnt)
{
  return output1 ("write", ScmPortWrite, argcnt);
}

unsigned ScmPrimitiveDisplay (unsigned argcnt)
{
  return output1 ("display", ScmPortDisplay, argcnt);
}

unsigned ScmPrimitiveNewline (unsigned argcnt)
{
  return output0 ("newline", ScmPortNewline, argcnt);
}

unsigned ScmPrimitiveFlush (unsigned argcnt)
{
  return output0 ("flush", ScmPortFlush, argcnt);
}

unsigned ScmPrimitiveWPortC (void)
{
  ScmDirtyModeCache (ScmCC->u.c.mode_id);
  ScmRevertToFatherContinuation (1);
  return 0;
}

unsigned ScmPrimitiveWithInputFromPort (unsigned argcnt)
{
  void *port;

  port = POP ();
  if (ScmTypeOf (port) != ScmType (Port) || !ScmPortAllowsInput (port))
    badarg ("with-input-from-port", port);
  ScmPushPrimitiveContinuation (port, 1);
  ScmSetMode (SCM_INPUT_PORT_MODE, ScmCC->u.c.environ);
  Push (CPOP (ScmCC->father));
  return 1;
}

unsigned ScmPrimitiveWithOutputToPort (unsigned argcnt)
{
  void *port;

  port = POP ();
  if (ScmTypeOf (port) != ScmType (Port) || !ScmPortAllowsOutput (port))
    badarg ("call-output-to-port", port);
  ScmPushPrimitiveContinuation (port, 1);
  ScmSetMode (SCM_OUTPUT_PORT_MODE, ScmCC->u.c.environ);
  Push (CPOP (ScmCC->father));
  return 1;
}

/*ARGSUSED*/
unsigned ScmPrimitiveInputPortP (unsigned argcnt)
{
  void *tmp = PEEK ();

  SET_TOP (
    ScmTypeOf (tmp) == ScmType (Port) && ScmPortAllowsInput (tmp)
	? &ScmTrue
	: &ScmFalse);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveOutputPortP (unsigned argcnt)
{
  void *tmp = PEEK ();

  SET_TOP (
    ScmTypeOf (tmp) == ScmType (Port) && ScmPortAllowsOutput (tmp)
	? &ScmTrue
	: &ScmFalse);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveCurrentInputPort (unsigned argcnt)
{
  void *tmp = current_input_port ();
  Push (tmp);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveCurrentOutputPort (unsigned argcnt)
{
  void *tmp = current_output_port ();
  Push (tmp);
  return 0;
}

static unsigned open_file
 (unsigned argcnt, const char *name, ScmPort *(*proc) (const char *, int, int))
{
  ScmString *fn;
  ScmPort *port;
  void *tmp;
  int bin = 0, updt = 0, buf = _IOFBF;

  if (argcnt < 1 || argcnt > 4)
    error ("bad argcnt (%u) to primitive procedure %s", argcnt, name);
  tmp = POP ();
  if (ScmTypeOf (tmp) != ScmType (String))
    badarg (name, tmp);
  fn = tmp;
  if (argcnt > 1) {
    updt = (POP () != &ScmFalse);
    if (argcnt > 2) {
      bin = (POP () != &ScmFalse);
      if (argcnt > 3) {
	tmp = POP ();
	if (tmp == &ScmTrue)
	  buf = _IOFBF;
	else if (tmp == &ScmFalse)
	  buf = _IONBF;
	else
	  buf = _IOLBF;
      }
    }
  }
  port = (*proc) (tmpstring (fn->array, fn->length), bin, updt);
  errno = 0;
  if (setvbuf (ScmPortToStreamPtr (port), NULL, buf, BUFSIZ) != 0)
    error ("buffer request for file %w failed (%s)", fn, ERRORSTRING);
  PUSH (port);
  return 0;
}  

unsigned ScmPrimitiveOpenInputFile (unsigned argcnt)
{
  return open_file (argcnt, "open-input-file", ScmOpenInputFile);
}

unsigned ScmPrimitiveOpenOutputFile (unsigned argcnt)
{
  return open_file (argcnt, "open-output-file", ScmOpenOutputFile);
}

unsigned ScmPrimitiveOpenAppendFile (unsigned argcnt)
{
  return open_file (argcnt, "open-append-file", ScmOpenAppendFile);
}

/*ARGSUSED*/
unsigned ScmPrimitiveOpenTemporaryFile (unsigned argcnt)
{
  Push (ScmOpenTemporaryFile ());
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveOpenInputGeneric (unsigned argcnt)
{
  void *rd = POP ();
  void *rdc = POP ();
  void *pkc = POP ();
  void *chr = POP ();
  void *cl = PEEK ();

  SET_TOP (ScmOpenInputGeneric (rd, rdc, pkc, chr, cl));
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveOpenOutputGeneric (unsigned argcnt)
{
  void *wr = POP ();
  void *dp = POP ();
  void *wc = POP ();
  void *nl = POP ();
  void *fl = POP ();
  void *cl = PEEK ();

  SET_TOP (ScmOpenOutputGeneric (wr, dp, wc, nl, fl, cl));
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveClosePort (unsigned argcnt)
{
  void *port = POP ();

  if (ScmTypeOf (port) != ScmType (Port))
    badarg ("close-port", port);
  return ScmPortClose (port);
}

/*ARGSUSED*/
unsigned ScmPrimitiveStandardPort (unsigned argcnt)
{
  unsigned i = ScmNumberToUShort (PEEK (), "standard-port");

  if (i > 2)
    error ("bad number to primitive procedure standard-port: %w", PEEK ());
  SET_TOP (i == 0 ? ScmStdinPort : i == 1 ? ScmStdoutPort : ScmStderrPort);
  return 0;
}

static
unsigned string_write_display (void (*proc) (void *, putc_proc, void *))
{
  const char *msg;
  size_t len;
  ScmString *string;

  tmpbuf_reset ();
  (*proc) (PEEK (), tmpbuf_putc, NULL);
  msg = tmpbuf_get (&len);
  SCM_VNEW (string, String, len, char);
  string->length = len;
  memcpy (string->array, msg, len);
  SET_TOP (string);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveStringWrite (unsigned argcnt)
{
  return string_write_display (write_object);
}

/*ARGSUSED*/
unsigned ScmPrimitiveStringDisplay (unsigned argcnt)
{
  return string_write_display (display_object);
}

static char *sr_buf = NULL;
static size_t sr_buf_len = 0;
static size_t sr_end, sr_pos;

static int initialized = 0;

static void deallocate_all (void)
{
  if (sr_buf != NULL)
    free (sr_buf);
}

static void initialize (void)
{
  if (!initialized) {
    initialized = 1;
    atexit (deallocate_all);
  }
}

/*ARGSUSED*/
static int sr_getc (void *ignore)
{
  return sr_pos >= sr_end ? EOF : sr_buf [sr_pos++];
}

/*ARGSUSED*/
static void sr_ungetc (int c, void *ignore)
{
  if (sr_pos > 0)
    sr_buf [--sr_pos] = c;
}

/*ARGSUSED*/
unsigned ScmPrimitiveStringRead (unsigned argcnt)
{
  void *tmp = PEEK ();
  ScmString *string;
  char *tbuf;
  unsigned length;

  if (ScmMultiCont (ScmCC) == 0)
    error ("string-read: continuation does not accept multiple values");
  if (ScmTypeOf (tmp) != ScmType (String))
    badarg ("string-read", tmp);

  string = tmp;
  length = string->length;

  if (sr_buf_len < length) {
    initialize ();
    tbuf = REALLOC (sr_buf, length);
    if (tbuf == NULL)
      reset ("Out of memory in string-read");
    sr_buf = tbuf;
    sr_buf_len = length;
  }

  sr_pos = 0;
  sr_end = length;
  memcpy (sr_buf, string->array, length);

  tmp = ScmRead (sr_getc, sr_ungetc, NULL);
  SET_TOP (tmp);

  length = sr_end - sr_pos;
  SCM_VNEW (string, String, length, char);
  string->length = length;
  memcpy (string->array, sr_buf + sr_pos, length);

  tmp = PEEK ();
  SET_TOP (string);
  Push (tmp);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveRemoveFile (unsigned argcnt)
{
  void *tmp = PEEK ();
  ScmString *str;

  if (ScmTypeOf (tmp) != ScmType (String))
    badarg ("remove-file", tmp);
  str = tmp;
  errno = 0;
  if (remove (tmpstring (str->array, str->length)) != 0)
    error ("cannot remove file %w (%s)", tmp, ERRORSTRING);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveRenameFile (unsigned argcnt)
{
  void *from = POP ();
  void *to = PEEK ();
  char ffn [FILENAME_MAX + 1];
  ScmString *fstr, *tstr;

  if (ScmTypeOf (from) != ScmType (String))
    badarg ("rename-file", from);
  if (ScmTypeOf (to) != ScmType (String))
    badarg ("rename-file", to);

  fstr = from;
  tstr = to;
  if (fstr->length > FILENAME_MAX)
    restriction ("length of filename in (rename-file %w ...) exeeds limit",
		 from);
  memcpy (ffn, fstr->array, fstr->length);
  ffn [fstr->length] = '\0';
  errno = 0;
  if (rename (ffn, tmpstring (tstr->array, tstr->length)) != 0)
    error ("cannot rename file %w to %w (%s)", from, to, ERRORSTRING);
  return 0;
}

/*ARGSUSED*/
unsigned ScmPrimitiveSeekAndTell (unsigned argcnt)
{
  void *port;
  void *offset;
  void *whence;

  port = POP ();
  offset = POP ();
  whence = PEEK ();
  if (ScmTypeOf (port) != ScmType (Port))
    badarg ("seek-and-tell", port);
  offset = ScmLongToNumber
             (ScmPortSeekAndTell
                (port, ScmNumberToLong (offset, "seek-and-tell"), whence));
  SET_TOP (offset);
  return 0;
}