/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/**************\
*              *
*  KlO  Stream *
*  BODY        *
*              *
\**************/

#include "EXTERN.h"
#include <signal.h>
#include <fcntl.h>
#ifdef SYSV
#include <unistd.h>
#endif /* SYSV */
#include <sys/types.h>
#include <ctype.h>
#include <sys/time.h>     
#include <sys/stat.h>
#ifdef NEED_SELECT_H
#include <sys/select.h>
#endif
#include "klone.h"
#include "kl_number.h"
#include "kl_atom.h"
#include "kl_list.h"
#include "kl_string.h"
#include "kl_func.h"
#include "klgeneric.h"
#include "klnet.h"
#include "klparser.h"
#include "INTERN.h"
#include "kl_stream.h"

#include <errno.h>

KlO KlStreamToStringCoerce();
extern KlStream KlSocketMake();
extern KlStream KlSocketAccept();

/* direction of files:
 * 0 = closed
 * 1 = read
 * 2 = write
 * ==> 3 read&write
 */

char *KlStreamDirectionsText[] = {"closed", "read", "write", "read+write"};

/* constructor for Files
 */

KlStream
KlStreamMake(fd, direction, name)
    FILE *fd;
    int direction;
    char *name;
{
    KlStream obj;

    obj = (KlStream) KlOMake(KlStreamType);
    obj->subtype = KlStreamFileType;
    obj->fd = fd;
    obj->write_fd = 0;
    obj->direction = direction;
    obj->parse_state = 0;
    obj->parse_dirty = 0;
    obj->parse_disabled = 0;
    obj->parse_bufferized = 0;		/* can be turned to 1 by load */
    obj->read_expr = 0;
    obj->name = (char *) Malloc(strlen(name) + 1);
    strcpy(obj->name, name);
    obj->blocking = 1;
    obj->blocking_write = 1;

    return obj;
}

/* constructor for Strings
 */

KlStreamString
KlStreamStringMake(klstring, direction)
    KlString klstring;
    int direction;
{
    KlStreamString obj;

    obj = (KlStreamString) KlOMake(KlStreamType);
    obj->subtype = KlStreamStringType;
    KlIncRef(obj->klstring = klstring);
    obj->direction = direction;
    obj->parse_state = 0;
    obj->parse_dirty = 0;
    obj->parse_disabled = 0;
    obj->read_expr = 0;
    obj->cursor = 0;
#ifdef USE_STANDARD_MALLOC
    obj->limit = (klstring->string ? KlModStringLength(klstring) + 1 : 0);
#else /* !USE_STANDARD_MALLOC */
#ifdef DO_NOT_REDEFINE_MALLOC
    if (obj->type == KlStringType && KlOIsInMallocSpace(klstring->string))
	/* optimisation: if we can determine the bucket size, use it! */
	obj->limit = (klstring->string ? KlMallocedSize(klstring->string) : 0);
    else /* let realloc do the work */
	obj->limit = (klstring->string ? KlModStringLength(klstring) + 1 : 0);
#else /* !DO_NOT_REDEFINE_MALLOC */
    /* here we are sure all malloc go through our malloc */
    if (!KlHasTrait(klstring, KlTrait_unreallocable))
	obj->limit = (klstring->string ? KlMallocedSize(klstring->string) : 0);
    else
	obj->limit = (klstring->string ? KlModStringLength(klstring) + 1 : 0);
#endif /* DO_NOT_REDEFINE_MALLOC */
#endif /* !USE_STANDARD_MALLOC */
    return obj;
}

/* KlOpen
 * opening a new stream
 * (open filename &key :direction :if-exists :type :error) [646]
 * 
 *     creates a stream by opening the file filename. keywords can be:
 *     :direction    :output, :input (default), or :io (both)
 *     :if-exists    :overwrite, :supersede, :error or :append (default) 
 *		  what to do if file exists.
 * 		  already and we open it in :output or :io mode)
 *     :type	  :file (default) or :string. The string type is a string that
 * 		  can be written to and read from by I/O primitives, but can
 * 		  be still used as a string.
 *                Also can be :tcp for tcp socket, :udp for udp socket
 *                :pipe creates a pipe with both ends separated
 *                in this case filename will just be used as a label when 
 *                printing the stream
 *     :buffered  can be t (default) or nil
 *     :writer    file to open for writing, if :direction :io and write channel
 *		  is different from read channel
 *     :blocking  can be t (default) or (), in which case FD_NDELAY is set
 *     :error     if an error happens, returns the evaluation of argument
 *                instead of calling KlE_ERROR_OPENING_FILE. Note that since
 *                open evaluates its arguments, you need to quote the 
 *                expression
 * NOTE: filename must be a string or a listen-ing socket, in which case 
 * open does an accept call on it and return the actual socket. In this case
 * :type is ignored, but direction, buffered, blocking, error are not
 */

/* list of valid parameters to keywords. see at the end of this file */
static KlKeyword
    *KlOpenKV_if_exists,
    *KlOpenKV_direction,
    *KlOpenKV_filetype;


KlStream
KlOpen(argc, argv)
    int argc;
    KlO *argv;
{
    KlO direction, if_exists, filetype, buffered, blocking, error;
    KlString writer;
    KlString filename;
    int no_delay;

    KlParseKeywords(argc, argv, 1);
    direction = KlKeyVal(KlK_direction, KlK_input);
    if_exists = KlKeyVal(KlK_if_exists, KlK_append);
    filetype = KlKeyVal(KlK_type, KlK_file);
    buffered = KlKeyVal(KlK_buffered, TRU);
    writer = (KlString) KlKeyVal(KlK_writer, 0);
    blocking =  KlKeyVal(KlK_blocking, TRU);
    error = KlKeyVal(KlK_error, 0);
    KlCheckUnvalidKeywords(argc, argv, 1);

    /* check the validity of the arguments to the keywords. */
    if_exists = KlCheckKeywordValue(KlK_if_exists, if_exists,
				    KlOpenKV_if_exists);
    direction = KlCheckKeywordValue(KlK_direction, direction,
				    KlOpenKV_direction);
    /* this chek is not needed actually, since all bad values are trapped ...
       filetype = KlCheckKeywordValue(KlK_type, filetype, KlOpenKV_filetype);
       */
    no_delay = KlFalseP(blocking);

    if (!KlIsAString(argv[0])) {
					/* a socket? ==> accept call */
	if (KlIsAStream(argv[0]) && 
	    (((KlStream) (argv[0]))->subtype & 12)) {
	    return KlSocketAccept(argv[0], direction, buffered, blocking, error);
	} else {			/* else error */
	    KlMustBeString(argv[0], 0);
	}
    }
    filename = (KlString) argv[0];

    if (filetype == (KlO) KlK_file) {	/* file type */
	KlStream stream;
	char *mode;
	FILE *fd, *write_fd = 0;

	if (direction == (KlO) KlK_output) {
	    mode = (if_exists == (KlO) KlK_overwrite ? "r+" :
		    if_exists == (KlO) KlK_supersede ? "w" : "a");
	} else if (direction == (KlO) KlK_io) {
	    mode = (if_exists == (KlO) KlK_overwrite ? "r+" :
		    if_exists == (KlO) KlK_supersede ? "w+" : "a+");
	    if (writer) {
		KlMustBeString(writer, KlPosition(argc, argv, KlK_writer) + 1);
		if (writer->string[0] == '~') {
		    writer = KlExpandTildeForFiles(writer->string);
		}
		if (!(write_fd = fopen(writer->string, mode))) {
		    return KlOpenError(error, writer, KlK_output, 1);
		}
		mode = "r";
	    }
	} else {			/* input */
	    mode = "r";
	}

        /* check for exclusion, :if-exists :error */
	if (*mode == 'a' && if_exists == (KlO) KlK_error) {
	    int o_mode = (mode[1] == '+' ?
			  O_CREAT | O_EXCL | O_RDWR :
			  O_CREAT | O_EXCL | O_WRONLY);
	    int fdes = open((filename->string[0] == '~'
			     ? KlExpandTildeForFiles(filename->string)->string
			     : filename->string), o_mode, 0666);
	    if (fdes < 0 || !(fd = fdopen(fdes, mode))) { /* error, existed */
		return  KlOpenError(error, filename, direction, 1);
	    } 
	} else if (!(fd = fopen(	/* normal open */
	    (filename->string[0] == '~'
	     ? KlExpandTildeForFiles(filename->string)->string
	     : filename->string),
	    mode))) {
	    return  KlOpenError(error, filename,
				write_fd ? KlK_input : (KlKeyword) direction, 1);
	}

	stream = KlStreamMake(fd,
			      direction == (KlO) KlK_output ? 2 :
			      direction == (KlO) KlK_io ? 3 :
			      1,
			      filename->string);
	if (write_fd) {
	    stream->write_fd = write_fd;
	}
	if (buffered == NIL) {		/* unbuffer stream */
	    setbuf(((stream->direction & KlStreamOWRITE) && write_fd
		    ? write_fd
		    : fd),
		   0);
	}
	if (direction == (KlO) KlK_output
	    && if_exists == (KlO) KlK_overwrite) {
	    fseek(fd, 0L, 0);
	    if (write_fd) {
		fseek(write_fd, 0L, 0);
	    }
	}
	if (no_delay) {
	    KlSetFILENoBlocking(fd, 1, &(stream->blocking));
	    if (writer)
		KlSetFILENoBlocking(write_fd, 1, &(stream->blocking_write));
	}
	return stream;
    } else if (filetype == (KlO) KlK_string) {	/* string stream */
	KlStreamString stream;

	KlMustBeAModifiableString(filename, 0);
	stream =
	    KlStreamStringMake(filename,
			       direction == (KlO) KlK_output ? 2 :
			       direction == (KlO) KlK_io ? 3 :
			       1);
	
	if (direction == (KlO) KlK_output
	    || direction == (KlO) KlK_io) {
	    if (if_exists == (KlO) KlK_append) {
		stream->cursor = KlModStringLength(stream->klstring);
	    } else if (if_exists == (KlO) KlK_supersede) {
		stream->klstring->string[0] = '\0';
                KlModStringSetLength(stream->klstring, 0);
	    }
	    /* overwrite ==> cursor = 0 */
	}
	return (KlStream) stream;
    } else if (filetype == (KlO) KlK_tcp) {	/* tcp socket stream */
	return KlSocketMake(filename, KlK_tcp, error, direction, 
			    buffered, blocking);
    } else if (filetype == (KlO) KlK_udp) {	/* udp socket stream */
	return KlSocketMake(filename, KlK_udp, error, direction, 
			    buffered, blocking);

    } else if (filetype == (KlO) KlK_pipe) { /* a bidirectional pipe */
	int pipe_fds[2];		/* opened in IO mode */
	KlStream stream;
	if (pipe(pipe_fds) < 0) {
	    KlOpenError(0, filename, KlK_io, 1);
	}
	stream = KlStreamMake(fdopen(pipe_fds[0], "r"), 3, filename->string);
	stream->write_fd = fdopen(pipe_fds[1], "w");
	stream->subtype = KlStreamProcessType;
	/* non-buffered? */
	if (KlFalseP(buffered)) {
	    setbuf(stream->write_fd, 0);
	}
	/* non-blocking? */
	if (KlFalseP(blocking)) {
	    KlSetFILENoBlocking(stream->fd, 1, &(stream->blocking));
	    KlSetFILENoBlocking(stream->write_fd, 1, &(stream->blocking));
	}
    } else {				/* default: unknown keyowrd error */
	return (KlStream) 
	    KlError3(KlE_INVALID_KEYWORD_VALUE, filetype, KlK_type, 
		     KlListNullTerminated(KlOpenKV_filetype));
    }

}

/* KlOpenError
 */

KlStream
KlOpenError(error, name, mode, reason)
    KlO error;
    KlString name;
    KlKeyword mode;
    char *reason;			/* string or null or 1 for errno */
{
    if (error) {
	return (KlStream) KlSend_eval(error);
    } else {
	return (KlStream) KlError3(KlE_ERROR_OPENING_FILE, name, mode,
				   (reason == (char *) 1 
				    ? (KlO) KlErrnoGet(errno)
				    : (KlO) KlStringMake(reason ? reason : "")));
    }
}

/* auxilliary function */

#ifdef SYSV
#define KlNDELAY O_NDELAY
#else
#define KlNDELAY FNDELAY
#endif

KlSetFILENoBlocking(fp, flag, klone_flag)
    FILE *fp;
    int flag;
    char *klone_flag;
{
    int file_mode;

    fcntl(KlFp2Fd(fp), F_GETFL, &file_mode);
    if (flag)
	file_mode |= KlNDELAY;	/* set non-blocking flag */
    else
	file_mode &= ~KlNDELAY;	/* remove non-blocking flag */
    fcntl(KlFp2Fd(fp), F_SETFL, file_mode);
    *klone_flag = flag ? 0 : 1;		/* set blocking flag to opposite */
}

/*****************************************************************************\
* 				 KlStreamMode                                 *
\*****************************************************************************/
/* stream-mode stream
 * :writer t|()
 * :blocking t|()
 * :buffered t|()			only buffered () does something
 * (stream-mode [:writer flag]) lists modes as a plist
 * (stream-mode :buffered ()) MUST be done before first read or write
 */
    
KlO
KlStreamMode(argc, argv)
    int argc;
    KlO *argv;
{
    KlO writer, blocking, buffered;
    KlStream stream;
    FILE *fp;
    char *flagp;


    KlParseKeywords(argc, argv, 1);
    writer =  KlKeyVal(KlK_writer, NIL);
    blocking =  KlKeyVal(KlK_blocking, 0);
    buffered = KlKeyVal(KlK_buffered, 0);
    KlCheckUnvalidKeywords(argc, argv, 1);

    stream = (KlStream) argv[0];
    KlMustBeStream(stream, 0);

    if ((stream->subtype & KlStreamFileType) && KlStreamNotClosed(stream)) {
	if (KlTrueP(writer) && stream->write_fd) {
	    fp = stream->write_fd;
	    flagp = &(stream->blocking_write);
	} else {
	    fp = stream->fd;
	    flagp = &(stream->blocking);
	}

	if (blocking) {			/* set */
	    KlSetFILENoBlocking(fp, KlFalseP(blocking), flagp);
	}
	if (buffered && KlFalseP(buffered)) {
	    setbuf(fp, 0);
	}
	if (!blocking && !buffered) {			/* get */
	    if (KlTrueP(writer) && stream->write_fd) {
		return (KlO) KlListPairMake(KlK_blocking,
					    stream->blocking_write
					    ? TRU : NIL);
	    } else {
		return (KlO) KlListPairMake(KlK_blocking,
					    stream->blocking ? TRU : NIL);
	    }
	}
    }
    return (KlO) stream;
}

/*****************************************************************************\
* 				   KlFseek                                    *
\*****************************************************************************/
/* KlFseek
 * seeking into a file 
 * (file-position stream &optional offset from_where)
 * from_where = 0,1,2 for start,current_pos,end of file
 * returns t (success) () (failure)
 * other values = ftell (default)
 */

KlO
KlFseek(argc, argv)
    int argc;
    KlO *argv;
{
    KlStreamString stream;
    int offset = 0;
    int from_where = -1;
    KlO result = TRU;

    switch(argc) {
    case 1:
	break;
    case 2:
	KlMustBeNumber(argv[1], 1);
	offset = ((KlNumber) argv[1])->number;
	from_where = 0;
	break;
    case 3:
	KlMustBeNumber(argv[1], 1);
	KlMustBeNumber(argv[2], 2);
	offset = ((KlNumber) argv[1])->number;
	from_where = ((KlNumber) argv[2])->number;
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }

    stream = (KlStreamString)  argv[0];
    KlMustBeStream(stream, 0);

    stream->parse_dirty = 1;

    if (stream->subtype & KlStreamFileType) {
	if (((unsigned int) from_where) > 2) {
	    return (KlO) KlNumberMake(ftell(((KlStream) stream)->fd));
	} else {
	    if (fseek(((KlStream) stream)->fd, offset, from_where))
		result = NIL;		/* -1 = failure */
	}
    } else {				/* string streams */
	int len = KlModStringLength(stream->klstring);
	int pos;

	switch (from_where) {
	case 0:
	    pos = offset;
	    break;
	case 1:
	    pos = stream->cursor + offset;
	    break;
	case 2:
	    pos = len + offset;
	    break;
        default:
	    return (KlO) KlNumberMake(stream->cursor);
	}
	if (pos >= 0) {
	    if (pos >= stream->limit) {
		if (KlHasTrait(stream->klstring, KlTrait_unreallocable)) {
		    return KlError(KlE_NO_APPEND, stream->klstring);
		}
		stream->limit = KlMallocChunkSize(pos + 1);
		stream->klstring->string = (char *)
		    Realloc(stream->klstring->string, stream->limit);
	    }
	    stream->cursor = pos;
	    if (pos > len) {		/* if past the end, fill with blanks */
		bzero(stream->klstring->string+len, pos-len);
		stream->klstring->string[pos] = '\0';
		KlModStringSetLength(stream->klstring, pos);
	    }
	} else
	    result = NIL;
    }
    return result;
}

/* printing streams
 */

KlO
KlStreamPrint(obj, stream)
    KlStream obj;
    KlStream stream;
{
    KlSPrintf(stream, "{^ %s", KlTypeCName(obj->type));
    KlSPrintf(stream, " 0x%x ", obj);
    if (obj->subtype & KlStreamFileType) {
	KlSPrintf(stream, "\"%s\"", obj->name);
	if (KlStreamNotClosed(obj))
	    KlSPrintf(stream, " fd=%d", KlFp2Fd(obj->fd));
    } else {
	KlSend_print(KlA_String, stream);
    }
    KlSPrintf(stream, " %s}", KlStreamDirectionsText[obj->direction]);
    return (KlO) obj;
}

/* closing streams
 * (close stream [ :writer t|() ] )
 * writer allows you to close only one direction of a bidirectional stream
 * may not work on streams where the underlying fd is the same but fdopened 
 * via 2 different fps (sockets), it will generate a close error
 */

KlO
KlStreamClose(argc, argv)
    int argc;
    KlO *argv;
{
    KlStream obj;
    KlO writer;
    int close_error = 0;			/* keep flag  */

    KlParseKeywords(argc, argv, 1);
    writer =  KlKeyVal(KlK_writer, 0);
    KlCheckUnvalidKeywords(argc, argv, 1);
    obj = (KlStream) argv[0];
    KlMustBeStream(obj, 0);

    /* nothing is needed to be done for strings */
    /* we do not send kill to the process */
    if (obj->subtype & KlStreamFileType) {
	if (obj->direction) {
	    signal(SIGPIPE, SIG_IGN);
	    if (writer && obj->direction == 3) { /* we close only one dir */
		if (KlTrueP(writer)) {	/* close output dir */
		    if (obj->write_fd) {
			if (fclose(obj->write_fd))
			    close_error = 1;
			obj->write_fd = 0;
		    }
		    obj->direction = 1;
		} else {		/* close input dir */
                    if (obj->write_fd) {
			fclose(obj->fd);
			obj->fd = obj->write_fd;
			obj->write_fd = 0;
		    }
		    obj->direction = 2;
		}
		KlTrapSIGPIPE();
		goto end;
	    } else {
		int not_same_underlying_fd;
		if (obj->direction == 3 && obj->write_fd && obj->fd && 
		    (KlFp2Fd(obj->fd) == KlFp2Fd(obj->write_fd))) {
		    not_same_underlying_fd = 0;
		} else {
		    not_same_underlying_fd = 1;
		}
		/* close first output, we may have data to flush */
		if (obj->write_fd) {
		    if (fclose(obj->write_fd)) {
			close_error = 1;
		    }
		    obj->write_fd = 0;
		}
		/* then input, it doesnt matter if it was closed above */
		if (fclose(obj->fd) && (obj->direction & 2) 
		    && not_same_underlying_fd) {
		    close_error = 1;
		}
		obj->fd = 0;
	    }
	    KlTrapSIGPIPE();
	}
    }
    obj->direction = 0;
  end:
    if (close_error)
	KlError2(KlE_STREAM_ERROR, KlA_write, obj);
    return NIL;
}

/* freeing streams (closes files)
 */

KlO
KlStreamFree(obj)
    KlStream obj;
{
    if (obj->subtype == KlStreamStringType) { /* strings */
	KlDecRef(((KlStreamString) obj)->klstring);
    } else {				/* file & processes */
	KlStreamClose(1, &obj);
	Free(obj->name);
    }
    Klyy_delete_buffer(obj->parse_state); /* can be passed a NULL ptr */
    Free(obj);
    return (KlO) obj;
}

/*ARGSUSED*/
KlResetStdout(old, dummy)
    KlStream old;
    KlO dummy;
{
    KlStdout = old;
}

/*****************************************************************************\
* 				IO redirection                                *
\*****************************************************************************/
/* active values on:
 * *standard-input* [497]
 * *standard-output*
 * *standard-error*
 */

KlO
KlStreamStdGet(stptr)
    KlStream *stptr;
{
    return (KlO) * stptr;
}

KlO
KlStreamStdSet(obj, stptr)
    KlStream obj;
    KlStream *stptr;
{
    KlMustBeStream(obj, 0);
    if (stptr == &KlStdin) {
	KlStreamCanREAD(obj);
    } else {
	KlStreamCanWRITE(obj);
	KlFlush(0);
    }

    KlDecRef(*stptr);
    KlIncRef(*stptr = obj);

    return (KlO) obj;
}

/*****************************************************************************\
* 				parsing stream                                *
\*****************************************************************************/

extern struct yy_buffer_state *Klyy_scan_bytes();		/* flex */
extern struct yy_buffer_state *Klyy_create_buffer();	/* flex */

/* to redirect parsing stream
 * returns old stream (or 0 if not changed)
 * it now relies heavily on flex mecanisms to do so
 */

KlStream
KlStdyyRedirect(stream)
    KlStream stream;
{
    if (stream != KlStdyy) {		/* do nothing if same */
	KlStream oldstream;
	int unswitched = 1;
	KlMustBeStream(stream, 0);
	KlStreamCanREAD(stream);
	/* init place to hold the flex parse state if necessary */
	if (!stream->parse_state) {
	    if (stream->subtype == KlStreamStringType) {
		/* note: this copies the data, since flex modifies its input */
		int cursor = ((KlStreamString) stream)->cursor;
		stream->parse_state = Klyy_scan_bytes(
		    ((KlStreamString) stream)->klstring->string + cursor,
		    ((KlStreamString) stream)->klstring->size - cursor);
		unswitched = 0;		/* this function switches */
	    } else {
		stream->parse_state = 
		    Klyy_create_buffer(stream->fd, Klyy_buf_size);
		/* by default we refuse to use the flex bufferisation as it 
		   interferes too much with fseek-ing. only load uses it */
		Klyy_set_bufferized(stream->parse_state, 
				    stream->parse_bufferized);
	    }
	}
	
	oldstream = KlStdyy;
	oldstream->read_expr = KlReadExpr;
	KlReadExpr = stream->read_expr;
	KlDecRef(KlStdyy);
	KlIncRef(KlStdyy = stream);
	KlStdyy->parse_disabled = 0;
	if (unswitched)
	    Klyy_switch_to_buffer(stream->parse_state); /* flex function */
	return oldstream;
    } else {
	return stream;
    }
}

/* init parse stream to stdin */
KlStdyyInit()
{
    KlIncRef(KlStdyy = KlStdin);
    KlStdyy->parse_state = Klyy_create_buffer(KlStdyy->fd, Klyy_buf_size);
    Klyy_switch_to_buffer(KlStdyy->parse_state);
}

/* stream is dirty, clean it */
KlStdyyReset(stream)
    KlStream stream;
{
    if (stream->parse_state) {		/* no need to RE-set if not set */
	if (stream->subtype == KlStreamStringType) {
	    /* for strings, we brutally reset by deleting/recreating */
		int cursor = ((KlStreamString) stream)->cursor;
		Klyy_delete_buffer(stream->parse_state);
		stream->parse_state = Klyy_scan_bytes(
		    ((KlStreamString) stream)->klstring->string + cursor,
		    ((KlStreamString) stream)->klstring->size - cursor);
	} else {
	    /* for files, flex provides us with a more efficient method */
	    /* normally should be only necessary for bufferized streams) */
	    if (stream->parse_bufferized)
		Klyy_flush_buffer(stream->parse_state);
	}
    }
    stream->parse_dirty = 0;		/* cleaned */
}

/* functions used to print where we are in the loaded file */

char *
KlIsReadingFile()
{
    if (
	KlStdyy &&
	KlStdyy->subtype == KlStreamFileType &&
	KlStdyy->name && *(KlStdyy->name) &&
	KlStdyy->fd) {
	return KlStdyy->name;
    }
    return 0;
}

/*
 * KlRead: is now a macro
 * reads an expression from the input (string or stream).
 * returns this expression or NULL if EOF reached
 * In case of syntax error, returns NIL
 * the read expression is in the global variable KlReadExpr,
 * if you need it. (this global is maintained for ref count purposes)
 * You don't need to free it since it's done at the beginning of this
 * routine.
 * Beware that it could be overwritten by a subsequent call to KlEval
 * or KlRead !
 */

static
KlReadKlAux(oldpos, oldstream)
    char *oldpos;
    KlStream oldstream;
{
    ((KlStreamString) KlStdyy)->cursor += (Klyy_bufptr() - oldpos);
    KlStdyyRedirect(oldstream);    
}

/* The klone-callable read function
 * jumps to tag EOF on EOF
 */

KlO
KlReadKl(argc, argv)
    int argc;
    KlO *argv;
{
    KlStream oldstream = KlStdyy;
    KlO result = NIL;

    if (argc) {
	KlMustBeStream(argv[0], 0);
	KlStreamCanREAD(((KlStream)argv[0]));
	if (argc > 2)
	    return KlBadNumberOfArguments(argc);
	oldstream = KlStdyyRedirect(argv[0]);
    }
    if (KlStdyy->parse_dirty)		/* some seek happened meanwhile */
	KlStdyyReset(KlStdyy);
    
    if (KlStdyy == oldstream) {		/* no need to redirect back */
	Klyyparse();
    } else {
	if (KlStdyy->subtype == KlStreamStringType) {
	    /* we must increment by hand the cursor position for strings */
	    char *oldpos = Klyy_bufptr();
	    KlUnwindProtectStatement((Klyyparse(), result = KlReadExpr),
				     KlReadKlAux, oldpos, oldstream);
	} else {
	    KlUnwindProtectStatement((Klyyparse(), result = KlReadExpr),
				     KlApplyUnary, KlStdyyRedirect, oldstream);
	}
    }
    /* note that we couldnt use KlReadExpr directly as it was modified by the
     * restoring KlStdyyRedirect to oldstream
     */
    if (result) 
	return result;
    else
	if (argc >= 2)
	    return KlSend_eval(argv[1]);
	else
	    KlThrow(KlA_EOF, NIL);		/* EOF */
    /* NOTREACHED */
}

/* KlDoReadAndEval
 * Low-level function to parse and evaluate all exprs of current stdin
 * does not perform any GC itself
 */

KlO
KlDoReadAndEval()
{
    KlO result = NIL;
    KlO PreviousExpr;
    if (!KlRead()) goto end_empty;
    PreviousExpr = KlReadExpr;
    while (KlRead()) {
	if (KlReadExpr == (KlO) KlA_equal && KlInfixAssigns) {
	    /* x = y, create assign */
	    if (!(KlRead()))	/* x = EOF */
		goto end;
	    PreviousExpr = (KlO) KlAssignMake(PreviousExpr, KlReadExpr);
	} else {			/* normal */
	    KlSend_eval(PreviousExpr);
	    PreviousExpr = KlReadExpr;
	}
    }
end:
    result = KlSend_eval(PreviousExpr);
end_empty:
    return result;
}

/* KlParseString
 * parses a C string and returns expr. (with execute parameter 0)
 * raw no-error-checking function to be used in C initialisations
 */

KlO
KlParseStringRaw(execute)
    int execute;			/* 0= only parse, 1= real/+eval loop */
{
    KlO result = NIL;
    if (execute) {
	result = KlDoReadAndEval();
    } else {
	Klyyparse(), result = KlReadExpr ? KlReadExpr : NIL;
    }
    return result;
}

KlO
KlParseString(l, s, execute)
    int l;				/* length of string */
    char *s;
    int execute;                        /* 0= only parse, 1= real/+eval loop */
{
    KlStream oldstream = 0;
    KlO result;

    oldstream = KlStdyyRedirect(KlStreamStringMake(KlStringPtrMake(l, s),
						   1));
    KlUnwindProtectStatement(result = KlParseStringRaw(execute), KlApplyUnary,
			     KlStdyyRedirect, oldstream);
    return result;
}

/*****************************************************************************\
* 				      IO                                      *
\*****************************************************************************/

/* flushing a stream
 * 0 = stdout + stderr
 */

KlO
KlFlush(obj)
    KlStream obj;
{
    if (obj && KlTrueP(obj)) {
	if (obj->type == KlStreamType
	    && (obj->subtype & KlStreamFileType)) {
	    if (obj->direction & KlStreamOWRITE) {
		if (fflush(KlStreamWriteFd(obj)))
		    KlError2(KlE_STREAM_ERROR, KlA_write, obj);
		/* for streams in :io mode, we must also do a filepos op
		 * to avoid getting garbage from bufferisation
		 */
		if ((obj->direction & KlStreamOREAD)
		    && !(obj->write_fd)) {
		    fseek(obj->fd, 0L, SEEK_CUR); /* noop to synchronise */
		}
	    }
	}
    } else {
	if (KlStdout->subtype & KlStreamFileType
	    && KlStdout->direction & KlStreamOWRITE)
	    if (fflush(KlStreamWriteFd(KlStdout)))
		KlError2(KlE_STREAM_ERROR, KlA_write, KlStdout);
	if (KlStderr->subtype & KlStreamFileType
	    && KlStderr->direction & KlStreamOWRITE)
	    if (fflush(KlStreamWriteFd(KlStderr)))
		KlError2(KlE_STREAM_ERROR, KlA_write, KlStderr);
    }
    return NIL;
}

/***********************\
* C- callable functions *
\***********************/

/* prints a printf-formatted string */

KlSPrintf(stream, format, string)
    KlStream stream;
    char *format;
    char *string;
{
    KlStreamCanWRITE(stream);
    if (stream->subtype == KlStreamStringType) {
	char tmp[KlMAX_TEMP_STRING_SIZE];

	sprintf(tmp, format, string);
	KlSPuts(tmp, stream);
    } else {
	fprintf(KlStreamWriteFd(stream), format, string);
    }
}

/* to print readably without enclosing double-quotes in KlPrintFormatAux */
#define PFPRINT(l, s, st) if(must_unstrip) \
    KlSPuts(KlUnstripString(l, s), st); else KlSPutBytes(l, s, st);
static char *percent_string = "%";

/* print-format
 * (print-format stream format arguments...)
 * %NN are replaced by the printing of the N-th argument
 * for 0 <= N 
 * (type of object can be printed also by %tN)
 * %N can be printed readably by %rN
 * %lN prints readably and quotes newlines
 * % is printed by %%
 * %ffunc-nameN applies func-name to argN and prints result
 * %sN prints it in raw string mode ^Sstring^S
 * if format is not a string it is applied to arguments and the result is
 * used as format
 */
    
KlPrintFormatAux(stream, argc, argv)
    KlStream stream;
    int argc;
    KlO *argv;
{
    char *format, *p, *end;
    int pos;
    int print_with_type;		/* 0= no, 1 = yes */
    int print_readably;			/* 0=as is, 1= no, 2 = readably */
    int quote_newlines;			/* 0= no, 1 = yes */
    KlString klformat = (KlString) argv[1];
    int prv = KlPrintReadably;
    int qnl = KlQuoteNewlines;
    int must_unstrip = (KlPrintReadably && !KlPrintAsRawStrings
			&& !KlPrintFormatOldBehavior);

    if (klformat->type != KlStringType) { /* if not a string, apply */
	if (KlIsAnAtom(klformat) && KlIsAString(((KlAtom)klformat)->c_val)) {
	    klformat = (KlString) ((KlAtom)klformat)->c_val;
        } else {

	    KlList call = KlListKl(argc - 1, argv + 1);

	    klformat = (KlString) KlApply(call);
	    KlMustBeString(klformat, 1);
	}
    }
    format = klformat->string;
    end = format + KlStringLength(klformat);
    if (prv && !KlPrintFormatOldBehavior)
	KlSPutc(KlPrintAsRawStrings ? 30 : 34, stream);
    for (p = format; p < end; p++) {
	if (*p == '%') {		/* see a subst place */
	    KlO funcname = 0;
	    int option_char = 1;
	    int print_raw = 0;
	    PFPRINT(p - format, format, stream); /* print up to it */
	    print_with_type = 0;
	    print_readably = 0;
	    quote_newlines = 0;
	    do {			/* interpret options */
		switch (*(++p)) {
		case 'r' :		/* print-readably */
		    print_readably = 2;
		    break;
		case 'n':		/* not print-readably (normal) */
		    print_readably = 1;
		    break;
		case 't':		/* prints type */
		    print_with_type = 1;
		    break;
		case 'l':		/* readably & quote newlines */
		    quote_newlines = 1;
		    print_readably = 2;
		    break;
		case 'f':		/* apply a function */
		{
		    char *start = ++p;
		    while (isalpha(*p) || strchr(":-_", *p)) {
			p++;
		    }
		    funcname = (KlO) KlInternBytes(p - start, start);
		    p--;
		}
		break;
		case 's' :
		    print_raw = 1;
		    break;
		default:		/* %%: prints second char */
		    option_char = 0;
		}
	    } while (option_char);

	    if (isdigit(*p)) {
		pos = (*p) - '0' + 2;
		while (isdigit(*(p+1))) {
		    pos = (pos * 10) + (*(++p));
		}
		if (pos >= 2 && pos < argc) {
		    KlO arg = funcname ? KlApplyV(funcname, 1, argv[pos]) 
			: argv[pos];
		    if (print_raw) {
			if (!KlIsAString(arg))
			    arg = KlCoerce(arg, KlStringType);
			KlSPutBytes(KlStringLength((KlString) arg), 
				    ((KlString) arg)->string, stream);
		    } else {
			if (print_readably)
			    KlPrintReadably = print_readably - 1;
			if (quote_newlines)
			    KlQuoteNewlines = 1;
			if (print_with_type) {
			    KlSPuts(KlTypeCName(arg->type), stream);
			} else {
			    KlSPrint(arg, stream);
			}
			if (print_readably)
			    KlPrintReadably = prv;
			if (quote_newlines)
			    KlQuoteNewlines = qnl;
		    }
		}
	    } else if (*p == '%') {	/* %% = % */
		PFPRINT(1, percent_string, stream);
	    } else if (*p == '\0') {	/* % at end */
		PFPRINT(1, percent_string, stream);
		p--;
	    } else {			/* %<any_char> = % */
		PFPRINT(1, percent_string, stream);
		PFPRINT(1, p, stream);
	    }
	    format = p+1;		/* make the start next char */
	}
    }
    PFPRINT(end - format, format, stream);
    if (prv && !KlPrintFormatOldBehavior)
	KlSPutc(KlPrintAsRawStrings ? 30 : 34, stream);
}

KlO
KlPrintFormat(argc, argv)
    int argc;
    KlO *argv;
{
    KlStream stream;

    KlNumberOfArgumentsCheck(argc < 1, argc);
    /* decode the polymorph first argument */
    if (KlIsAString(argv[0])
	       && !KlIsASymbol(argv[0])) { /* stream arg can be omitted */
	stream = KlStdout;	
	argc++;
	argv--;
    } else if (KlIsAStream(argv[0])) {	/* normal case, stream */
	stream = (KlStream) argv[0];
	KlStreamCanWRITE(stream);
    } else if ((argv[0] == (KlO) KlStringType) /* create new string stream */
	       || (argv[0] == (KlO) KlA_String)) {
	KlStreamString klstream = KlStreamStringMake(KlStringMake(0), 3);
	KlPrintFormatAux(klstream, argc, argv);
	return (KlO) klstream->klstring;
    } else if (argv[0] == NIL) {		/* () = stdout */
	stream = KlStdout;
    } else {
	KlMustBeStream(argv[0], 0);	/* give meaningful error mess */
    }
    if (argc > 1)			/* argv[0] is the stream */
	KlPrintFormatAux(stream, argc, argv);
    return NIL;
}

/* KlSPutBytes
 * the heart of printing in Klone. Nearly all output goes through this.
 */

KlSPutBytes(length, buffer, stream)
    int length;
    char *buffer;
    KlStreamString stream;
{
    if (stream->subtype == KlStreamStringType) {
	if ((stream->cursor + length) >= stream->limit) {	/* realloc */
	    if (KlHasTrait(stream->klstring, KlTrait_unreallocable)) {
		return (int) KlError(KlE_NO_APPEND, stream->klstring);
	    }
	    stream->limit = KlMallocChunkSize(stream->cursor + length + 1);
	    stream->klstring->string = (char *)
		Realloc(stream->klstring->string, stream->limit);
	    stream->klstring->string[stream->cursor + length] = '\0';
	}
	bcopy(buffer, stream->klstring->string + stream->cursor, length);
	stream->cursor += length;
	if (stream->cursor >= KlModStringLength(stream->klstring)) {
	    /* we extended the string, let's add a null byte for C compat */
	    KlModStringSetLength(stream->klstring, stream->cursor);
	    stream->klstring->string[stream->cursor] = '\0';
	}
    } else {
	if (length !=
	    fwrite(buffer, 1, length, KlStreamWriteFd((KlStream) stream))) {
	    KlError2(KlE_STREAM_ERROR, KlA_write, stream);  /* no space left */
	}
    }
}

/* KlSPuts
 * prints a string. Mainly used from short C strings now that 
 * Klone strings are byte stings
 */

KlSPuts(string, stream)
    char *string;
    KlStreamString stream;
{
    if (stream->subtype == KlStreamStringType) {
	KlSPutBytes(strlen(string), string, stream);
    } else {
	if (EOF == fputs(string, (KlStreamWriteFd((KlStream) stream)))) {
	    /* error: no space left */
	    KlError2(KlE_STREAM_ERROR, KlA_write, stream);
	}
    }
}

/* reading a string
 * returns pointer to static storage or 0 on EOF
 * reads till \n or eof, do not returns final \n.
 * mistakes NULL bytes in the input for EOF!, but this provides mucho speed!
 */

static int KlGets_tmpl;
static char *KlGets_tmp;

char *
KlGets(stream, lenptr)
    KlStream stream;
    int *lenptr;			/* returns length of string */
{
    int length;

    if (stream->subtype == KlStreamStringType) { /* string */
	KlStreamString klstream = (KlStreamString) stream;
	char *start = klstream->klstring->string + klstream->cursor;
	char *end = klstream->klstring->string + 
	    KlStringLength( klstream->klstring);
	char *p = start;

	if (start == end)		/* EOF */
	    return 0;
	while (p < end && *p != '\n')
	    p++;
	length = p - start;
	if (length >= KlGets_tmpl) {
	    KlGets_tmpl = length;
	    KlGets_tmp = (char *) Realloc(KlGets_tmp, KlGets_tmpl + 1);
	}
	bcopy(start, KlGets_tmp, length);
	KlGets_tmp[length] = '\0';
	klstream->cursor = p - klstream->klstring->string + 
	    ((p < end) ? 1 : 0);	/* skip newline, unless at EOF */
	*lenptr = length;
	return KlGets_tmp;
    } else {				/* file */
	return KlFGets(stream->fd, lenptr);
    }
}

/* KlFGets
 * useful function to read an unlimited line (but terminates on '\0')
 */

char *
KlFGets(fd, lenptr)
    FILE *fd;
    int *lenptr;
{
    char *p = KlGets_tmp;
    int length;

    KlGets_tmp[KlGets_tmpl - 2] = '\0'; /* marker overriden when more */
    while (fgets(p, KlGets_tmpl - (p - KlGets_tmp), fd)) {
	if (KlGets_tmp[KlGets_tmpl - 2]
	    && KlGets_tmp[KlGets_tmpl - 2] != '\n') { /* more to read */
	    KlGets_tmpl += 1024;
#ifdef VOID_MALLOC
	    KlGets_tmp = (char *) Realloc(KlGets_tmp, KlGets_tmpl);
#else
	    KlGets_tmp = (char *) Realloc(KlGets_tmp, KlGets_tmpl);
#endif /* VOID_MALLOC */
	    p = KlGets_tmp + KlGets_tmpl - 1 - 1024;
	    KlGets_tmp[KlGets_tmpl - 2] = '\0';
	} else {			/* done */
	    goto done;
	}
    }
    if (p == KlGets_tmp)		/* EOF */
	return 0;
 done:
    /* trim last newline if present and return */
    length = strlen(KlGets_tmp);
    if (length > 0 && KlGets_tmp[length - 1] == '\n')
	KlGets_tmp[--length] = '\0';
    else
	KlGets_tmp[length] = '\0';
    *lenptr = length;
    return KlGets_tmp;
}

/* reading a char
 * retunrs EOF on eof
 */

int
KlGetc(stream)
    KlStream stream;
{
    if (stream->subtype == KlStreamStringType) {
	KlStreamString klstream = (KlStreamString) stream;
	char *p = klstream->klstring->string + klstream->cursor;

	if (klstream->cursor < KlStringLength(klstream->klstring)) {
	    klstream->cursor++;
	    return *p;
	} else {
	    return EOF;
	}
    } else {
	return getc(stream->fd);
    }
}

/*************************\
* klone-callable functions *
\*************************/

KlResetKlPrintLevel(a, b)
    KlO a, b;
{
    KlPrintLevel = -1;
}

/*
 *  ? (or print) simply print value of an object
 */
/* klone-level one,  handling *print-level*
 */

KlO
KlPrintNary(argc, argv)
    int argc;
    KlO argv[];
{
    int i;

    if (KlPrintLevel >= 0) {		/* we are inside a print */
	for (i = 0; i < argc; i++)
	    KlSend_print(argv[i], KlStdout);
    } else {				/* we start printing, init p-l */
	KlPrintLevel = 0;
	KlUnwindProtectStatement
	    (for (i = 0; i < argc; i++) KlSend_print(argv[i], KlStdout),
	     KlResetKlPrintLevel, 0, 0);
    }
    KlFlush(0);
    return argc ? argv[argc - 1] : NIL;
}

/* low-level one, do not handle *print-level*
 */

KlO
KlWrite(argc, argv)
    int argc;
    KlO *argv;
{
    switch (argc) {
    case 1:
	KlSend_print(argv[0], KlStdout);
	break;
    case 2:
	KlMustBeStream(argv[1], 1);
	KlStreamCanWRITE(((KlStream) argv[1]));
	KlSend_print(argv[0], argv[1]);
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    return argv[0];
}

/* klone-level one,  handling *print-level*
 */

KlO
KlWriteKl(argc, argv)
    int argc;
    KlO *argv;
{
    if (KlPrintLevel >= 0) {		/* we are inside a print */
	return KlWrite(argc, argv);
    } else {				/* we start printing, init p-l */
	KlO result;
	KlPrintLevel = 0;
	KlUnwindProtect(KlWrite(argc, argv), result, KlResetKlPrintLevel,
			0, 0);
	return result;
    }
}

KlO
KlWriteChar(argc, argv)
    int argc;
    KlO *argv;
{
    KlStream stream;

    switch (argc) {
    case 1:
	stream = KlStdout;
	break;
    case 2:
	stream = (KlStream) argv[1];
	KlMustBeStream(stream, 1);
	KlStreamCanWRITE(stream);
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    if (KlIsAString(argv[0])) {
	KlSPuts(((KlString) argv[0])->string, stream);
    } else {
	KlMustBeNumber(argv[0], 0);
	KlSPutc(((KlNumber) argv[0])->number, stream);
    }
    return argv[0];
}

KlO
KlWriteLine(argc, argv)
    int argc;
    KlString *argv;
{
    KlStream stream;

    switch (argc) {
    case 1:
	stream = KlStdout;
	break;
    case 2:
	stream = (KlStream) argv[1];
	KlMustBeStream(stream, 1);
	KlStreamCanWRITE(stream);
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    KlMustBeString(argv[0], 0);
    KlSPutBytes(KlStringLength(argv[0]), argv[0]->string, stream);
    KlSPutc('\n', stream);
    return (KlO) argv[0];
}

/* read functions callable from klone */

KlO
KlReadChar(argc, argv)
    int argc;
    KlStream *argv;
{
    KlStream stream;
    int c;

    switch (argc) {
    case 0:
	stream = KlStdin;
	break;
    case 1: case 2:
	stream = argv[0];
	KlMustBeStream(stream, 0);
	KlStreamCanREAD(stream);
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    c = KlGetc(stream);
    if (c == EOF) {
	if (argc == 2)
	    return KlSend_eval(argv[1]);
	else
	    KlThrow(KlA_EOF, NIL);
	/* NOTREACHED */
    } else {
	return (KlO) KlNumberMake(c);
    }
}

KlO
KlReadLine(argc, argv)
    int argc;
    KlStream *argv;
{
    KlStream stream;
    char *s;
    int len;

    switch (argc) {
    case 0:
	stream = KlStdin;
	break;
    case 1: case 2:
	stream = argv[0];
	KlMustBeStream(stream, 0);
	KlStreamCanREAD(stream);
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    if (s = KlGets(stream, &len)) {
	return (KlO) KlStringMakeFromBytes(len, s);
    } else {
	if (argc == 2)
	    return KlSend_eval(argv[1]);
	else
	    KlThrow(KlA_EOF, NIL);
	/* NOTREACHED */
    }
}

/*****************************************************************************\
*        readwrite of N chars at a time, on possibly non-blocking streams     *
\*****************************************************************************/

/* (read-chars N [stream])
*/

KlO
KlReadChars(argc, argv)
    int argc;
    KlStream *argv;
{
    KlStream stream = KlStdin;
    int n = -1;

    switch (argc) {
    case 2:
	stream = argv[1];
	KlMustBeStream(stream, 1);
	KlStreamCanREAD(stream);
	/* no break intentional */
    case 1:
	if (KlTrueP(argv[0])) {
	    KlMustBeNumber(argv[0], 0);
	    n = ((KlNumber) argv[0])->number;
	}
	/* no break intentional */
    case 0:
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    if (stream->subtype == KlStreamStringType) { /* string */
	int nread;
	if (n >= 0) {			/* part */
	    nread = Min(n, (int) 
			KlStringLength(((KlStreamString) stream)->klstring)
			- ((KlStreamString) stream)->cursor);
	} else {			/* up to end  */
	    nread = (int) KlStringLength(((KlStreamString) stream)->klstring)
		- ((KlStreamString) stream)->cursor;
	}
	((KlStreamString) stream)->cursor += nread;
	return (KlO) KlStringMakeFromBytes
	    (nread, ((KlStreamString) stream)->klstring->string
	     + ((KlStreamString) stream)->cursor - nread);
    } else {			/* file */
	KlString s;
	clearerr(stream->fd);	/* reset eof indicator */
	if (n >= 0) {			/* part */
	    char *buffer = (char *) Malloc(n + 1);
	    int nread = fread(buffer, 1, n, stream->fd);
	    buffer[nread] = '\0';
	    s = KlStringMakeNoCopy(nread, buffer);
	    /* no Free of buffer, will be done by GC of s */
	} else {			/* whole: gobble up everything */
	    s = (KlString) KlStreamToStringCoerce(KlStringType, stream);
	}
	if (!KlModStringLength(s)	/* no input? maybe eof? */
	    && feof(stream->fd)) {
	    KlThrow(KlA_EOF, NIL);
	}
	return (KlO) s;
    }
}

/* (write-chars string N [stream] [offset])
 */

KlO
KlWriteChars(argc, argv)
    int argc;
    KlStream *argv;
{
    KlStream stream = KlStdout;
    KlString s;
    int n = -1;
    int offset = 0;

    switch (argc) {
    case 4:
	KlMustBeNumber(argv[3], 3);
	offset = ((KlNumber) argv[3])->number;
    case 3:
	stream = argv[2];
	KlMustBeStream(argv[2], 2);
	KlStreamCanWRITE(stream);
	/* no break intentional */
    case 2:
	if (KlTrueP(argv[1])) {
	    KlMustBeNumber(argv[1], 1);
	    n = ((KlNumber) argv[1])->number;
	}
	/* no break intentional */
    case 1:
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }

    s = (KlString) argv[0];
    KlMustBeString(argv[0], 0);
    if (n >= 0)
	n = Min(n, (int) KlStringLength(s) - offset);
    else
	n = KlStringLength(s) - offset;
    if (stream->subtype == KlStreamStringType) { /* no problemo */
	KlSPutBytes(n, s->string + offset, stream);
    } else {				/* file */
	n = fwrite(s->string + offset, 1, n,
		   KlStreamWriteFd((KlStream) stream));
    }
    return (KlO) KlNumberMake(n);
}

/**************************************************************************\
* 				    select                                 *
\**************************************************************************/
/* (select [:input] streams... [:output streams...] [:error streams]
 *         [:timeout milliseconds-or-nil])
 * works with buffering and strings!
 * returns () (no stream were ready, and timeout expired or signal received)
 * or a list of 3 lists being the lists of streams ready for input, output,
 * and having an exceptional condition pending.
 * streams can be streams or lists of streams which are expanded.
 * any stream can be () and is then ignored
 * :input keyword is implicitely delared at the start
 * :timeout 0 means non-blocking, nonexisting or () means blocks indefinitely
 *     (default)
 * keywords can appear in any order
 * select is made of :input (read), :output (write) or :error (execptional
 *     condition pending)
 * before going to the UNIX select() call observed streams are examined. If
 * one of them satisfies one of the following criteria, KlStreamSelect returns
 * immediately with the matching  streams without actually calling select(2)
 *  [1] buffered input file stream having some characters still in the input
 *      buffer in the FILE structure
 *  [2] string streams in read or write mode (always ready)
 * WARNING: (select) blocks indefinitely!
 * WARNING: select on a file at EOF returns true!. to test if a file is a EOF,
 *          if select is true but read-non-blocking returns 0, then EOF is 
 *          here.
 */

/* descriptor used to prepare the arguments lists to select(2) */
struct KlStreamList {
    int mode;				/* read, write or read&write (error) */
    fd_set set;				/* to be passed to select */
    KlList list;			/* list of selected streams */
    KlList ready_list;			/* results: streams with pending IO */
};

KlO
KlStreamSelect(argc, argv)
    int argc;
    KlStream *argv;
{
    int nfds = 0, n, i, res;
    struct KlStreamList arglists[3], *arglistp = &(arglists[0]);
    struct timeval timeout, *timeoutp = 0; /* blocking */
    KlStream *arg = argv, *last = argv+argc;

    for (i = 0; i < 3; i++) {		/* init the 3 KlStreamLists */
	FD_ZERO(&(arglists[i].set));
	arglists[i].list = KlListNMake(0);
	arglists[i].ready_list = KlListNMake(0);
	arglists[i].mode = i+1;		/* hack */
    }

    while (arg < last) {		/* parses args */
	if (KlIsAKeyword(*arg)) {	/* keyword change cur. KlStreamList */
	    if (KlK_timeout == (KlKeyword) *arg) {
		if (++arg < last && KlTrueP(*arg)) {
		    KlMustBeNumber(*arg, arg - argv);
		    timeout.tv_sec = ((KlNumber)*arg)->number / 1000;
		    timeout.tv_usec = (((KlNumber)*arg)->number % 1000) * 1000;
#ifdef AMIGA
		    if (((KlNumber)*arg)->number == 0)
			timeout.tv_usec = 1; /* bug in amiga select? */
#endif /* AMIGA */
		    timeoutp = &timeout;
		} else {
		    timeoutp = 0;	/* () ==> no timeout, blocking */
		}
	    } else if (KlK_input == (KlKeyword) *arg) {
		arglistp = arglists;
	    } else if (KlK_output == (KlKeyword) *arg) {
		arglistp = arglists + 1;
	    } else if (KlK_error == (KlKeyword) *arg) {
		arglistp = arglists + 2;
	    } else {
		KlKeyword KlSelectKeywords[5], *p = KlSelectKeywords;
		*p++ = KlK_input;
		*p++ = KlK_output;
		*p++ = KlK_error;
		*p++ = KlK_timeout;
		*p++ = 0;
		KlError2(KlE_INVALID_KEYWORD, *arg,
			 KlListNullTerminated(KlSelectKeywords));
	    }
	} else if (KlIsAList(*arg)) {	/* expand lists of streams */
	    for (i = 0; i < ((KlList) (*arg))->size; i++) {
		if ((n = KlStreamSelectArgAdd
		     (((KlList)(*arg))->list[i], arg-argv, arglistp))
		     > nfds)
		    nfds = n;
	    }
	} else {			/* simple case of a streams */
	    if ((n = KlStreamSelectArgAdd(*arg, arg-argv, arglistp)) > nfds)
		nfds = n;
	}
	arg++;
    }
    for (i = 0; i < 3; i++)		/* returns if something in buffers */
	if (arglists[i].ready_list->size) 
	    goto end;

					/* do the UNIX call */
    for (;;) {
	KlLastSignal = 0;
	res = select(nfds, &(arglists[0].set), &(arglists[1].set), 
		     &(arglists[2].set), timeoutp);
	if (res > 0) {
	    /* OK, constructs the returned triplet */
	    KlStream obj;
	    for (i = 0; i < arglists[0].list->size; i++) {
		if (KlIsAFileStream(obj = (KlStream) arglists[0].list->list[i])
		    && FD_ISSET(KlFp2Fd(obj->fd), &(arglists[0].set)))
		    KlListAppend(arglists[0].ready_list, obj);
	    }
	    for (i = 0; i < arglists[1].list->size; i++) {
		if (KlIsAFileStream(obj = (KlStream) arglists[1].list->list[i])
		    && FD_ISSET(KlFp2Fd(KlStreamWriteFd(obj)),
				&(arglists[1].set)))
		    KlListAppend(arglists[1].ready_list, obj);
	    }
	    for (i = 0; i < arglists[2].list->size; i++) {
		if (KlIsAFileStream(obj = (KlStream) arglists[2].list->list[i])
		    && (FD_ISSET(KlFp2Fd(obj->fd), &(arglists[2].set))
			|| (obj->write_fd
			    && FD_ISSET(KlFp2Fd(obj->write_fd),
					&(arglists[2].set)))))
		    KlListAppend(arglists[2].ready_list, obj);
	    }
	    goto end;
	} else if (res < 0) {		/* error (signal such as SIGCHLD) */
	    if (errno != EINTR || KlLastSignal != KlSIGCHLD) 
		return NIL;		/* SIGCHLD ? continue : return NIL */
	} else {				/* none pending */
	    return NIL;
	}
    }
  end:
    {					/* actual building of returned list */
	KlList reslist = KlListNMake(3);
	for (i = 0; i < 3; i++)
	    KlIncRef(reslist->list[i] = (KlO) arglists[i].ready_list);
	return (KlO) reslist;
    }
}

/* main parsing (by accumulation) used by KlStreamSelect
 * accumulates arg into a KlStreamList struct
 * checks if a stream is structurally ready (chars in buffer) and already
 * puts it in ready_list field
 * return fd+1 if correct file descriptor monitored or 0
 */

int
KlStreamSelectArgAdd(obj, pos, slistp)
    KlStream obj;
    int pos;
    struct KlStreamList *slistp;
{
    int fd, res = 0;
    if (KlFalseP(obj))			/* ignore () */
	return 0;
    KlMustBeStream(obj, pos);
    if (!(obj->direction & (slistp->mode)))
	KlError2(KlE_STREAM_ERROR, 
		 (slistp->mode == KlStreamOWRITE) ? KlA_write : KlA_read, obj);
    KlListAppend(slistp->list, obj);
    if (KlIsAFileStream(obj)) {		/* file */
	if ((obj->direction) & KlStreamOWRITE & (slistp->mode)) {
	    fd = KlFp2Fd(KlStreamWriteFd(obj));
	    FD_SET(fd, &(slistp->set));
	    res = Max(res, fd+1);
	}
	if ((obj->direction) & KlStreamOREAD & (slistp->mode)) { 
	    fd = KlFp2Fd(obj->fd);
	    FD_SET(fd, &(slistp->set));
	    res = Max(res, fd+1);
	}
	if (slistp->mode == KlStreamOREAD /* if chars in buffer, ready */
	    && READ_DATA_PENDING(obj->fd))
	    KlListAppend(slistp->ready_list, obj);
    } else {				/* string */
	/* strings always ready to write */
	KlListAppend(slistp->ready_list, obj);
    }
    return res;
}


/*****************************************************************************\
* 				  coercions                                   *
\*****************************************************************************/

/* string->stream 
 * open a string stream
 */

/*ARGSUSED*/
KlO
KlStringToStreamCoerce(totype, obj)
    KlType totype;
    KlString obj;
{
    return (KlO) KlStreamStringMake(KlStringCopy(obj), 3);
}

/*ARGSUSED*/
KlO
KlStreamToStringCoerce(totype, stream)
    KlType totype;
    KlStream stream;
{
    struct stat buf;

    if (stream->subtype == KlStreamStringType) { /* string */
	return (KlO) ((KlStreamString)stream)->klstring;
    } else {
	KlStreamCanREAD(stream);
	if (stream->subtype == KlStreamFileType	/* leave out sockets, pipes */
	    && !fstat(KlFp2Fd(stream->fd), &buf)
	    && (buf.st_mode & S_IFREG)) { /* regular file of known length */
	    int size;
	    KlString str = KlStringNMake(buf.st_size);
	    size = fread(str->string, 1, buf.st_size, stream->fd);
	    *(str->string + size) = '\0';
	    KlModStringSetLength(str, size);
	    return (KlO) str;
	} else {				/* stream of unknown length */
	    KlString str = KlStringNMake(1019);
	    int offset = 0;
	    int nitems;
	    int to_get = 1019;
	    int bufsize = 1024;
	
	    for (;;) {
		nitems = fread(str->string + offset, 1, to_get, stream->fd);
		if (!nitems) {
		    if (!stream->blocking || feof(stream->fd)) {
			break;		/* EOF, ok end loop */
		    } else {
					/* error. wait a bit before retry */
			struct timeval timeout;
			timeout.tv_sec = 0;
			timeout.tv_usec = 100; /* wait 1/10th of a second */
			select(0, 0, 0, 0, &timeout);
		    }
		}
		offset += nitems;
		if (offset > bufsize / 2) {
		    bufsize *= 2;
		    str->string = (char *) Realloc(str->string, bufsize - 4);
		}
		to_get = bufsize - offset -4 -1;
	    }
	    *(str->string + offset) = '\0';
	    KlModStringSetLength(str, offset);
	    return (KlO) str;
	}
    }
}

/*****************************************************************************\
* 				  TYPE INIT                                   *
\*****************************************************************************/

KlStreamInit()
{
    int i;

    KlDeclareType(&KlStreamType, "Stream", sizeof(struct _KlStream));

    KlDeclareMethod1(KlStreamType, KlSelPrint, KlStreamPrint);
    KlDeclareMethod1(KlStreamType, KlSelFree, KlStreamFree);

    KlDeclareSubr(KlOpen, "open", NARY);
    KlDeclareSubr(KlStreamClose, "close", NARY);
    KlA_write = (KlAtom) KlDeclareSubr(KlWrite, "write", NARY);
    KlDeclareSubr(KlWriteLine, "write-line", NARY);
    KlDeclareSubr(KlWriteChar, "write-char", NARY);
    KlA_read = (KlAtom) KlDeclareSubr(KlReadKl, "read", NARY);
    KlDeclareSubr(KlReadLine, "read-line", NARY);
    KlDeclareSubr(KlReadChar, "read-char", NARY);
    KlDeclareSubr(KlFlush, "flush", 1);
    KlDeclareSubr(KlPrintFormat, "print-format", NARY);
    KlDeclareSubr(KlFseek, "file-position", NARY);
    KlDeclareSubr(KlStreamMode, "stream-mode", NARY);
    KlDeclareSubr(KlReadChars, "read-chars", NARY);
    KlDeclareSubr(KlWriteChars, "write-chars", NARY);
    KlDeclareSubr(KlStreamSelect, "select", NARY);

    KlIncRef(KlStdin = KlStreamMake(stdin, 1, "stdin"));
    KlIncRef(KlStdout = KlStreamMake(stdout, 2, "stdout"));
    KlIncRef(KlStderr = KlStreamMake(stderr, 2, "stderr"));

    KlA_StdinOrig = KlConstantMake("*standard-input-orig*", KlStdin);
    KlA_StdoutOrig = KlConstantMake("*standard-output-orig*", KlStdout);
    KlA_StderrOrig = KlConstantMake("*standard-error-orig*", KlStderr);

    KlA_stdin = KlActiveMake("*standard-input*",
			     KlStreamStdGet, KlStreamStdSet, &KlStdin);
    KlA_stdout = KlActiveMake("*standard-output*",
			      KlStreamStdGet, KlStreamStdSet, &KlStdout);
    KlA_stderr = KlActiveMake("*standard-error*",
			      KlStreamStdGet, KlStreamStdSet, &KlStderr);

    KlStdyy = 0;

    KlIncRef(KlStdpool = KlStreamStringMake(KlStringMake(" "), 1));
    
    KlDeclareCoerce(KlStringType, KlStreamType, KlStringToStreamCoerce);
    KlDeclareCoerce(KlStreamType, KlStringType, KlStreamToStringCoerce);

    /* keyword lists */
    
    KlOpenKV_if_exists = (KlKeyword *) Malloc(KLSO * 5);    i = 0;
    KlOpenKV_if_exists[i++] = KlK_supersede;
    KlOpenKV_if_exists[i++] = KlK_error;
    KlOpenKV_if_exists[i++] = KlK_append;
    KlOpenKV_if_exists[i++] = KlK_overwrite;
    KlOpenKV_if_exists[i++] = 0;

    KlOpenKV_direction = (KlKeyword *) Malloc(KLSO * 4);    i = 0;
    KlOpenKV_direction[i++] = KlK_input;
    KlOpenKV_direction[i++] = KlK_io;
    KlOpenKV_direction[i++] = KlK_output;
    KlOpenKV_direction[i++] = 0;

    KlOpenKV_filetype = (KlKeyword *) Malloc(KLSO * 6);    i = 0;
    KlOpenKV_filetype[i++] = KlK_file;
    KlOpenKV_filetype[i++] = KlK_string;
    KlOpenKV_filetype[i++] = KlK_tcp;
    KlOpenKV_filetype[i++] = KlK_udp;
    KlOpenKV_filetype[i++] = KlK_pipe;
    KlOpenKV_filetype[i++] = 0;

    /* initializes stdin */
#ifdef AMIGA
    Klyyin = stdin;
#endif /* AMIGA */

    KlGets_tmpl = 1020;
    KlGets_tmp = (char *) Malloc(KlGets_tmpl);
}