Port.c

/*
 * Port.c -- Implementation of Scheme ports
 *
 * (C) m.b (Matthias Blume); May 13, HUB; Jan 1993 PU/CS
 *         Humboldt-University of Berlin
 *         Princeton University, Dept. of Computer Science
 *
 * $Id: Port.c,v 2.15 1994/11/12 22:13:36 blume Exp $
 */

# include "rcs.h"
RCSID ("$Id: Port.c,v 2.15 1994/11/12 22:13:36 blume Exp $")

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

# include "storext.h"
# include "Port.h"
# include "identifier.h"
# include "except.h"
# include "type.h"

# include "Boolean.h"
# include "Character.h"
# include "Cont.h"
# include "io.h"
# include "reader.h"

# include "realloc.h"

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

typedef enum {
  CLOSED,
  INPUT,
  OUTPUT,
  UPDATE_R,
  UPDATE_W,
  END_OF_INPUT			/* for INPUT FILE_PORTs only */
} port_state;

typedef enum {
  FILE_PORT,
  GENERIC_PORT
} port_type;

struct ScmPort {
  MEM_descriptor _;
  port_state state;
  port_type type;
  union {
    FILE *file;
    struct {
      void *read;
      void *read_char;
      void *peek_char;
      void *char_ready;
      void *close;
    } gin;
    struct {
      void *write;
      void *display;
      void *write_char;
      void *newline;
      void *flush;
      void *close;
    } gout;
  } u;
};

/*
 * Some stuff to overcome the annoying restrictions imposed by the C library
 * when dealing with read/write files.
 */
# define XABLE(p,wrong,right) ((void) ((p)->state == (wrong) \
				       ? (fseek ((p)->u.file, 0L, SEEK_CUR), \
					  ((p)->state = (right))) \
				       : 0))
# define READABLE(p) XABLE (p, UPDATE_W, UPDATE_R)
# define WRITABLE(p) XABLE (p, UPDATE_R, UPDATE_W) 

static void iterator (void *vport, MEM_visitor proc, void *cd)
{
  ScmPort *port = vport;

  if (port->state == CLOSED || port->type == FILE_PORT)
    return;
  if (port->state == INPUT) {
    (* proc) ((void *)&port->u.gin.read, cd);
    (* proc) ((void *)&port->u.gin.read_char, cd);
    (* proc) ((void *)&port->u.gin.peek_char, cd);
    (* proc) ((void *)&port->u.gin.char_ready, cd);
    (* proc) ((void *)&port->u.gin.close, cd);
  } else {
    (* proc) ((void *)&port->u.gout.write, cd);
    (* proc) ((void *)&port->u.gout.display, cd);
    (* proc) ((void *)&port->u.gout.write_char, cd);
    (* proc) ((void *)&port->u.gout.newline, cd);
    (* proc) ((void *)&port->u.gout.flush, cd);
    (* proc) ((void *)&port->u.gout.close, cd);
  }
}

static void dumper (void *vport, FILE *file)
{
  ScmPort *port = vport;
  int c;

  if (port->type == FILE_PORT)
    if (port->state == CLOSED)
      c = 'c';
    else if (port->u.file == stdin)
      c = 'i';
    else if (port->u.file == stdout)
      c = 'o';
    else if (port->u.file == stderr)
      c = 'e';
    else
      c = 'c';
  else if (port->state == CLOSED)
    c = 'C';
  else if (port->state == INPUT)
    c = 'I';
  else
    c = 'O';

  putc (c, file);
}

static ScmPort **ports = NULL;
static unsigned int ports_len = 0;
static int ports_dirty = 0;

static void *excavator (FILE *file)
{
  unsigned i;
  int c = getc (file);
  ScmPort * res;

  SCM_NEW (res, Port);
  switch (c) {
  case 'c':
    res->type = FILE_PORT;
    res->state = CLOSED;
    break;
  case 'i':
    res->type = FILE_PORT;
    res->state = INPUT;
    res->u.file = stdin;
    break;
  case 'o':
    res->type = FILE_PORT;
    res->state = OUTPUT;
    res->u.file = stdout;
    break;
  case 'e':
    res->type = FILE_PORT;
    res->state = OUTPUT;
    res->u.file = stderr;
    break;
  case 'C':
    res->type = GENERIC_PORT;
    res->state = CLOSED;
    break;
  case 'I':
    res->type = GENERIC_PORT;
    res->state = INPUT;
    break;
  case 'O':
    res->type = GENERIC_PORT;
    res->state = OUTPUT;
    break;
  default:
    fatal ("Bad memory dump file (Port)");
  }
  if (ports_dirty) {
    ports_dirty = 0;
    for (i = 0; i < ports_len; i++)
      ports [i] = NULL;
  }
  return res;
}

static void display (void *vport, putc_proc pp, void *cd)
{
  ScmPort *port = vport;
  char buf [32], num [8];
  char *tname, *sname;

  sname = port->state == CLOSED
           ? "closed"
	   : port->state == INPUT
	     ? "input"
	     : port->state == OUTPUT
	       ? "output"
	       : "update";
  if (port->type == FILE_PORT)
    if (port->u.file == stdin)
      tname = "stdin";
    else if (port->u.file == stdout)
      tname = "stdout";
    else if (port->u.file == stderr)
      tname = "stderr";
    else if (port->state == CLOSED)
      tname = "-1";
    else {
      sprintf (num, "%d", fileno (port->u.file));
      tname = num;
    }
  else
    tname = "generic";

  sprintf (buf, "#<Port %s %s>", tname, sname);
  putc_string (buf, pp, cd);
}

# define INCR 20

static ScmPort *new_port (void)
{
  unsigned i, j;
  ScmPort **n, *res;

  for (i = 0; i < ports_len; i++)
    if (ports [i] == NULL)
      break;
  if (i == ports_len) {
    n = REALLOC (ports, (INCR + ports_len) * sizeof (ScmPort *));
    if (n == NULL)
      reset ("new_port failed (out of memory)");
    ports = n;
    for (j = 0; j < INCR; j++)
      ports [ports_len + j] = NULL;
    ports_len += INCR;
  }
  SCM_NEW (res, Port);
  ports [i] = res;
  ports_dirty = 1;
  return res;
}

ScmPort *ScmStdinPort = NULL;
ScmPort *ScmStdoutPort = NULL;
ScmPort *ScmStderrPort = NULL;
static void *save_1 = NULL;
static void *save_2 = NULL;
static void *save_3 = NULL;
static void *save_4 = NULL;
static void *save_5 = NULL;
static void *save_6 = NULL;

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

static void module_init (void)
{
  atexit (deallocate_all);

  MEM_root_var (ScmStdinPort);
  MEM_root_var (ScmStdoutPort);
  MEM_root_var (ScmStderrPort);
  MEM_root_var (save_1);
  MEM_root_var (save_2);
  MEM_root_var (save_3);
  MEM_root_var (save_4);
  MEM_root_var (save_5);
  MEM_root_var (save_6);

  SCM_NEW (ScmStdinPort, Port);
  ScmStdinPort->type = FILE_PORT;
  ScmStdinPort->state = INPUT;
  ScmStdinPort->u.file = stdin;

  SCM_NEW (ScmStdoutPort, Port);
  ScmStdoutPort->type = FILE_PORT;
  ScmStdoutPort->state = OUTPUT;
  ScmStdoutPort->u.file = stdout;

  SCM_NEW (ScmStderrPort, Port);
  ScmStderrPort->type = FILE_PORT;
  ScmStderrPort->state = OUTPUT;
  ScmStderrPort->u.file = stderr;
}

static void after_gc (void)
{
  unsigned i;
  ScmPort *n;

  for (i = 0; i < ports_len; i++) {
    if (ports [i] == NULL)
	/* ok */
	;
    else if (ports [i] != (n = MEM_new_location_of (ports [i])))
      ports [i] = n;
    else {
      warning ("implicitly closing stale file port");
      fclose (ports [i]->u.file);
      ports [i] = NULL;
    }
  }
}

MEM_VECTOR (Port,
	    MEM_UNITS (sizeof (ScmPort)), MEM_NULL_measure,
	    iterator, dumper, excavator, MEM_NULL_revisor,
	    module_init, MEM_NULL_task, after_gc,
	    EXT (SCM_NO_NUMBER,
		 cannot_cvt_real, display, display, NULL_eq, NULL_eq));

int ScmPortAllowsInput (ScmPort *port)
{
  return port->state != CLOSED && port->state != OUTPUT;
}

int ScmPortAllowsOutput (ScmPort *port)
{
  return port->state != CLOSED && port->state != INPUT;
}

FILE *ScmPortToStreamPtr (ScmPort *port)
{
  return port->u.file;
}

ScmPort *ScmOpenInputFile (const char *filename, int bin, int updt)
{
  FILE *fp;
  ScmPort * res;
  char mode [4] = { 'r' };
  int mode_idx = 1;

  bin && (mode [mode_idx++] = 'b');
  updt && (mode [mode_idx++] = '+');
  mode [mode_idx] = '\0';
  errno = 0;
  if ((fp = fopen (filename, mode)) == NULL)
    error ("open \"%s\" for input failed (%s)", filename, ERRORSTRING);
  res = new_port ();
  res->type = FILE_PORT;
  res->u.file = fp;
  res->state = updt ? UPDATE_R : INPUT;
  return res;
}

ScmPort *ScmOpenOutputFile (const char *filename, int bin, int updt)
{
  FILE *fp;
  ScmPort * res;
  char mode [4] = { 'w' };
  int mode_idx = 1;

  bin && (mode [mode_idx++] = 'b');
  updt && (mode [mode_idx++] = '+');
  mode [mode_idx] = '\0';
  errno = 0;
  if ((fp = fopen (filename, mode)) == NULL)
    error ("open \"%s\" for output failed (%s)", filename, ERRORSTRING);
  res = new_port ();
  res->type = FILE_PORT;
  res->u.file = fp;
  res->state = updt ? UPDATE_W : OUTPUT;
  return res;
}

ScmPort *ScmOpenAppendFile (const char *filename, int bin, int updt)
{
  FILE *fp;
  ScmPort * res;
  char mode [4] = { 'a' };
  int mode_idx = 1;

  bin && (mode [mode_idx++] = 'b');
  updt && (mode [mode_idx++] = '+');
  mode [mode_idx] = '\0';
  errno = 0;
  if ((fp = fopen (filename, mode)) == NULL)
    error ("open \"%s\" for append failed (%s)", filename, ERRORSTRING);
  res = new_port ();
  res->type = FILE_PORT;
  res->u.file = fp;
  res->state = updt ? UPDATE_W : OUTPUT;
  return res;
}

ScmPort *ScmOpenTemporaryFile (void)
{
  FILE *fp;
  ScmPort *res;

  errno = 0;
  if ((fp = tmpfile ()) == NULL)
    error ("cannot open a temporary file (%s)", ERRORSTRING);
  res = new_port ();
  res->type = FILE_PORT;
  res->u.file = fp;
  res->state = UPDATE_W;
  return res;
}

ScmPort *ScmOpenInputGeneric
  (void *rd, void *rdc, void *pkc, void *chr, void *cl)
{
  ScmPort *res;

  save_1 = rd;
  save_2 = rdc;
  save_3 = pkc;
  save_4 = chr;
  save_5 = cl;
  SCM_NEW (res, Port);
  res->type = GENERIC_PORT;
  res->state = INPUT;
  res->u.gin.read = save_1;
  res->u.gin.read_char = save_2;
  res->u.gin.peek_char = save_3;
  res->u.gin.char_ready = save_4;
  res->u.gin.close = save_5;
  save_1 = save_2 = save_3 = save_4 = save_5 = NULL;
  return res;
}

ScmPort *ScmOpenOutputGeneric
  (void *wr, void *dp, void *wrc, void *nl, void *fl, void *cl)
{
  ScmPort *res;

  save_1 = wr;
  save_2 = dp;
  save_3 = wrc;
  save_4 = nl;
  save_5 = fl;
  save_6 = cl;
  SCM_NEW (res, Port);
  res->type = GENERIC_PORT;
  res->state = OUTPUT;
  res->u.gout.write = save_1;
  res->u.gout.display = save_2;
  res->u.gout.write_char = save_3;
  res->u.gout.newline = save_4;
  res->u.gout.flush = save_5;
  res->u.gout.close = save_6;
  save_1 = save_2 = save_3 = save_4 = save_5 = save_6 = NULL;
  return res;
}

unsigned ScmPortRead (ScmPort *port)
{
  if (port->type == FILE_PORT) {
    void *res;
    READABLE (port);
    if (port->state == END_OF_INPUT) {
      port->state = INPUT;
      Push (&ScmEof);
    } else {
      res = ScmRead (file_getc, file_ungetc, port->u.file);
      Push (res);
    }
    return 0;
  } else {
    Push (port->u.gin.read);
    return 1;
  }
}

unsigned ScmPortReadChar (ScmPort *port)
{
  if (port->type == FILE_PORT) {
    int c;
    void *res;
    READABLE (port);
    if (port->state == END_OF_INPUT) {
      port->state = INPUT;
      Push (&ScmEof);
    } else {
      c = getc (port->u.file);
      res = (c == EOF)
	     ? (void *) &ScmEof
	     : (void *) &ScmCharacter_array [c];
      Push (res);
    }
    return 0;
  } else {
    Push (port->u.gin.read_char);
    return 1;
  }
}

unsigned ScmPortPeekChar (ScmPort *port)
{
  if (port->type == FILE_PORT) {
    int c;
    void *res;
    READABLE (port);
    if (port->state == END_OF_INPUT)
      res = &ScmEof;
    else {
      c = getc (port->u.file);
      if (c == EOF) {
	res = &ScmEof;
	/* make next call to read-char return EOF, too */
	if (port->state == INPUT)
	  port->state = END_OF_INPUT;
      } else {
	ungetc (c, port->u.file);
	res = &ScmCharacter_array [c];
      }
    }
    Push (res);
    return 0;
  } else {
    Push (port->u.gin.peek_char);
    return 1;
  }
}

/* yuck -- system-dependend conditional compilation!!! */
# ifdef VSCM_POSIX

# include <fcntl.h>

static void (*real_signal_handler) (int);
static int old_fstate;
static int inconsistent_fd;

static void temp_signal_handler (int sig)
{
  /* repair file state */
  fcntl (inconsistent_fd, F_SETFL, old_fstate);
  /* invoke original signal handler */
  (* real_signal_handler) (sig);
}

static int getc_might_block (ScmPort *port)
{
  FILE *file = port->u.file;
  int fd, old, c, r;

  if (port->state == END_OF_INPUT)
    return 0;

  inconsistent_fd = fd = fileno (file);

  /* save old state */
  old_fstate = old = fcntl (fd, F_GETFL, 0);

  /* protection agains interrupts in critical section */
  if ((real_signal_handler = signal (SIGINT, SIG_IGN)) != SIG_IGN)
    signal (SIGINT, temp_signal_handler);

  /* go into non-blocking mode (critical section starts) */
  fcntl (fd, F_SETFL, old | O_NONBLOCK);

  errno = 0;
  /* probe */
  if ((c = getc (file)) != EOF) {
    /* succeeded */
    ungetc (c, file);
    r = 0;
  } else if (errno == EAGAIN)
    /* would block */
    r = 1;
  else {
    /* true EOF */
    r = 0;

    /*
     * The primary problem with this is that on files like /dev/tty the EOF
     * condition goes away after the first probe.  However, a subsequent
     * input request must be consistent, so we remember that we saw an EOF.
     *
     * READ/WRITE files do not behave this way, but they are non-standard
     * anyway and the semantics of char-ready? are more than questionable
     * in this case.
     */
    if (port->state == INPUT)
      port->state = END_OF_INPUT;
  }

  /* reset old mode (end of critical section) */
  fcntl (fd, F_SETFL, old);

  /* go back to normal signal handler */
  signal (SIGINT, real_signal_handler);

  return r;
}

# else

/*ARGSUSED*/
static int getc_might_block (ScmPort *port)
{
  static int warned = 0;
  if (!warned) {
    warned = 1;
    warning ("char-ready? always returns #f for file ports");
  }
  return 1;
}

# endif

unsigned ScmPortCharReadyP (ScmPort *port)
{
  if (port->type == FILE_PORT) {
    READABLE (port);
    if (getc_might_block (port))
      Push (&ScmFalse);
    else
      Push (&ScmTrue);
    return 0;
  } else {
    Push (port->u.gin.char_ready);
    return 1;
  }
}

unsigned ScmPortWrite (ScmPort *port, void *obj)
{
  if (port->type == FILE_PORT) {
    WRITABLE (port);
    write_object (obj, file_putc, port->u.file);
    Push (obj);
    return 0;
  } else {
    Push (obj);
    Push (port->u.gout.write);
    return 2;
  }
}

unsigned ScmPortDisplay (ScmPort *port, void *obj)
{
  if (port->type == FILE_PORT) {
    WRITABLE (port);
    display_object (obj, file_putc, port->u.file);
    Push (obj);
    return 0;
  } else {
    Push (obj);
    Push (port->u.gout.display);
    return 2;
  }
}

unsigned ScmPortWriteChar (ScmPort *port, void *obj)
{
  if (ScmTypeOf (obj) != ScmType (Character))
    badarg ("write-char", obj);
  if (port->type == FILE_PORT) {
    WRITABLE (port);
    putc ((ScmCharacter *) obj - ScmCharacter_array, port->u.file);
    Push (obj);
    return 0;
  } else {
    Push (obj);
    Push (port->u.gout.write_char);
    return 2;
  }
}

unsigned ScmPortNewline (ScmPort *port)
{
  if (port->type == FILE_PORT) {
    WRITABLE (port);
    putc ('\n', port->u.file);
    Push (&ScmFalse);
    return 0;
  } else {
    Push (port->u.gout.newline);
    return 1;
  }
}

unsigned ScmPortFlush (ScmPort *port)
{
  if (port->type == FILE_PORT) {
    errno = 0;
    if (fflush (port->u.file) == EOF)
      error ("write error while flushing file port %w (%s)",
	     port, ERRORSTRING);
    Push (&ScmFalse);
    return 0;
  } else {
    Push (port->u.gout.flush);
    return 1;
  }
}

unsigned ScmPortClose (ScmPort *port)
{
  unsigned i;
  port_state state = port->state;

  if (state == CLOSED)
    return 0;
  port->state = CLOSED;
  if (port->type == FILE_PORT) {
    for (i = 0; i < ports_len; i++)
      if (ports [i] == port) {
	ports [i] = NULL;
	break;
      }
    errno = 0;
    if (fclose (port->u.file) == EOF)
      error ("problems when closing port %w (%s)", port, ERRORSTRING);
    Push (&ScmFalse);
    return 0;
  } else {
    if (state == INPUT)
      Push (port->u.gin.close);
    else
      Push (port->u.gout.close);
    return 1;
  }
}

long ScmPortSeekAndTell (ScmPort *port, long offset, void *whence)
{
  int w;

  if (port->type != FILE_PORT)
    error ("seek-and-tell on non-file-port: %w", port);
  if (whence == &ScmTrue)
    w = SEEK_SET;
  else if (whence == &ScmFalse)
    w = SEEK_END;
  else
    w = SEEK_CUR;
  errno = 0;
  if (fseek (port->u.file, offset, w) != 0)
    error ("seek operation on port %w failed (%s)", port, ERRORSTRING);
  errno = 0;
  if ((offset = ftell (port->u.file)) < 0)
    error ("tell operation on port %w failed (%s)", port, ERRORSTRING);
  return offset;
}