[bpt/guile.git] / libguile / ports.c

/*	Copyright (C) 1995,1996 Free Software Foundation, Inc.
 * 
 * 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 2, 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 software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */
\f
#include <stdio.h>
#include "_scm.h"
#include "genio.h"
#include "chars.h"

#include "markers.h"
#include "filesys.h"
#include "fports.h"
#include "strports.h"
#include "vports.h"

#include "ports.h"

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef HAVE_SYS_IOCTL_H
#include <sys/ioctl.h>
#endif
\f


/* scm_ptobs scm_numptob
 * implement a dynamicly resized array of ptob records.
 * Indexes into this table are used when generating type
 * tags for smobjects (if you know a tag you can get an index and conversely).
 */
scm_ptobfuns *scm_ptobs;
scm_sizet scm_numptob;


SCM 
scm_markstream (ptr)
     SCM ptr;
{
  int openp;
  if (SCM_GC8MARKP (ptr))
    return SCM_BOOL_F;
  openp = SCM_CAR (ptr) & SCM_OPN;
  SCM_SETGC8MARK (ptr);
  if (openp)
    return SCM_STREAM  (ptr);
  else
    return SCM_BOOL_F;
}


long 
scm_newptob (ptob)
     scm_ptobfuns *ptob;
{
  char *tmp;
  if (255 <= scm_numptob)
    goto ptoberr;
  SCM_DEFER_INTS;
  SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)));
  if (tmp)
    {
      scm_ptobs = (scm_ptobfuns *) tmp;
      scm_ptobs[scm_numptob].mark = ptob->mark;
      scm_ptobs[scm_numptob].free = ptob->free;
      scm_ptobs[scm_numptob].print = ptob->print;
      scm_ptobs[scm_numptob].equalp = ptob->equalp;
      scm_ptobs[scm_numptob].fputc = ptob->fputc;
      scm_ptobs[scm_numptob].fputs = ptob->fputs;
      scm_ptobs[scm_numptob].fwrite = ptob->fwrite;
      scm_ptobs[scm_numptob].fflush = ptob->fflush;
      scm_ptobs[scm_numptob].fgetc = ptob->fgetc;
      scm_ptobs[scm_numptob].fclose = ptob->fclose;
      scm_numptob++;
    }
  SCM_ALLOW_INTS;
  if (!tmp)
  ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob");
  return scm_tc7_port + (scm_numptob - 1) * 256;
}

\f
/* internal SCM call */

void 
scm_fflush (port)
     SCM port;
{
  scm_sizet i = SCM_PTOBNUM (port);
  (scm_ptobs[i].fflush) (SCM_STREAM (port));
}

\f

SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p);

SCM 
scm_char_ready_p (port)
     SCM port;
{
  if (SCM_UNBNDP (port))
    port = scm_cur_inp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p);
  if (SCM_CRDYP (port) || !SCM_FPORTP (port))
    return SCM_BOOL_T;
  return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p)
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}


\f

SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p);

SCM 
scm_ungetc_char_ready_p (port)
     SCM port;
{
  if (SCM_UNBNDP (port))
    port = scm_cur_inp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p);
  return (SCM_CRDYP (port)
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}


\f


/* {Standard Ports}
 */
SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port);

SCM 
scm_current_input_port ()
{
  return scm_cur_inp;
}

SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port);

SCM 
scm_current_output_port ()
{
  return scm_cur_outp;
}

SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port);

SCM 
scm_current_error_port ()
{
  return scm_cur_errp;
}

SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port);

SCM 
scm_set_current_input_port (port)
     SCM port;
{
  SCM oinp = scm_cur_inp;
  SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port);
  scm_cur_inp = port;
  return oinp;
}


SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port);

SCM 
scm_set_current_output_port (port)
     SCM port;
{
  SCM ooutp = scm_cur_outp;
  SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port);
  scm_cur_outp = port;
  return ooutp;
}


SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port);

SCM 
scm_set_current_error_port (port)
     SCM port;
{
  SCM oerrp = scm_cur_errp;
  SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port);
  scm_cur_errp = port;
  return oerrp;
}

\f

/* {Ports - in general}
 * 
 */

/* Array of open ports, required for reliable MOVE->FDES etc.  */
struct scm_port_table **scm_port_table;

int scm_port_table_size = 0;	/* Number of ports in scm_port_table.  */
int scm_port_table_room = 20;	/* Size of the array.  */

/* Add a port to the table.  Call with SCM_DEFER_INTS active.  */

struct scm_port_table *
scm_add_to_port_table (port)
     SCM port;
{
  if (scm_port_table_size == scm_port_table_room)
    {
      scm_port_table = ((struct scm_port_table **)
			realloc ((char *) scm_port_table,
				 (long) (sizeof (struct scm_port_table)
					 * scm_port_table_room * 2)));
      /* !!! error checking */
      scm_port_table_room *= 2;
    }
  scm_port_table[scm_port_table_size] = ((struct scm_port_table *)
					 scm_must_malloc (sizeof (struct scm_port_table),
							  "system port table"));
  scm_port_table[scm_port_table_size]->port = port;
  scm_port_table[scm_port_table_size]->revealed = 0;
  scm_port_table[scm_port_table_size]->stream = 0;
  scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F;
  scm_port_table[scm_port_table_size]->line_number = 1;
  scm_port_table[scm_port_table_size]->column_number = 0;
  scm_port_table[scm_port_table_size]->representation = scm_regular_port;
  return scm_port_table[scm_port_table_size++];
}

/* Remove a port from the table.  Call with SCM_DEFER_INTS active.  */

void
scm_remove_from_port_table (port)
     SCM port;
{
  int i = 0;
  while (scm_port_table[i]->port != port)
    {
      i++;
      /* Error if not found: too violent?  May occur in GC.  */
      if (i >= scm_port_table_size)
	scm_wta (port, "Port not in table", "scm_remove_from_port_table");
    }
  scm_must_free ((char *)scm_port_table[i]);
  scm_mallocated -= sizeof (*scm_port_table[i]);
  scm_port_table[i] = scm_port_table[scm_port_table_size - 1];
  SCM_SETPTAB_ENTRY (port, 0);
  scm_port_table_size--;
}

#ifdef DEBUG
/* Undocumented functions for debugging.  */
/* Return the number of ports in the table.  */

SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size);
SCM
scm_pt_size ()
{
  return SCM_MAKINUM (scm_port_table_size);
}

/* Return the ith member of the port table.  */
SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member);
SCM
scm_pt_member (member)
     SCM member;
{
  int i;
  SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member);
  i = SCM_INUM (member);
  if (i < 0 || i >= scm_port_table_size)
    return SCM_BOOL_F;
  else
    return scm_port_table[i]->port;
}
#endif


/* Find a port in the table and return its revealed count.
   Also used by the garbage collector.
 */

int
scm_revealed_count (port)
     SCM port;
{
  return SCM_REVEALED(port);
}


/* Return the revealed count for a port.  */

SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed);

SCM
scm_port_revealed (port)
     SCM port;
{
  SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed);
  return SCM_MAKINUM (scm_revealed_count (port));
}

/* Set the revealed count for a port.  */
SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x);

SCM
scm_set_port_revealed_x (port, rcount)
     SCM port;
     SCM rcount;
{
  SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x);
  SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x);
  SCM_DEFER_INTS;
  SCM_REVEALED (port) = SCM_INUM (rcount);
  SCM_ALLOW_INTS;
  return SCM_UNSPECIFIED;
}

/* scm_close_port
 * Call the close operation on a port object. 
 */
SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port);

SCM
scm_close_port (port)
     SCM port;
{
  scm_sizet i;
  SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port);
  if (SCM_CLOSEDP (port))
    return SCM_UNSPECIFIED;
  i = SCM_PTOBNUM (port);
  SCM_DEFER_INTS;
  if (scm_ptobs[i].fclose)
    SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port)));
  scm_remove_from_port_table (port);
  SCM_SETAND_CAR (port, ~SCM_OPN);
  SCM_ALLOW_INTS;
  return SCM_UNSPECIFIED;
}

SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except);

SCM
scm_close_all_ports_except (ports)
     SCM ports;
{
  int i = 0;
  SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except);
  SCM_DEFER_INTS;  
  while (i < scm_port_table_size)
    {
      SCM thisport = scm_port_table[i]->port;
      int found = 0;
      SCM ports_ptr = ports;

      while (SCM_NNULLP (ports_ptr))
	{
	  SCM port = SCM_CAR (ports_ptr);
	  if (i == 0)
	    SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except);
	  if (port == thisport)
	    found = 1;
	  ports_ptr = SCM_CDR (ports_ptr);
	}
      if (found)
	i++;
      else
	/* i is not to be incremented here.  */
	scm_close_port (thisport);
    }
  SCM_ALLOW_INTS;
  return SCM_UNSPECIFIED;
}

SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p);

SCM 
scm_input_port_p (x)
     SCM x;
{
  if (SCM_IMP (x))
 return SCM_BOOL_F;
  return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p);

SCM 
scm_output_port_p (x)
     SCM x;
{
  if (SCM_IMP (x))
 return SCM_BOOL_F;
  return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
}


SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p);

SCM 
scm_eof_object_p (x)
     SCM x;
{
  return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output);

SCM 
scm_force_output (port)
     SCM port;
{
  if (SCM_UNBNDP (port))
 port = scm_cur_outp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output);
  {
    scm_sizet i = SCM_PTOBNUM (port);
    SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port)));
    return SCM_UNSPECIFIED;
  }
}


SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char);

SCM 
scm_read_char (port)
     SCM port;
{
  int c;
  if (SCM_UNBNDP (port))
    port = scm_cur_inp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char);
  c = scm_gen_getc (port);
  if (EOF == c)
    return SCM_EOF_VAL;
  return SCM_MAKICHR (c);
}


SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);

SCM 
scm_peek_char (port)
     SCM port;
{
  int c;
  if (SCM_UNBNDP (port))
    port = scm_cur_inp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char);
  c = scm_gen_getc (port);
  if (EOF == c)
    return SCM_EOF_VAL;
  scm_gen_ungetc (c, port);
  return SCM_MAKICHR (c);
}

SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char);

SCM 
scm_unread_char (cobj, port)
     SCM cobj;
     SCM port;
{
  int c;

  SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char);

  if (SCM_UNBNDP (port))
    port = scm_cur_inp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char);


  c = SCM_ICHR (cobj);

  scm_gen_ungetc (c, port);
  return cobj;
}


SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line);

SCM 
scm_port_line (port)
     SCM port;
{
  SCM p;
  p = ((port == SCM_UNDEFINED)
       ? scm_cur_inp
       : port);
  if (!(SCM_NIMP (p) && SCM_PORTP (p)))
    return SCM_BOOL_F;
  else
    return SCM_MAKINUM (SCM_LINUM (p));
}

SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x);

SCM 
scm_set_port_line_x (port, line)
     SCM port;
     SCM line;
{
  if (line == SCM_UNDEFINED)
    {
      line = port;
      port = scm_cur_inp;
    }
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
		port,
		SCM_ARG1,
		s_set_port_line_x);
  return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
}

SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column);

SCM
scm_port_column  (port)
     SCM port;
{
  SCM p;
  p = ((port == SCM_UNDEFINED)
       ? scm_cur_inp
       : port);
  if (!(SCM_NIMP (p) && SCM_PORTP (p)))
    return SCM_BOOL_F;
  else
    return SCM_MAKINUM (SCM_COL (p));
}

SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x);

SCM 
scm_set_port_column_x (port, column)
     SCM port;
     SCM column;
{
  if (column == SCM_UNDEFINED)
    {
      column = port;
      port = scm_cur_inp;
    }
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
		port,
		SCM_ARG1,
		s_set_port_column_x);
  return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
}

SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename);

SCM 
scm_port_filename (port)
     SCM port;
{
  SCM p;
  p = ((port == SCM_UNDEFINED)
       ? scm_cur_inp
       : port);
  if (!(SCM_NIMP (p) && SCM_PORTP (p)))
    return SCM_BOOL_F;
  else
    return SCM_PTAB_ENTRY (p)->file_name;
}

SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x);

SCM 
scm_set_port_filename_x (port, filename)
     SCM port;
     SCM filename;
{
  if (filename == SCM_UNDEFINED)
    {
      filename = port;
      port = scm_cur_inp;
    }
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
		port,
		SCM_ARG1,
		s_set_port_filename_x);
  return SCM_PTAB_ENTRY (port)->file_name = filename;
}

#ifndef ttyname
extern char * ttyname();
#endif


void 
scm_prinport (exp, port, type)
     SCM exp;
     SCM port;
     char *type;
{
  scm_gen_puts (scm_regular_string, "#<", port);
  if (SCM_CLOSEDP (exp))
    scm_gen_puts (scm_regular_string, "closed: ", port);
  else
    {
      if (SCM_RDNG & SCM_CAR (exp))
	scm_gen_puts (scm_regular_string, "input: ", port);
      if (SCM_WRTNG & SCM_CAR (exp))
	scm_gen_puts (scm_regular_string, "output: ", port);
    }
  scm_gen_puts (scm_regular_string, type, port);
  scm_gen_putc (' ', port);
#ifndef MSDOS
#ifndef __EMX__
#ifndef _DCC
#ifndef AMIGA
#ifndef THINK_C
  if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp))))
    scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port);
  else
#endif
#endif
#endif
#endif
#endif
  if (SCM_OPFPORTP (exp))
    scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port);
  else
    scm_intprint (SCM_CDR (exp), 16, port);
  scm_gen_putc ('>', port);
}


void
scm_ports_prehistory ()
{
  scm_numptob = 0;
  scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns));
  
  /* WARNING: These scm_newptob calls must be done in this order.
   * They must agree with the port declarations in tags.h.
   */
  /* scm_tc16_fport = */ scm_newptob (&scm_fptob);
  /* scm_tc16_pipe = */ scm_newptob (&scm_pipob);
  /* scm_tc16_strport = */ scm_newptob (&scm_stptob);
  /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob);
}
\f

\f
/* {Void Ports}
 */

int scm_tc16_void_port = 0;

static int
print_void_port (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_prinport (exp, port, "void");
  return 1;
}

static int
putc_void_port (c, strm)
     int c;
     SCM strm;
{
  return 0;			/* vestigial return value */
}

static int
puts_void_port (s, strm)
     char * s;
     SCM strm;
{
  return 0;			/* vestigial return value */
}

static scm_sizet
write_void_port (ptr, size, nitems, strm)
     void * ptr;
     int size;
     int nitems;
     SCM strm;
{
  int len;
  len = size * nitems;
  return len;
}


static int flush_void_port SCM_P ((SCM strm));

static int
flush_void_port (strm)
     SCM strm;
{
  return 0;
}


static int getc_void_port SCM_P ((SCM strm));

static int
getc_void_port (strm)
     SCM strm;
{
  return EOF;
}


static int close_void_port SCM_P ((SCM strm));

static int
close_void_port (strm)
     SCM strm;
{
  return 0;			/* this is ignored by scm_close_port. */
}


static int noop0 SCM_P ((SCM stream));

static int 
noop0 (stream)
     SCM stream;
{
  return 0;
}


static struct scm_ptobfuns  void_port_ptob =
{
  scm_mark0, 
  noop0,
  print_void_port,
  0,				/* equal? */
  putc_void_port,
  puts_void_port,
  write_void_port,
  flush_void_port,
  getc_void_port,
  close_void_port,
};

\f


SCM
scm_void_port (mode_str)
     char * mode_str;
{
  int mode_bits;
  SCM answer;
  struct scm_port_table * pt;

  SCM_NEWCELL (answer);
  SCM_DEFER_INTS;
  mode_bits = scm_mode_bits (mode_str);
  pt = scm_add_to_port_table (answer);
  SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
  SCM_SETPTAB_ENTRY (answer, pt);
  SCM_SETSTREAM (answer, SCM_BOOL_F);
  SCM_ALLOW_INTS;
  return answer;
}


SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port);

SCM
scm_sys_make_void_port (mode)
     SCM mode;
{
  SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode,
	      SCM_ARG1, s_sys_make_void_port);

  return scm_void_port (SCM_ROCHARS (mode));
}


\f


void
scm_init_ports ()
{
  scm_tc16_void_port = scm_newptob (&void_port_ptob);
#include "ports.x"
}