/*
 *
 *  p o r t . c			-- ports implementation
 *
 * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 * 
 *
 * Permission to use, copy, and/or distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that both the above copyright notice and this permission notice appear in
 * all copies and derived works.  Fees for distribution or use of this
 * software or derived works may only be charged with express written
 * permission of the copyright holder.  
 * This software is provided ``as is'' without express or implied warranty.
 *
 * This software is a derivative work of other copyrighted softwares; the
 * copyright notices of these softwares are placed in the file COPYRIGHTS
 *
 *
 *            Author: Erick Gallesio [eg@unice.fr]
 *    Creation date: 17-Feb-1993 12:27
 * Last file update: 16-Jul-1995 17:39
 *
 */
#include <sys/ioctl.h>
#include <sys/time.h>
#include <ctype.h>
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>	/* This seems to be useful only for AIX */
#endif
#include "stk.h"

/* external vars */
SCM STk_curr_iport, STk_curr_oport, STk_curr_eport, STk_eof_object;

static SCM makeport(char *name, int type, int error)
{
  SCM z;
  FILE *f;
  long flag;
  char *full_name;

  flag = No_interrupt(1);

  if (strncmp(name, "| ", 2)) {
    full_name = CHARS(STk_internal_expand_file_name(name));

    if ((f = fopen(full_name,(type==tc_iport)? "r" : "w")) == NULL) {
      if (error) Err("could not open file", STk_makestring(name));
      else return Ntruth;
    }
  }
  else {
    full_name = name;
    if ((f = popen(name+1,(type==tc_iport)? "r" : "w")) == NULL) {
      if (error) Err("could not create pipe", STk_makestring(name));
      else return Ntruth;
    }    
  }

  NEWCELL(z, type);
  z->storage_as.port.f    = f;
  z->storage_as.port.name = (char *) must_malloc(strlen(full_name)+1);
  strcpy(z->storage_as.port.name, full_name);
  
  No_interrupt(flag);
  return(z);
}
  
static SCM verify_port(char *who, SCM port, int mode)
{
  char buff[100];

  if (port == UNBOUND)     /* test write 'cause of flush */
    port = (mode&F_WRITE) ? STk_curr_oport: STk_curr_iport; 

  if (port->storage_as.port.f == NULL) {
    sprintf(buff, "%s: port is closed", who);
    Err(buff, port);
  }
  if ((mode & F_READ)  && INP(port))  return port; /* not else. It can be both */
  if ((mode & F_WRITE) && OUTP(port)) return port;
Error:
  sprintf(buff, "%s: bad port", who);
  Err(buff, port);
}

static void closeport(SCM port)
{
  long flag;

  flag = No_interrupt(1);
  if (port->storage_as.port.f) {
    if (ISPORTP(port) || OSPORTP(port))			  /* String port */
      STk_free_string_port(port);
    else
      if (strncmp(port->storage_as.port.name, "| ",2)==0) /* Pipe port */
	pclose(port->storage_as.port.f);
      else						  /* File port */
	fclose(port->storage_as.port.f);
    port->storage_as.port.f = (FILE *) NULL;
  }
  No_interrupt(flag);
}

void STk_freeport(SCM port)
{
   long flag = No_interrupt(1);

   closeport(port);
   if (*(port->storage_as.port.name)) {
     free(port->storage_as.port.name);
     port->storage_as.port.name = "";
   }
   No_interrupt(flag);
}

void STk_init_standard_ports(void)
{
  NEWCELL(STk_curr_iport, tc_iport);
  STk_curr_iport->storage_as.port.name = "*stdin*"; 
  STk_curr_iport->storage_as.port.f    = stdin;
  STk_gc_protect(&STk_curr_iport);

  NEWCELL(STk_curr_oport, tc_oport);
  STk_curr_oport->storage_as.port.name = "*stdout*"; 
  STk_curr_oport->storage_as.port.f    = stdout;
  STk_gc_protect(&STk_curr_oport);
 
  NEWCELL(STk_curr_eport, tc_oport);
  STk_curr_eport->storage_as.port.name = "*stderr*"; 
  STk_curr_eport->storage_as.port.f    = stderr;
  STk_gc_protect(&STk_curr_eport);
  
  NEWCELL(STk_eof_object, tc_eof);
  STk_gc_protect(&STk_eof_object);

  STk_line_counter = 1;
  STk_current_filename = UNBOUND;	/* Ubound <=> stdin */
  STk_gc_protect(&STk_current_filename);
}

/******************************************************************************
 *
 * L O A D  stuff
 *
 ******************************************************************************/
static int do_load(char *full_name)
{
  FILE *f;
  int c;
  SCM previous_file_name;

  if (!STk_dirp(full_name)) {
     f = fopen(full_name, "r");
     
     if (f == NULL) return 0;

     if (VCELL(Intern(LOAD_VERBOSE)) != Ntruth)
       fprintf(stderr, ";; Loading file \"%s\"\n", full_name);
     
     /* Just read one character. Assume that file is an object if this 
      * character is a control one. Here, I don't try to see if the file magic 
      * number has a particular value, since I'm not nure that all platforms
      * use identical conventions 
      */
     c = Getc(f); Ungetc(c, f);
     if (c != EOF &&  ((iscntrl(c)&& c!= '\n') || !isascii(c))) {
       fclose(f);
       STk_load_object_file(full_name);
     }
     else {
       /* file seems not to be an object file. Try to load it as a Scheme file */
       jmp_buf jb, *prev_jb = Top_jmp_buf;
       long prev_context    = Error_context;
       SCM previous_file, form;
       int k, previous_line;
      
       /* Save info about current line and file */
       previous_file	    = STk_current_filename;
       previous_line	    = STk_line_counter;
       STk_line_counter     = 1;
       STk_current_filename = STk_makestring(full_name);

       /* save normal error jmpbuf so that eval error don't lead to toplevel */
       /* This permits to close the opened file in case of error */
       /* If in a "catch", keep the ERR_IGNORED bit set */
       if ((k = setjmp(jb)) == 0) {
	 Top_jmp_buf   = &jb;

	 for( ; ; ) {
	   form = STk_readf(f, FALSE);
	   if EQ(form, STk_eof_object) break;
	   STk_eval(form, NIL);
	 }
       }
       fclose(f);

       Top_jmp_buf   = prev_jb;
       Error_context = prev_context;
       if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);

       /* No error: restore info about current line and file */
       STk_current_filename = previous_file;
       STk_line_counter	    = previous_line;
     }
     if (VCELL(Intern(LOAD_VERBOSE)) != Ntruth)
       fprintf(stderr, ";; File \"%s\" loaded\n", full_name);
     return 1;
  }
  /* No file found */
  return 0;
}

static int try_loadfile(char *prefix, char *fname, SCM suffixes)
{
  char full_name[MAX_PATH_LENGTH], *s;

  /* First try to load without suffix */
  if (strlen(prefix) + strlen(fname) + 2 >= MAX_PATH_LENGTH) goto TooLong;
  sprintf(full_name, "%s%s%s", prefix, (*prefix ? "/": ""), fname);
  
  if (do_load(full_name)) return 1;

  /* Now try to load file with suffix */
  for ( ; NNULLP(suffixes); suffixes = CDR(suffixes)) {
    /* We are sure that suffixes is a well formed list (ensured by loadfile) */
    if (NSTRINGP(CAR(suffixes))) Err("load: bad suffix component", CAR(suffixes));
    s = CHARS(CAR(suffixes));

    if (strlen(prefix)+strlen(fname)+strlen(s)+3 >= MAX_PATH_LENGTH) goto  TooLong;
    sprintf(full_name, "%s%s%s.%s", prefix, (*prefix ? "/": ""), fname, s);

    if (do_load(full_name)) return 1;
  }
  
  /* No file loaded */
  return 0;

TooLong:
    Err("load: Filename too long", NIL);
}

SCM STk_loadfile(char *fname, int err_if_absent)
{
  int len;
  SCM load_path, load_suffixes;     
  
  len           = strlen(fname);
  load_path     = VCELL(Intern(LOAD_PATH));
  load_suffixes = VCELL(Intern(LOAD_SUFFIXES));
  
  if (STk_llength(load_path)<0)     Err("load: bad loading path", load_path);
  if (STk_llength(load_suffixes)<0) Err("load: bad set of suffixes", load_suffixes);
 
  if ((len > 0 && (fname[0] == '/' || fname[0] == '~')) ||
      (len > 1 && fname[0] == '.' && fname[1] == '/') ||
      (len > 2 && fname[0] == '.' && fname[1] == '.' && fname[2] == '/')) {
    
    if (fname[0] == '~') 
      fname = CHARS(STk_internal_expand_file_name(fname));

    if (try_loadfile("", fname, load_suffixes))
      return(err_if_absent? UNDEFINED: Truth);
  }
  else {
    /* Use *load-path* for loading file */
    for ( ; NNULLP(load_path); load_path = CDR(load_path)) {
      if (NSTRINGP(CAR(load_path))) 
	Err("load: bad loading path component", CAR(load_path));

      if (try_loadfile(CHARS(CAR(load_path)), fname, load_suffixes))
	return(err_if_absent? UNDEFINED: Truth);
    }
  }

    /* If we are here, we have been unable to load a file. Report err if needed */
  if (err_if_absent)
    Err("load: cannot open file", STk_makestring(fname));
  return Ntruth; 
}


PRIMITIVE STk_input_portp(SCM port)
{
  return IPORTP(port)? Truth: Ntruth;
}

PRIMITIVE STk_output_portp(SCM port)
{
  return OPORTP(port)? Truth: Ntruth;
}

PRIMITIVE STk_current_input_port(void)
{
  return STk_curr_iport;
}

PRIMITIVE STk_current_output_port(void)
{
  return STk_curr_oport;
}

PRIMITIVE STk_current_error_port(void)
{
  return STk_curr_eport;
}

PRIMITIVE STk_with_input_from_file(SCM string, SCM thunk)
{
  jmp_buf env, *prev_env = Top_jmp_buf;
  SCM result, prev_iport = STk_curr_iport;
  int prev_context 	 = Error_context;
  int k;

  if (NSTRINGP(string))     Err("with-input-from-file: bad string", string);
  if (!STk_is_thunk(thunk)) Err("with-input-from-file: bad thunk", thunk);

  STk_curr_iport = UNBOUND; 	/* will not be changed if opening fails */

  if ((k = setjmp(env)) == 0) {
    Top_jmp_buf     = &env;
    STk_curr_iport  = makeport(CHARS(string), tc_iport, 1);
    result          = Apply(thunk, NIL);
  }
  /* restore normal error jmpbuf  and current input port*/
  if (STk_curr_iport != UNBOUND) closeport(STk_curr_iport);
  STk_curr_iport = prev_iport;
  Top_jmp_buf    = prev_env;
  Error_context  = prev_context;

  if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  return result;
}

PRIMITIVE STk_with_output_to_file(SCM string, SCM thunk)
{
  jmp_buf env, *prev_env = Top_jmp_buf;
  SCM result, prev_oport = STk_curr_oport;
  int prev_context       = Error_context;
  int k;

  if (NSTRINGP(string))     Err("with-output-to-file: bad string", string);
  if (!STk_is_thunk(thunk)) Err("with-output-to-file: bad thunk", thunk);

  STk_curr_oport = UNBOUND;		/* will not be changed if opening fails */

  if ((k = setjmp(env)) == 0) {
    Top_jmp_buf     = &env;
    STk_curr_oport  = makeport(CHARS(string), tc_oport, 1);
    result          = Apply(thunk, NIL);
  }
  /* restore normal error jmpbuf  and current output port*/
  if (STk_curr_oport != UNBOUND) closeport(STk_curr_oport);
  STk_curr_oport = prev_oport;
  Top_jmp_buf    = prev_env;
  Error_context  = prev_context;

  if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  return result;
}


PRIMITIVE STk_open_input_file(SCM filename)
{
  if (NSTRINGP(filename)) Err("open-input-file: bad file name", filename);
  return makeport(CHARS(filename), tc_iport, TRUE);
}

PRIMITIVE STk_open_output_file(SCM filename)
{
  if (NSTRINGP(filename)) Err("open-output-file: bad file name", filename);
  return makeport(CHARS(filename), tc_oport, TRUE); 
}

PRIMITIVE STk_close_input_port(SCM port)
{
  if (!INP(port)) Err("close-input-port: not an input port", port);
  closeport(port);

  return UNDEFINED;
}

PRIMITIVE STk_close_output_port(SCM port)
{
  if (!OUTP(port)) Err("close-output-port: not an output port", port);
  closeport(port);

  return UNDEFINED;
}

PRIMITIVE STk_read(SCM port)
{
  port = verify_port("read", port, F_READ);
  return(STk_readf(port->storage_as.port.f, FALSE));
}

PRIMITIVE STk_read_char(SCM port)
{
  int c;

  port = verify_port("read-char", port, F_READ);
  c = Getc(port->storage_as.port.f);
  return (c == EOF) ? STk_eof_object : STk_makechar(c);
}

PRIMITIVE STk_peek_char(SCM port)
{
  int c;

  port = verify_port("peek-char", port, F_READ);
  c = Getc(port->storage_as.port.f);
  Ungetc(c, port->storage_as.port.f);
  return (c == EOF) ? STk_eof_object : STk_makechar(c);
}

PRIMITIVE STk_eof_objectp(SCM obj)
{
  return (obj == STk_eof_object)? Truth : Ntruth;
}
#ifdef max
#undef max
#endif
#define max(a,b) ((a)>(b)? (a) : (b))

#ifdef _STDIO_USES_IOSTREAM  /* GNU libc */
#  if defined(_IO_STDIO_H) || defined (linux)
#    define READ_DATA_PENDING(fp) (max(0,(fp)->_IO_read_end - (fp)->_IO_read_ptr))
#  else
#    define READ_DATA_PENDING(fp) (max(0,(fp)->_egptr - (fp)->_gptr))
#  endif
#endif
#if (!defined (READ_DATA_PENDING)) && defined __SLBF
#  define READ_DATA_PENDING(fp) (max(0,fp->_r))
#endif
#if !defined (READ_DATA_PENDING)
#  define READ_DATA_PENDING(fp) (fp->_cnt)
#endif

PRIMITIVE STk_char_readyp(SCM port) 
{ 
  port = verify_port("char-ready?", port, F_READ);
  if (Eof(port->storage_as.port.f)) return Truth;
  if (ISPORTP(port)) /* !eof -> */  return Truth;
  else {
    /* First, see if characters are available in the buffer */
    if (READ_DATA_PENDING(port->storage_as.port.f))
      return Truth;

#ifdef HAVE_SELECT
    {
      fd_set readfds;
      struct timeval timeout;
      int f = fileno(port->storage_as.port.f);

      FD_ZERO(&readfds); 
      FD_SET(f, &readfds);
      timeout.tv_sec = timeout.tv_usec = 0;
      return (select(f+1, &readfds, NULL, NULL, &timeout)) ? Truth : Ntruth;
    }
#else
#  ifdef FIONREAD
   {
     int result;

     ioctl(fileno(port->storage_as.port.f), FIONREAD, &result);
     return result ? Truth : Ntruth;
   }
#  else
   return Truth;
#  endif
#endif
  }
}


PRIMITIVE STk_write(SCM expr, SCM port)
{
  port = verify_port("write", port, F_WRITE);
  STk_print(expr, port, WRT_MODE);
  return UNDEFINED;
}

PRIMITIVE STk_display(SCM expr, SCM port)
{
  port = verify_port("display", port, F_WRITE);
  STk_print(expr, port, DSP_MODE);
  return UNDEFINED;
}

PRIMITIVE STk_newline(SCM port)
{
  port = verify_port("newline", port, F_WRITE);
  Putc('\n', port->storage_as.port.f);
  return UNDEFINED;
}

PRIMITIVE STk_write_char(SCM c, SCM port)
{
  if (NCHARP(c)) Err("write-char: not a character", c);
  port = verify_port("write-char", port, F_WRITE);
  Putc(CHAR(c), port->storage_as.port.f);
  return UNDEFINED;
}

/*
 * The name `scheme_load' is needed because of a symbol table conflict
 * in libc. This is bogus, but what do you do.
 */
PRIMITIVE STk_scheme_load(SCM filename)
{
  if (NSTRINGP(filename)) Err("load: bad file name", filename); 
  return STk_loadfile(CHARS(filename), 1);
}


/*
 *
 * STk bonus
 *
 */

static SCM internal_format(SCM l,int len,int error)/* a very simple and poor one */ 
{
  SCM port, fmt;
  int format_in_string = 0;
  char *p;
  FILE *f;

  if (error) {
    if (len < 1) Err("error: Bad list of parameters", l);
    format_in_string = 1;
    port = STk_open_output_string();
    len -= 1;
  }
  else {
    if (len < 2) Err("format: Bad list of parameters", l);
    port = CAR(l); l = CDR(l);
    len -= 2;
  }
  fmt  = CAR(l); l = CDR(l);

  if (BOOLEANP(port)){
    if (port == Truth) port = STk_curr_oport;
    else {
      format_in_string = 1;
      port= STk_open_output_string();
    }
  }
  
  verify_port(error? "error": "format", port, F_WRITE);
  if (NSTRINGP(fmt)) Err("format: bad format string", fmt);

  f = port->storage_as.port.f;

  for(p=CHARS(fmt); *p; p++) {
    if (*p == '~') {
      switch(*(++p)) {
        case 'S':
        case 's':
        case 'A':
        case 'a': if (len-- > 0) {
                    STk_print(CAR(l), 
			      port, 
			      (tolower(*p) == 's')? WRT_MODE: DSP_MODE);
                    l = CDR(l);
                  }
                  else Err("format: too much ~ in format string", l); 
	          continue;
        case '%': Putc('\n', f);
                  continue;
        case '~': Putc('~', f);
                  continue;
        default:  Putc('~',  f);
                  /* NO BREAK */
      }
    }
    Putc(*p, f);
  }

  if (NNULLP(l)) Err("format: too few ~ in format string", l);

  return format_in_string ? STk_get_output_string(port) : UNDEFINED;
}

PRIMITIVE STk_format(SCM l, int len)
{
  return internal_format(l, len, FALSE);
}

PRIMITIVE STk_error(SCM l, int len)
{
  /* Set context to ERR_OK but keep the bit indicating if error must be caught */
  Error_context = ERR_OK | (Error_context & ERR_IGNORED);

  Err(CHARS(internal_format(l, len, TRUE)), NIL);
  return UNDEFINED; 	/* for compiler */
}

PRIMITIVE STk_try_load(SCM filename)
{
  if (NSTRINGP(filename)) Err("try-load: bad file name", filename); 

  return STk_loadfile(CHARS(filename), FALSE);
}

PRIMITIVE STk_open_file(SCM filename, SCM mode)
{
  int type;

  if (NSTRINGP(filename)) Err("open-file: bad file name", filename); 
  if (NSTRINGP(mode))     Err("open-file: bad mode", mode);

  type = strchr(CHARS(mode), 'r') ? tc_iport : tc_oport;
  return(makeport(CHARS(filename), type, FALSE));
}

PRIMITIVE STk_close_port(SCM port)
{
  if (INP(port) || OUTP(port)) closeport(port);
  else Err("close-port: bad port", port);
  return UNDEFINED;
}

PRIMITIVE STk_read_line(SCM port)
{
  FILE *f;
  int c, i, size = 128;
  char *buff = (char *) must_malloc(size);
  SCM res;

  port = verify_port("read-line", port, F_READ);
  f = port->storage_as.port.f;
  for (i = 0; ; i++) {
    switch (c = Getc(f)) {
      case EOF:  if (i == 0) { free(buff); return STk_eof_object; }
      case '\n': res = STk_makestrg(i, buff); free(buff); return res;
      default:   if (i == size) {
	           size += size / 2;
		   buff = must_realloc(buff, size);
		 }
	         buff[i] = c;
    }
  }
}

PRIMITIVE STk_flush(SCM port)
{
  port = verify_port("flush", port, F_WRITE|F_READ);
  fflush(port->storage_as.port.f);
  return UNDEFINED;
}

/******************************************************************************
 *
 * Autoload stuff
 *
 ******************************************************************************/

static SCM list_of_files = NULL;

static SCM make_autoload(SCM file)
{
  SCM z;
  
  NEWCELL(z, tc_autoload);
  CAR(z) =  file;
  return z;
}

void STk_do_autoload(SCM var)
{
  SCM file, autoload;

  autoload = VCELL(var); file = CAR(autoload);
  
  /* Retain in a list, files which are currently autoloaded to avoid mult. load */
  if (!list_of_files) {
    list_of_files = NIL;
    STk_gc_protect(&list_of_files);
  }

  if (STk_member(file, list_of_files) != Ntruth) return;
  list_of_files = Cons(file, list_of_files);

  STk_loadfile(CHARS(file), TRUE);

  list_of_files = CDR(list_of_files);

  if (TYPEP(VCELL(var), tc_autoload)) {
    Err("autoload: symbol was not defined", var);
  }
}

PRIMITIVE STk_autoload(SCM l, SCM env, int len)
{
  SCM file;

  if (len < 2) Err("autoload: bad parameter list", l);

  file = CAR(l); 
  if (NSTRINGP(file)) Err("autoload: bad file name", file);

  for (l = CDR(l); NNULLP(l); l = CDR(l)) {
    if (NSYMBOLP(CAR(l))) Err("autoload: bad symbol", CAR(l));
    VCELL(CAR(l)) = make_autoload(file);
  }
  return UNDEFINED;
}

PRIMITIVE STk_autoloadp(SCM l, SCM env, int len)
{
  if (len != 1 || NSYMBOLP(CAR(l)))
    Err("autoload?: bad symbol", l);
  
  return TYPEP(CAR(l), tc_autoload) ? Truth: Ntruth;
}