/*
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

This file is part of GNU Common Lisp, herein referred to as GCL

GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GCL 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 Library General Public 
License for more details.

You should have received a copy of the GNU Library General Public License 
along with GCL; see the file COPYING.  If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/

/*
	file.d
	IMPLEMENTATION-DEPENDENT

	The specification of printf may be dependent on the C library,
	especially for read-write access, append access, etc.
	The file also contains the code to reclaim the I/O buffer
	by accessing the FILE structure of C.
	It also contains read_fasl_data.
*/

#define IN_FILE
#include "include.h"

#define	kclgetc(FP)		getc(FP)
#define	kclungetc(C, FP)	ungetc(C, FP)
#define	kclfeof(FP)		feof(FP)
#define	kclputc(C, FP)		putc(C, FP)

#ifdef HAVE_AOUT
#undef ATT
#undef BSD
#ifndef HAVE_ELF
#define BSD
#endif
#include HAVE_AOUT
#endif

#ifdef ATT
#include <filehdr.h>
#include <syms.h>
#endif

#ifdef E15
#include <a.out.h>
#define exec	bhdr
#define a_text	tsize
#define a_data	dsize
#define a_bss	bsize
#define a_syms	ssize
#define a_trsize	rtsize
#define a_drsize	rdsize
#endif

#ifdef HAVE_ELF
#include <elf.h>
#endif

object terminal_io;

object Vverbose;
object LSP_string;


object sSAignore_eof_on_terminal_ioA;

bool
feof1(fp)
FILE *fp;
{
	if (!feof(fp))
		return(FALSE);
	if (fp == terminal_io->sm.sm_object0->sm.sm_fp) {
		if (symbol_value(sSAignore_eof_on_terminal_ioA) == Cnil)
			return(TRUE);
#ifdef UNIX
		fp = freopen("/dev/tty", "r", fp);
#endif
#ifdef AOSVS

#endif
		if (fp == NULL)
			error("can't reopen the console");
		return(FALSE);
	}
	return(TRUE);
}

#undef	feof
#define	feof	feof1


end_of_stream(strm)
object strm;
{
	FEerror("Unexpected end of ~S.", 1, strm);
}

/*
	Input_stream_p(strm) answers
	if stream strm is an input stream or not.
	It does not check if it really is possible to read
	from the stream,
	but only checks the mode of the stream (sm_mode).
*/
bool
input_stream_p(strm)
object strm;
{
BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
		return(TRUE);

	case smm_output:
		return(FALSE);

	case smm_io:
		return(TRUE);

	case smm_probe:
		return(FALSE);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		return(FALSE);

	case smm_concatenated:
		return(TRUE);

	case smm_two_way:
		return(TRUE);

	case smm_echo:
		return(TRUE);

	case smm_string_input:
		return(TRUE);

	case smm_string_output:
		return(FALSE);

	default:
		error("illegal stream mode");
	}
}

/*
	Output_stream_p(strm) answers
	if stream strm is an output stream.
	It does not check if it really is possible to write
	to the stream,
	but only checks the mode of the stream (sm_mode).
*/
bool
output_stream_p(strm)
object strm;
{
BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
		return(FALSE);

	case smm_output:
		return(TRUE);

	case smm_io:
		return(TRUE);

	case smm_probe:
		return(FALSE);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		return(TRUE);

	case smm_concatenated:
		return(FALSE);

	case smm_two_way:
		return(TRUE);

	case smm_echo:
		return(TRUE);

	case smm_string_input:
		return(FALSE);

	case smm_string_output:
		return(TRUE);

	default:
		error("illegal stream mode");
	}
}

object
stream_element_type(strm)
object strm;
{
 	object endp_temp;
	object x;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_output:
	case smm_io:
	case smm_probe:
		return(strm->sm.sm_object0);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		x = strm->sm.sm_object0;
		if (endp(x))
			return(Ct);
		return(stream_element_type(x->c.c_car));

	case smm_concatenated:
		x = strm->sm.sm_object0;
		if (endp(x))
			return(Ct);
		return(stream_element_type(x->c.c_car));

	case smm_two_way:
		return(stream_element_type(strm->sm.sm_object0));

	case smm_echo:
		return(stream_element_type(strm->sm.sm_object0));

	case smm_string_input:
		return(sLstring_char);

	case smm_string_output:
		return(sLstring_char);

	default:
		error("illegal stream mode");
	}
}

#ifndef NO_SETBUF
setup_stream_buffer(x)
     object x;
{char *buf=alloc_contblock(BUFSIZ);
  	x->sm.sm_buffer = buf;
#ifdef SGC
	perm_writable(buf,BUFSIZ);
#endif
	setbuf(x->sm.sm_fp, buf);
}	

deallocate_stream_buffer(strm)
object strm;
{
  if (strm->sm.sm_buffer)
    {insert_contblock(strm->sm.sm_buffer, BUFSIZ);
     strm->sm.sm_buffer = 0;}
  else
    printf("no buffer? %x  \n",strm->sm.sm_fp);

#ifndef FCLOSE_SETBUF_OK
  strm->sm.sm_fp->_base = NULL;
#endif
}
/* end ifndef NO_SETBUF */
#endif

DEFVAR("*ALLOW-GZIPPED-FILE*",sSAallow_gzipped_fileA,SI,sLnil,"");

/*
	Open_stream(fn, smm, if_exists, if_does_not_exist)
	opens file fn with mode smm.
	Fn is a namestring.
*/
object
open_stream(fn, smm, if_exists, if_does_not_exist)
object fn;
enum smmode smm;
object if_exists, if_does_not_exist;
{
	object x;
	FILE *fp;
	char fname[BUFSIZ];
	int i;
	object unzipped = 0;
	vs_mark;

/*
	if (type_of(fn) != t_string)
		FEwrong_type_argument(sLstring, fn);
*/
	if (fn->st.st_fillp > BUFSIZ - 1)
		too_long_file_name(fn);
	for (i = 0;  i < fn->st.st_fillp;  i++)
		fname[i] = fn->st.st_self[i];
	
	fname[i] = '\0';
	if (smm == smm_input || smm == smm_probe) {
		fp = fopen(fname, "r");
	      AGAIN:
		if (fp == NULL) {
		        if (sSAallow_gzipped_fileA->s.s_dbind != sLnil)
			  { char buf[256];
			    sprintf(buf,"%s.gz",fname);
			    fp = fopen(buf,"r");
			    if (fp)
			      { char *tmp;
				char command [500];
				close(fp);
				tmp = tmpnam(0);
				unzipped = make_simple_string(tmp);
				sprintf(command,"gzip -dc %s > %s",buf,tmp);
				fp = 0;
				if (0 == system(command))
				  {
				    fp = fopen(tmp,"r");
				    if (fp) 
				      goto AGAIN;
				    /* should not get here */
				    else { unlink(tmp);}}
			      }}
			if (if_does_not_exist == sKerror)
				cannot_open(fn);
			else if (if_does_not_exist == sKcreate) {
				fp = fopen(fname, "w");
				if (fp == NULL)
					cannot_create(fn);
				fclose(fp);
				fp = fopen(fname, "r");
				if (fp == NULL)
					cannot_open(fn);
			} else if (if_does_not_exist == Cnil)
				return(Cnil);
			else
			 FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
				 1, if_does_not_exist);
		}
	} else if (smm == smm_output || smm == smm_io) {
		if (if_exists == sKnew_version && if_does_not_exist == sKcreate)
			goto CREATE;
		fp = fopen(fname, "r");
		if (fp != NULL) {
			fclose(fp);
			if (if_exists == sKerror)
				FEerror("The file ~A already exists.", 1, fn);
			else if (if_exists == sKrename) {
				if (smm == smm_output)
					fp = backup_fopen(fname, "w");
				else
					fp = backup_fopen(fname, "w+");
				if (fp == NULL)
					cannot_create(fn);
			} else if (if_exists == sKrename_and_delete ||
				   if_exists == sKnew_version ||
				   if_exists == sKsupersede) {
				if (smm == smm_output)
					fp = fopen(fname, "w");
				else
					fp = fopen(fname, "w+");
				if (fp == NULL)
					cannot_create(fn);
			} else if (if_exists == sKoverwrite) {
				fp = fopen(fname, "r+");
				if (fp == NULL)
					cannot_open(fn);
			} else if (if_exists == sKappend) {
				if (smm == smm_output)
					fp = fopen(fname, "a");
				else
					fp = fopen(fname, "a+");
				if (fp == NULL)
				FEerror("Cannot append to the file ~A.",1,fn);
			} else if (if_exists == Cnil)
				return(Cnil);
			else
				FEerror("~S is an illegal IF-EXISTS option.",
					1, if_exists);
		} else {
			if (if_does_not_exist == sKerror)
				FEerror("The file ~A does not exist.", 1, fn);
			else if (if_does_not_exist == sKcreate) {
			CREATE:
				if (smm == smm_output)
					fp = fopen(fname, "w");
				else
					fp = fopen(fname, "w+");
				if (fp == NULL)
					cannot_create(fn);
			} else if (if_does_not_exist == Cnil)
				return(Cnil);
			else
			 FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
				 1, if_does_not_exist);
		}
	} else
		error("illegal stream mode");
	x = alloc_object(t_stream);
	x->sm.sm_mode = (short)smm;
	x->sm.sm_fp = fp;

	x->sm.sm_buffer = 0;
	x->sm.sm_object0 = (unzipped ? make_cons(sSAallow_gzipped_fileA,unzipped) : sLstring_char);
	x->sm.sm_object1 = fn;
	x->sm.sm_int0 = x->sm.sm_int1 = 0;
	vs_push(x);
	setup_stream_buffer(x);
	vs_reset;
	return(x);
}

/*
	Close_stream(strm) closes stream strm.
	The abort_flag is not used now.
*/
close_stream(strm)
object strm;
/*bool abort_flag; */	/*  Not used now!  */
{
	object endp_temp;
	object x;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_output:
		if (strm->sm.sm_fp == stdout)
			FEerror("Cannot close the standard output.", 0);
		if (strm->sm.sm_fp == NULL) break;
		fflush(strm->sm.sm_fp);
		deallocate_stream_buffer(strm);
		fclose(strm->sm.sm_fp);
		strm->sm.sm_fp = NULL;
		break;

	case smm_input:
		if (strm->sm.sm_fp == stdin)
			FEerror("Cannot close the standard input.", 0);

	case smm_io:
	case smm_probe:
		if (strm->sm.sm_fp == NULL) break;
		deallocate_stream_buffer(strm);
		fclose(strm->sm.sm_fp);
		strm->sm.sm_fp = NULL;
		if (type_of(strm->sm.sm_object0 ) == t_cons &&
		    Mcar(strm->sm.sm_object0 ) == sSAallow_gzipped_fileA)
		  fLdelete_file(Mcdr(strm->sm.sm_object0));
		break;

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
			close_stream(x->c.c_car);
		break;

	case smm_concatenated:
		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
			close_stream(x->c.c_car);
		break;

	case smm_two_way:
		close_stream(strm->sm.sm_object0);
		close_stream(strm->sm.sm_object1);
		break;

	case smm_echo:
		close_stream(strm->sm.sm_object0);
		close_stream(strm->sm.sm_object1);
		break;

	case smm_string_input:
		break;		/*  There is nothing to do.  */

	case smm_string_output:
		break;		/*  There is nothing to do.  */

	default:
		error("illegal stream mode");
	}
}

object
make_two_way_stream(istrm, ostrm)
object istrm, ostrm;
{
	object strm;

	strm = alloc_object(t_stream);
	strm->sm.sm_mode = (short)smm_two_way;
	strm->sm.sm_fp = NULL;
	strm->sm.sm_object0 = istrm;
	strm->sm.sm_object1 = ostrm;
	strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
	return(strm);
}

object
make_echo_stream(istrm, ostrm)
object istrm, ostrm;
{
	object strm;

	strm = make_two_way_stream(istrm, ostrm);
	strm->sm.sm_mode = (short)smm_echo;
	return(strm);
}

object
make_string_input_stream(strng, istart, iend)
object strng;
int istart, iend;
{
	object strm;

	strm = alloc_object(t_stream);
	strm->sm.sm_mode = (short)smm_string_input;
	strm->sm.sm_fp = NULL;
	strm->sm.sm_object0 = strng;
	strm->sm.sm_object1 = OBJNULL;
	strm->sm.sm_int0 = istart;
	strm->sm.sm_int1 = iend;
	return(strm);
}

object
make_string_output_stream(line_length)
int line_length;
{
	object strng, strm;
	vs_mark;

	strng = alloc_object(t_string);
	strng->st.st_hasfillp = TRUE;
	strng->st.st_adjustable = TRUE;
	strng->st.st_displaced = Cnil;
	strng->st.st_dim = line_length;
	strng->st.st_fillp = 0;
	strng->st.st_self = NULL;
		/*  For GBC not to go mad.  */
	vs_push(strng);
		/*  Saving for GBC.  */
	strng->st.st_self = alloc_relblock(line_length);
	strm = alloc_object(t_stream);
	strm->sm.sm_mode = (short)smm_string_output;
	strm->sm.sm_fp = NULL;
	strm->sm.sm_object0 = strng;
	strm->sm.sm_object1 = OBJNULL;
	strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
	vs_reset;
	return(strm);
}

object
get_output_stream_string(strm)
object strm;
{
	object strng;

	strng = copy_simple_string(strm->sm.sm_object0);
	strm->sm.sm_object0->st.st_fillp = 0;
	return(strng);
}

int
readc_stream(strm)
object strm;
{
	object endp_temp;
	int c;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_io:
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		c = kclgetc(strm->sm.sm_fp);
		c &= 0377;
		if (kclfeof(strm->sm.sm_fp))
			end_of_stream(strm);
		strm->sm.sm_int0++;
		return(c);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_concatenated:
	CONCATENATED:
		if (endp(strm->sm.sm_object0)) {
			end_of_stream(strm);
		}
		if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
			strm->sm.sm_object0
			= strm->sm.sm_object0->c.c_cdr;
			goto CONCATENATED;
		}
		c = readc_stream(strm->sm.sm_object0->c.c_car);
		return(c);

	case smm_two_way:
#ifdef UNIX
		if (strm == terminal_io)				/**/
			flush_stream(terminal_io->sm.sm_object1);	/**/
#endif
		strm->sm.sm_int1 = 0;
		strm = strm->sm.sm_object0;
		goto BEGIN;

	case smm_echo:
		c = readc_stream(strm->sm.sm_object0);
		if (strm->sm.sm_int0 == 0)
			writec_stream(c, strm->sm.sm_object1);
		else
			--(strm->sm.sm_int0);
		return(c);

	case smm_string_input:
		if (strm->sm.sm_int0 >= strm->sm.sm_int1)
			end_of_stream(strm);
		return(strm->sm.sm_object0->st.st_self
		       [strm->sm.sm_int0++]);

	case smm_output:
	case smm_probe:
	case smm_broadcast:
	case smm_string_output:
		cannot_read(strm);
#ifdef USER_DEFINED_STREAMS
	case smm_user_defined:
#define STM_DATA_STRUCT 0
#define STM_READ_CHAR 1
#define STM_WRITE_CHAR 2
#define STM_UNREAD_CHAR 7
#define STM_FORCE_OUTPUT 4
#define STM_PEEK_CHAR 3
#define STM_CLOSE 5
#define STM_TYPE 6
#define STM_NAME 8
{object val;
	 	object endp_temp;	
		object *old_vs_base = vs_base;
		object *old_vs_top = vs_top;
		vs_base = vs_top;
		vs_push(strm);
		super_funcall(strm->sm.sm_object1->str.str_self[STM_READ_CHAR]);
		val = vs_base[0];
		vs_base = old_vs_base;
		vs_top = old_vs_top;
		if (type_of(val) == t_fixnum)
		  return (fix(val));
		if (type_of(val) == t_character)
		  return (char_code(val));
	      }

#endif

	default:	
		error("illegal stream mode");
	}
}

unreadc_stream(c, strm)
int c;
object strm;
{ 	object endp_temp;
BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_io:
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		kclungetc(c, strm->sm.sm_fp);
		--strm->sm.sm_int0;
		break;

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_concatenated:
		if (endp(strm->sm.sm_object0))
			goto UNREAD_ERROR;
		strm = strm->sm.sm_object0->c.c_car;
		goto BEGIN;

	case smm_two_way:
		strm = strm->sm.sm_object0;
		goto BEGIN;

	case smm_echo:
		unreadc_stream(c, strm->sm.sm_object0);
		(strm->sm.sm_int0)++;
		break;

	case smm_string_input:
		if (strm->sm.sm_int0 <= 0)
			goto UNREAD_ERROR;
		--strm->sm.sm_int0;
		break;

	case smm_output:
	case smm_probe:
	case smm_broadcast:
	case smm_string_output:
		goto UNREAD_ERROR;

#ifdef USER_DEFINED_STREAMS
        case smm_user_defined:
		{object *old_vs_base = vs_base;
		 object *old_vs_top = vs_top;
		 vs_base = vs_top;
		 vs_push(strm);
		 /* if there is a file pointer and no define unget function,
                  * then call ungetc */
		 if ((strm->sm.sm_fp != NULL ) &&
		     strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR] == Cnil)
		   kclungetc(c, strm->sm.sm_fp);
		 else
		   super_funcall(strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR]);
		 vs_top = old_vs_top;
		 vs_base = old_vs_base;
	       }
		break;
#endif
	default:
		error("illegal stream mode");
	}
	return;

UNREAD_ERROR:
	FEerror("Cannot unread the stream ~S.", 1, strm);
}

writec_stream(c, strm)
int c;
object strm;
{ 	object endp_temp;
	object x;
	char *p;
	int i;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_output:
	case smm_io:
		strm->sm.sm_int0++;
		if (c == '\n')
			strm->sm.sm_int1 = 0;
		else if (c == '\t')
			strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
		else
			strm->sm.sm_int1++;
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		kclputc(c, strm->sm.sm_fp);
		break;

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
			writec_stream(c, x->c.c_car);
		break;

	case smm_two_way:
		strm->sm.sm_int0++;
		if (c == '\n')
			strm->sm.sm_int1 = 0;
		else if (c == '\t')
			strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
		else
			strm->sm.sm_int1++;
		strm = strm->sm.sm_object1;
		goto BEGIN;

	case smm_echo:
		strm = strm->sm.sm_object1;
		goto BEGIN;

	case smm_string_output:
		strm->sm.sm_int0++;
		if (c == '\n')
			strm->sm.sm_int1 = 0;
		else if (c == '\t')
			strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
		else
			strm->sm.sm_int1++;
		x = strm->sm.sm_object0;
		if (x->st.st_fillp >= x->st.st_dim) {
			if (!x->st.st_adjustable)
				FEerror("The string ~S is not adjustable.",
					1, x);
                        p = (inheap(x->st.st_dim) ? alloc_contblock : alloc_relblock)
                             (x->st.st_dim * 2 + 16); 
			for (i = 0;  i < x->st.st_dim;  i++)
				p[i] = x->st.st_self[i];
			i = x->st.st_dim * 2 + 16;
#define	ADIMLIM		16*1024*1024
			if (i >= ADIMLIM)
				FEerror("Can't extend the string.", 0);
			x->st.st_dim = i;
			adjust_displaced(x, p - x->st.st_self);
		}
		x->st.st_self[x->st.st_fillp++] = c;
		break;

	case smm_input:
	case smm_probe:
	case smm_concatenated:
	case smm_string_input:
		cannot_write(strm);

#ifdef USER_DEFINED_STREAMS
	case smm_user_defined:
		{object *old_vs_base = vs_base;
		 object *old_vs_top = vs_top;
		 vs_base = vs_top;
		 vs_push(strm);
		 vs_push(code_char(c));
		 super_funcall(strm->sm.sm_object1->str.str_self[2]);
		 vs_base = old_vs_base;
		 vs_top = old_vs_top;
		 break;
	       }

#endif
	default:
		error("illegal stream mode");
	}
	return(c);
}

writestr_stream(s, strm)
char *s;
object strm;
{
	while (*s != '\0')
		writec_stream(*s++, strm);
}

flush_stream(strm)
object strm;
{ 	object endp_temp;
	object x;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_output:
	case smm_io:
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		fflush(strm->sm.sm_fp);
		break;

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
			flush_stream(x->c.c_car);
		break;

	case smm_two_way:
		strm = strm->sm.sm_object1;
		goto BEGIN;

	case smm_echo:
		strm = strm->sm.sm_object1;
		goto BEGIN;

	case smm_string_output:
		break;

	case smm_input:
	case smm_probe:
	case smm_concatenated:
	case smm_string_input:
		FEerror("Cannot flush the stream ~S.", 1, strm);
#ifdef USER_DEFINED_STREAMS
        case smm_user_defined:
		{object *old_vs_base = vs_base;
		 object *old_vs_top = vs_top;
		 vs_base = vs_top;
		 vs_push(strm);
		 super_funcall(strm->sm.sm_object1->str.str_self[4]);
		 vs_base = old_vs_base;
		 vs_top = old_vs_top;
		break;
	       }

#endif

	default:
		error("illegal stream mode");
	}
}


bool
stream_at_end(strm)
object strm;
{ 	object endp_temp;
	object x;
#define NON_CHAR -1000
	VOL int c = NON_CHAR;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_io:	
	case smm_input:
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		{int prev_signals_allowed = signals_allowed;
	       AGAIN:
		signals_allowed= sig_at_read;
		c = kclgetc(strm->sm.sm_fp);

                if (c == NON_CHAR) goto AGAIN; 
		signals_allowed=prev_signals_allowed;}
	       
		if (kclfeof(strm->sm.sm_fp))
			return(TRUE);
		else {
			kclungetc(c, strm->sm.sm_fp);
			return(FALSE);
		}

	case smm_output:
		return(FALSE);

/*	case smm_io:
		return(FALSE);
*/

	case smm_probe:
		return(FALSE);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_broadcast:
		return(FALSE);

	case smm_concatenated:
	CONCATENATED:
		if (endp(strm->sm.sm_object0))
			return(TRUE);
		if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
			strm->sm.sm_object0
			= strm->sm.sm_object0->c.c_cdr;
			goto CONCATENATED;
		} else
			return(FALSE);

	case smm_two_way:
#ifdef UNIX
		if (strm == terminal_io)				/**/
			flush_stream(terminal_io->sm.sm_object1);	/**/
#endif
		strm = strm->sm.sm_object0;
		goto BEGIN;

	case smm_echo:
		strm = strm->sm.sm_object0;
		goto BEGIN;

	case smm_string_input:
		if (strm->sm.sm_int0 >= strm->sm.sm_int1)
			return(TRUE);
		else
			return(FALSE);

	case smm_string_output:
		return(FALSE);

#ifdef USER_DEFINED_STREAMS
        case smm_user_defined:
		  return(FALSE);
#endif
	default:
		error("illegal stream mode");
	}
}

#ifdef HAVE_IOCTL
#include <sys/ioctl.h>
#endif

bool
listen_stream(strm)
object strm;
{ 	object endp_temp;
	object x;
	int c;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_io:

		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		if (feof(strm->sm.sm_fp))
				return(FALSE);
#ifdef LISTEN_FOR_INPUT
		LISTEN_FOR_INPUT(strm->sm.sm_fp);
#endif
		return TRUE;

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_concatenated:
	CONCATENATED:
		if (endp(strm->sm.sm_object0))
			return(FALSE);
		strm = strm->sm.sm_object0->c.c_car;	/* Incomplete! */
		goto BEGIN;

	case smm_two_way:
	case smm_echo:
		strm = strm->sm.sm_object0;
		goto BEGIN;

	case smm_string_input:
		if (strm->sm.sm_int0 < strm->sm.sm_int1)
			return(TRUE);
		else
			return(FALSE);

	case smm_output:
	case smm_probe:
	case smm_broadcast:
	case smm_string_output:
		FEerror("Can't listen to ~S.", 1, strm);

	default:
		error("illegal stream mode");
	}
}

int
file_position(strm)
object strm;
{
BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_output:
	case smm_io:
		/*  return(strm->sm.sm_int0);  */
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		return(ftell(strm->sm.sm_fp));

	case smm_string_output:
		return(strm->sm.sm_object0->st.st_fillp);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_probe:
	case smm_broadcast:
	case smm_concatenated:
	case smm_two_way:
	case smm_echo:
	case smm_string_input:
		return(-1);

	default:
		error("illegal stream mode");
	}
}

int
file_position_set(strm, disp)
object strm;
int disp;
{
BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_output:
	case smm_io:
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		if (fseek(strm->sm.sm_fp, disp, 0) < 0)
			return(-1);
		strm->sm.sm_int0 = disp;
		return(0);

	case smm_string_output:
		if (disp < strm->sm.sm_object0->st.st_fillp) {
			strm->sm.sm_object0->st.st_fillp = disp;
			strm->sm.sm_int0 = disp;
		} else {
			disp -= strm->sm.sm_object0->st.st_fillp;
			while (disp-- > 0)
				writec_stream(' ', strm);
		}
		return(0);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_probe:
	case smm_broadcast:
	case smm_concatenated:
	case smm_two_way:
	case smm_echo:
	case smm_string_input:
		return(-1);

	default:
		error("illegal stream mode");
	}
}

int
file_length(strm)
object strm;
{
BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_input:
	case smm_output:
	case smm_io:
		if (strm->sm.sm_fp == NULL)
			closed_stream(strm);
		return(file_len(strm->sm.sm_fp));

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_probe:
	case smm_broadcast:
	case smm_concatenated:
	case smm_two_way:
	case smm_echo:
	case smm_string_input:
	case smm_string_output:
		return(-1);

	default:
		error("illegal stream mode");
	}
}

int
file_column(strm)
object strm;
{ 	object endp_temp;
	int i;
	object x;

BEGIN:
	switch (strm->sm.sm_mode) {
	case smm_output:
	case smm_io:
	case smm_two_way:
	case smm_string_output:
		return(strm->sm.sm_int1);

	case smm_synonym:
		strm = symbol_value(strm->sm.sm_object0);
		if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

	case smm_echo:
		strm = strm->sm.sm_object1;
		goto BEGIN;

	case smm_input:
	case smm_probe:
	case smm_string_input:
		return(-1);

	case smm_concatenated:
		if (endp(strm->sm.sm_object0))
			return(-1);
		strm = strm->sm.sm_object0->c.c_car;
		goto BEGIN;

	case smm_broadcast:
		for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) {
			i = file_column(x->c.c_car);
			if (i >= 0)
				return(i);
		}
		return(-1);

#ifdef USER_DEFINED_STREAMS
	case smm_user_defined: /* not right but what is? */
		return(-1);
	
#endif
	default:
		error("illegal stream mode");
	}
}

load(s)
char *s;
{
	object filename, strm, x;
	vs_mark;

	filename = make_simple_string(s);
	vs_push(filename);
	strm = open_stream(filename, smm_input, Cnil, sKerror);
	vs_push(strm);
	for (;;) {
		preserving_whitespace_flag = FALSE;
		detect_eos_flag = TRUE;
		x = read_object_non_recursive(strm);
		if (x == OBJNULL)
			break;
		vs_push(x);
		ieval(x);
		vs_pop;
	}
	close_stream(strm);
	vs_reset;
}

Lmake_synonym_stream()
{
	object x;

	check_arg(1);
	check_type_symbol(&vs_base[0]);
	x = alloc_object(t_stream);
	x->sm.sm_mode = (short)smm_synonym;
	x->sm.sm_fp = NULL;
	x->sm.sm_object0 = vs_base[0];
	x->sm.sm_object1 = OBJNULL;
	x->sm.sm_int0 = x->sm.sm_int1 = 0;
	vs_base[0] = x;
}

Lmake_broadcast_stream()
{
	object x;
	int narg, i;

	narg = vs_top - vs_base;
	for (i = 0;  i < narg;  i++)
		if (type_of(vs_base[i]) != t_stream ||
		    !output_stream_p(vs_base[i]))
			cannot_write(vs_base[i]);
	vs_push(Cnil);
	for (i = narg;  i > 0;  --i)
		stack_cons();
	x = alloc_object(t_stream);
	x->sm.sm_mode = (short)smm_broadcast;
	x->sm.sm_fp = NULL;
	x->sm.sm_object0 = vs_base[0];
	x->sm.sm_object1 = OBJNULL;
	x->sm.sm_int0 = x->sm.sm_int1 = 0;
	vs_base[0] = x;
}

Lmake_concatenated_stream()
{
	object x;
	int narg, i;

	narg = vs_top - vs_base;
	for (i = 0;  i < narg;  i++)
		if (type_of(vs_base[i]) != t_stream ||
		    !input_stream_p(vs_base[i]))
			cannot_read(vs_base[i]);
	vs_push(Cnil);
	for (i = narg;  i > 0;  --i)
		stack_cons();
	x = alloc_object(t_stream);
	x->sm.sm_mode = (short)smm_concatenated;
	x->sm.sm_fp = NULL;
	x->sm.sm_object0 = vs_base[0];
	x->sm.sm_object1 = OBJNULL;
	x->sm.sm_int0 = x->sm.sm_int1 = 0;
	vs_base[0] = x;
}

Lmake_two_way_stream()
{
	check_arg(2);

	if (type_of(vs_base[0]) != t_stream ||
	    !input_stream_p(vs_base[0]))
		cannot_read(vs_base[0]);
	if (type_of(vs_base[1]) != t_stream ||
	    !output_stream_p(vs_base[1]))
		cannot_write(vs_base[1]);
	vs_base[0] = make_two_way_stream(vs_base[0], vs_base[1]);
	vs_pop;
}

Lmake_echo_stream()
{
	check_arg(2);

	if (type_of(vs_base[0]) != t_stream ||
	    !input_stream_p(vs_base[0]))
		cannot_read(vs_base[0]);
	if (type_of(vs_base[1]) != t_stream ||
	    !output_stream_p(vs_base[1]))
		cannot_write(vs_base[1]);
	vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]);
	vs_pop;
}

@(defun make_string_input_stream (strng &o istart iend)
	int s, e;
@
	check_type_string(&strng);
	if (istart == Cnil)
		s = 0;
	else if (type_of(istart) != t_fixnum)
		goto E;
	else
		s = fix(istart);
	if (iend == Cnil)
		e = strng->st.st_fillp;
	else if (type_of(iend) != t_fixnum)
		goto E;
	else
		e = fix(iend);
	if (s < 0 || e > strng->st.st_fillp || s > e)
		goto E;
	@(return `make_string_input_stream(strng, s, e)`)

E:
	FEerror("~S and ~S are illegal as :START and :END~%\
for the string ~S.",
		3, istart, iend, strng);
@)

Lmake_string_output_stream()
{
	check_arg(0);
	vs_push(make_string_output_stream(64));
}

Lget_output_stream_string()
{
	check_arg(1);

	if (type_of(vs_base[0]) != t_stream ||
	    (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
		FEerror("~S is not a string-output stream.", 1, vs_base[0]);
	vs_base[0] = get_output_stream_string(vs_base[0]);
}

/*
	(SI:OUTPUT-STREAM-STRING string-output-stream)

		extracts the string associated with the given
		string-output-stream.
*/
siLoutput_stream_string()
{
	check_arg(1);
	if (type_of(vs_base[0]) != t_stream ||
	    (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
		FEerror("~S is not a string-output stream.", 1, vs_base[0]);
	vs_base[0] = vs_base[0]->sm.sm_object0;
}

Lstreamp()
{
	check_arg(1);

	if (type_of(vs_base[0]) == t_stream)
		vs_base[0] = Ct;
	else
		vs_base[0] = Cnil;
}

Linput_stream_p()
{
	check_arg(1);

	check_type_stream(&vs_base[0]);
	if (input_stream_p(vs_base[0]))
		vs_base[0] = Ct;
	else
		vs_base[0] = Cnil;
}

Loutput_stream_p()
{
	check_arg(1);

	check_type_stream(&vs_base[0]);
	if (output_stream_p(vs_base[0]))
		vs_base[0] = Ct;
	else
		vs_base[0] = Cnil;
}

Lstream_element_type()
{
	check_arg(1);

	check_type_stream(&vs_base[0]);
	vs_base[0] = stream_element_type(vs_base[0]);
}

@(defun close (strm &key abort)
@
	check_type_stream(&strm);
	close_stream(strm);
	@(return Ct)
@)

@(defun open (filename
	      &key (direction sKinput)
		   (element_type sLstring_char)
		   (if_exists Cnil iesp)
		   (if_does_not_exist Cnil idnesp)
	      &aux strm)
	enum smmode smm;
@
	check_type_or_pathname_string_symbol_stream(&filename);
	filename = coerce_to_namestring(filename);
	if (direction == sKinput) {
		smm = smm_input;
		if (!idnesp)
			if_does_not_exist = sKerror;
	} else if (direction == sKoutput) {
		smm = smm_output;
		if (!iesp)
			if_exists = sKnew_version;
		if (!idnesp) {
			if (if_exists == sKoverwrite ||
			    if_exists == sKappend)
				if_does_not_exist = sKerror;
			else
				if_does_not_exist = sKcreate;
		}
	} else if (direction == sKio) {
		smm = smm_io;
		if (!iesp)
			if_exists = sKnew_version;
		if (!idnesp) {
			if (if_exists == sKoverwrite ||
			    if_exists == sKappend)
				if_does_not_exist = sKerror;
			else
				if_does_not_exist = sKcreate;
		}
	} else if (direction == sKprobe) {
		smm = smm_probe;
		if (!idnesp)
			if_does_not_exist = Cnil;
	} else
		FEerror("~S is an illegal DIRECTION for OPEN.",
			1, direction);
	strm = open_stream(filename, smm, if_exists, if_does_not_exist);
	@(return strm)
@)

@(defun file_position (file_stream &o position)
	int i;
@
	check_type_stream(&file_stream);
	if (position == Cnil) {
		i = file_position(file_stream);
		if (i < 0)
			@(return Cnil)
		@(return `make_fixnum(i)`)
	} else {
		if (position == sKstart)
			i = 0;
		else if (position == sKend)
			i = file_length(file_stream);
		else if (type_of(position) != t_fixnum ||
		    (i = fix((position))) < 0)
			FEerror("~S is an illegal file position~%\
for the file-stream ~S.",
				2, position, file_stream);
		if (file_position_set(file_stream, i) < 0)
			@(return Cnil)
		@(return Ct)
	}	
@)

Lfile_length()
{
	int i;

	check_arg(1);
	check_type_stream(&vs_base[0]);
	i = file_length(vs_base[0]);
	if (i < 0)
		vs_base[0] = Cnil;
	else
		vs_base[0] = make_fixnum(i);
}

object sSAload_pathnameA;

@(defun load (pathname
	      &key (verbose `symbol_value(sLAload_verboseA)`)
		    print
		    (if_does_not_exist sKerror)
	      &aux pntype fasl_filename lsp_filename filename
		   defaults strm stdoutput x
		   package)
	bds_ptr old_bds_top;
	int i;
	object strm1;
@
	check_type_or_pathname_string_symbol_stream(&pathname);
	pathname = coerce_to_pathname(pathname);
	defaults = symbol_value(Vdefault_pathname_defaults);
	defaults = coerce_to_pathname(defaults);
	pathname = merge_pathnames(pathname, defaults, sKnewest);
	pntype = pathname->pn.pn_type;
	filename = coerce_to_namestring(pathname);
        old_bds_top=bds_top;
  	if (pntype == Cnil || pntype == sKwild ||
	    type_of(pntype) == t_string &&
#ifdef UNIX
	    string_eq(pntype, FASL_string)) {
#endif
#ifdef AOSVS

#endif
		pathname->pn.pn_type = FASL_string;
		fasl_filename = coerce_to_namestring(pathname);
	}
	if (pntype == Cnil || pntype == sKwild ||
	    type_of(pntype) == t_string &&
#ifdef UNIX
	    string_eq(pntype, LSP_string)) {
#endif
#ifdef AOSVS

#endif
		pathname->pn.pn_type = LSP_string;
		lsp_filename = coerce_to_namestring(pathname);
	}
	if (fasl_filename != Cnil && file_exists(fasl_filename)) {
		if (verbose != Cnil) {
			SETUP_PRINT_DEFAULT(fasl_filename);
			if (file_column(PRINTstream) != 0)
				write_str("\n");
			write_str("Loading ");
			PRINTescape = FALSE;
			write_object(fasl_filename, 0);
			write_str("\n");
			CLEANUP_PRINT_DEFAULT;
			flush_stream(PRINTstream);
		}
		package = symbol_value(sLApackageA);
		bds_bind(sLApackageA, package);
		bds_bind(sSAload_pathnameA,fasl_filename);
		i = fasload(fasl_filename);
		if (print != Cnil) {
			SETUP_PRINT_DEFAULT(Cnil);
			vs_top = PRINTvs_top;
			if (file_column(PRINTstream) != 0)
				write_str("\n");
			write_str("Fasload successfully ended.");
			write_str("\n");
			CLEANUP_PRINT_DEFAULT;
			flush_stream(PRINTstream);
		}
		bds_unwind(old_bds_top);
		if (verbose != Cnil) {
			SETUP_PRINT_DEFAULT(fasl_filename);
			if (file_column(PRINTstream) != 0)
				write_str("\n");
			write_str("Finished loading ");
			PRINTescape = FALSE;
			write_object(fasl_filename, 0);
			write_str("\n");
			CLEANUP_PRINT_DEFAULT;
			flush_stream(PRINTstream);
		}
		@(return `make_fixnum(i)`)
	}
	if (lsp_filename != Cnil && file_exists(lsp_filename)) {
		filename = lsp_filename;
	}
	if (if_does_not_exist != Cnil)
		if_does_not_exist = sKerror;
	strm1 = strm
	= open_stream(filename, smm_input, Cnil, if_does_not_exist);
	if (strm == Cnil)
		@(return Cnil)
	if (verbose != Cnil) {
		SETUP_PRINT_DEFAULT(filename);
		if (file_column(PRINTstream) != 0)
			write_str("\n");
		write_str("Loading ");
		PRINTescape = FALSE;
		write_object(filename, 0);
		write_str("\n");
		CLEANUP_PRINT_DEFAULT;
		flush_stream(PRINTstream);
	}
	package = symbol_value(sLApackageA);
	bds_bind(sSAload_pathnameA,pathname);
	bds_bind(sLApackageA, package);
	bds_bind(sLAstandard_inputA, strm);
	frs_push(FRS_PROTECT, Cnil);
	if (nlj_active) {
		close_stream(strm1);
		nlj_active = FALSE;
		frs_pop();
		bds_unwind(old_bds_top);
		unwind(nlj_fr, nlj_tag);
	}
	for (;;) {
		preserving_whitespace_flag = FALSE;
		detect_eos_flag = TRUE;
		x = read_object_non_recursive(strm);
		if (x == OBJNULL)
			break;
		{
			object *base = vs_base, *top = vs_top, *lex = lex_env;
			object xx;

			lex_new();
			eval(x);
			xx = vs_base[0];
			lex_env = lex;
			vs_top = top;
			vs_base = base;
			x = xx;
		}
		if (print != Cnil) {
			SETUP_PRINT_DEFAULT(x);
			write_object(x, 0);
			write_str("\n");
			CLEANUP_PRINT_DEFAULT;
			flush_stream(PRINTstream);
		}
	}
	close_stream(strm);
	frs_pop();
	bds_unwind(old_bds_top);
	if (verbose != Cnil) {
		SETUP_PRINT_DEFAULT(filename);
		if (file_column(PRINTstream) != 0)
			write_str("\n");
		write_str("Finished loading ");
		PRINTescape = FALSE;
		write_object(filename, 0);
		write_str("\n");
		CLEANUP_PRINT_DEFAULT;
		flush_stream(PRINTstream);
	}
	@(return Ct)
@)

siLget_string_input_stream_index()
{
	check_arg(1);
	check_type_stream(&vs_base[0]);
	if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input)
		FEerror("~S is not a string-input stream.", 1, vs_base[0]);
	vs_base[0] = make_fixnum(vs_base[0]->sm.sm_int0);
}

siLmake_string_output_stream_from_string()
{
	object strng, strm;

	check_arg(1);
	strng = vs_base[0];
	if (type_of(strng) != t_string || !strng->st.st_hasfillp)
		FEerror("~S is not a string with a fill-pointer.", 1, strng);
	strm = alloc_object(t_stream);
	strm->sm.sm_mode = (short)smm_string_output;
	strm->sm.sm_fp = NULL;
	strm->sm.sm_object0 = strng;
	strm->sm.sm_object1 = OBJNULL;
	strm->sm.sm_int0 = strng->st.st_fillp;
	strm->sm.sm_int1 = 0;
	vs_base[0] = strm;
}

siLcopy_stream()
{
	object in, out;

	check_arg(2);
	check_type_stream(&vs_base[0]);
	check_type_stream(&vs_base[1]);
	in = vs_base[0];
	out = vs_base[1];
	while (!stream_at_end(in))
		writec_stream(readc_stream(in), out);
	flush_stream(out);
	vs_base[0] = Ct;
	vs_pop;
#ifdef AOSVS

#endif
}


too_long_file_name(fn)
object fn;
{
	FEerror("~S is a too long file name.", 1, fn);
}

cannot_open(fn)
object fn;
{
	FEerror("Cannot open the file ~A.", 1, fn);
}

cannot_create(fn)
object fn;
{
	FEerror("Cannot create the file ~A.", 1, fn);
}

cannot_read(strm)
object strm;
{
	FEerror("Cannot read the stream ~S.", 1, strm);
}

cannot_write(strm)
object strm;
{
	FEerror("Cannot write to the stream ~S.", 1, strm);
}

#ifdef USER_DEFINED_STREAMS
/* more support for user defined streams */
siLuser_stream_state()
{     
  check_arg(1);

  if(vs_base[0]->sm.sm_object1)
      vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0]; 
  else
	FEerror("sLtream data NULL ~S", 1, vs_base[0]);
}
#endif

closed_stream(strm)
object strm;
{
	FEerror("The stream ~S is already closed.", 1, strm);
}



/* returns a stream with which one can safely do fwrite to the x->sm.sm_fp
   or nil.
   */


/* coerce stream to one so that x->sm.sm_fp is suitable for fread and fwrite,
   Return nil if this is not possible.
   */

object
coerce_stream(strm,out)
object strm;
int out;
{
 BEGIN:
 if (type_of(strm) != t_stream)
   FEwrong_type_argument(sLstream, strm);
 switch (strm->sm.sm_mode){
 case smm_synonym:
  strm = symbol_value(strm->sm.sm_object0);
  if (type_of(strm) != t_stream)
			FEwrong_type_argument(sLstream, strm);
		goto BEGIN;

 case smm_two_way:
 case smm_echo:
  if (out)strm = strm->sm.sm_object1;
    else strm = strm->sm.sm_object0;
  goto BEGIN;
 case smm_output:
  if (!out) cannot_read(strm);
  break;
 case smm_input:
    if (out) cannot_write(strm);
  break;
 default:
  strm=Cnil;
  }
 if (strm!=Cnil
     && (strm->sm.sm_fp == NULL))
   closed_stream(strm);
 return(strm);
}

siLfp_output_stream()
{check_arg(1);
 vs_base[0]=coerce_stream(vs_base[0],1);
}

siLfp_input_stream()
{check_arg(1);
 vs_base[0]=coerce_stream(vs_base[0],0);
}
 

@(defun fwrite (vector start count stream)
  unsigned char *p;
  int n,beg;
@  
  stream=coerce_stream(stream,1);
  if (stream==Cnil) @(return Cnil);
  p = vector->ust.ust_self;
  beg = ((type_of(start)==t_fixnum) ? fix(start) : 0);
  n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg));
  if (fwrite(p+beg,1,n,stream->sm.sm_fp)) @(return Ct);
  @(return Cnil);
@)

@(defun fread (vector start count stream)
  unsigned char *p;
  int n,beg;
@  
  stream=coerce_stream(stream,0);
  if (stream==Cnil) @(return Cnil);
  p = vector->ust.ust_self;
  beg = ((type_of(start)==t_fixnum) ? fix(start) : 0);
  n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg));
  if (n=fread(p+beg,1,n,stream->sm.sm_fp))
      @(return `make_fixnum(n)`);
  @(return Cnil);
@)

object standard_io;
DEFVAR("*STANDARD-INPUT*",sLAstandard_inputA,LISP,(init_file(),standard_io),""); 
DEFVAR("*STANDARD-OUTPUT*",sLAstandard_outputA,LISP,standard_io,"");
DEFVAR("*ERROR-OUTPUT*",sLAerror_outputA,LISP,standard_io,"");
DEFVAR("*TERMINAL-IO*",sLAterminal_ioA,LISP,terminal_io,"");
DEFVAR("*QUERY-IO*",sLAquery_ioA,LISP,
    (standard_io->sm.sm_object0 = sLAterminal_ioA,
        standard_io),"");
DEFVAR("*DEBUG-IO*",sLAdebug_ioA,LISP,standard_io,"");
DEFVAR("*TRACE-OUTPUT*",sLAtrace_outputA,LISP,standard_io,"");


init_file()
{
	object standard_input;
	object standard_output;
	object standard;
	object x;
	standard_input = alloc_object(t_stream);
	standard_input->sm.sm_mode = (short)smm_input;
	standard_input->sm.sm_fp = stdin;
	standard_input->sm.sm_object0 = sLstring_char;
	standard_input->sm.sm_object1
#ifdef UNIX
	= make_simple_string("stdin");
#endif
	standard_input->sm.sm_int0 = 0;
	standard_input->sm.sm_int1 = 0;

	standard_output = alloc_object(t_stream);
	standard_output->sm.sm_mode = (short)smm_output;
	standard_output->sm.sm_fp = stdout;
	standard_output->sm.sm_object0 = sLstring_char;
	standard_output->sm.sm_object1
#ifdef UNIX
	= make_simple_string("stdout");
#endif
	standard_output->sm.sm_int0 = 0;
	standard_output->sm.sm_int1 = 0;

	terminal_io = standard
	= make_two_way_stream(standard_input, standard_output);
	enter_mark_origin(&terminal_io);

	x = alloc_object(t_stream);
	x->sm.sm_mode = (short)smm_synonym;
	x->sm.sm_fp = NULL;
	x->sm.sm_object0 = sLAterminal_ioA;
	x->sm.sm_object1 = OBJNULL;
	x->sm.sm_int0 = x->sm.sm_int1 = 0;
	standard_io = x;
	enter_mark_origin(&standard_io);	

}

DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,"");
DEFVAR("*LOAD-PATHNAME*",sSAload_pathnameA,SI,Cnil,"");
DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,"");

DEF_ORDINARY("ABORT",sKabort,KEYWORD,"");
DEF_ORDINARY("APPEND",sKappend,KEYWORD,"");
DEF_ORDINARY("CREATE",sKcreate,KEYWORD,"");
DEF_ORDINARY("DEFAULT",sKdefault,KEYWORD,"");
DEF_ORDINARY("DIRECTION",sKdirection,KEYWORD,"");
DEF_ORDINARY("ELEMENT-TYPE",sKelement_type,KEYWORD,"");
DEF_ORDINARY("ERROR",sKerror,KEYWORD,"");
DEF_ORDINARY("IF-DOES-NOT-EXIST",sKif_does_not_exist,KEYWORD,"");
DEF_ORDINARY("IF-EXISTS",sKif_exists,KEYWORD,"");
DEF_ORDINARY("INPUT",sKinput,KEYWORD,"");
DEF_ORDINARY("IO",sKio,KEYWORD,"");
DEF_ORDINARY("NEW-VERSION",sKnew_version,KEYWORD,"");
DEF_ORDINARY("OUTPUT",sKoutput,KEYWORD,"");
DEF_ORDINARY("OVERWRITE",sKoverwrite,KEYWORD,"");
DEF_ORDINARY("PRINT",sKprint,KEYWORD,"");
DEF_ORDINARY("PROBE",sKprobe,KEYWORD,"");
DEF_ORDINARY("RENAME",sKrename,KEYWORD,"");
DEF_ORDINARY("RENAME-AND-DELETE",sKrename_and_delete,KEYWORD,"");
DEF_ORDINARY("SET-DEFAULT-PATHNAME",sKset_default_pathname,KEYWORD,"");
DEF_ORDINARY("SUPERSEDE",sKsupersede,KEYWORD,"");
DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,"");

init_file_function()
{


#ifdef UNIX
	FASL_string = make_simple_string("o");
	make_si_constant("*EOF*",make_fixnum(EOF));
#endif
#ifdef AOSVS

#endif
	enter_mark_origin(&FASL_string);
#ifdef UNIX
	LSP_string = make_simple_string("lsp");
#endif
#ifdef AOSVS

#endif
	enter_mark_origin(&LSP_string);
	make_si_function("FP-INPUT-STREAM",	siLfp_input_stream);
	make_si_function("FP-OUTPUT-STREAM",	siLfp_output_stream);

	make_function("MAKE-SYNONYM-STREAM", Lmake_synonym_stream);
	make_function("MAKE-BROADCAST-STREAM", Lmake_broadcast_stream);
	make_function("MAKE-CONCATENATED-STREAM",
		      Lmake_concatenated_stream);
	make_function("MAKE-TWO-WAY-STREAM", Lmake_two_way_stream);
	make_function("MAKE-ECHO-STREAM", Lmake_echo_stream);
	make_function("MAKE-STRING-INPUT-STREAM",
		      Lmake_string_input_stream);
	make_function("MAKE-STRING-OUTPUT-STREAM",
		      Lmake_string_output_stream);
	make_function("GET-OUTPUT-STREAM-STRING",
		      Lget_output_stream_string);

	make_si_function("OUTPUT-STREAM-STRING", siLoutput_stream_string);
	make_si_function("FWRITE",Lfwrite);
	make_si_function("FREAD",Lfread);
	make_function("STREAMP", Lstreamp);
	make_function("INPUT-STREAM-P", Linput_stream_p);
	make_function("OUTPUT-STREAM-P", Loutput_stream_p);
	make_function("STREAM-ELEMENT-TYPE", Lstream_element_type);
	make_function("CLOSE", Lclose);

	make_function("OPEN", Lopen);

	make_function("FILE-POSITION", Lfile_position);
	make_function("FILE-LENGTH", Lfile_length);

	make_function("LOAD", Lload);

	make_si_function("GET-STRING-INPUT-STREAM-INDEX",
			 siLget_string_input_stream_index);
	make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING",
			 siLmake_string_output_stream_from_string);
	make_si_function("COPY-STREAM", siLcopy_stream);

#ifdef USER_DEFINED_STREAMS
	make_si_function("USER-STREAM-STATE", siLuser_stream_state);
#endif


}


object
read_fasl_data(str)
char *str;
{
	object faslfile, data;
#ifdef UNIX
	FILE *fp;


#ifdef BSD
#ifdef HAVE_AOUT
 	struct exec header;
#endif
#endif
#ifdef ATT
	struct filehdr fileheader;
#endif
#ifdef E15
	struct exec header;
#endif
	int i;
#endif
        vs_mark;

	faslfile = make_simple_string(str);
	vs_push(faslfile);
	faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
	vs_push(faslfile);

#ifdef SEEK_TO_END_OFILE
 	SEEK_TO_END_OFILE(faslfile->sm.sm_fp);
#else

#ifdef BSD
	fp = faslfile->sm.sm_fp;
	fread(&header, sizeof(header), 1, fp);
	fseek(fp,
	      header.a_text+header.a_data+
	      header.a_syms+header.a_trsize+header.a_drsize,
	      1);
	fread(&i, sizeof(i), 1, fp);
	fseek(fp, i - sizeof(i), 1);
#endif

#ifdef ATT
	fp = faslfile->sm.sm_fp;
	fread(&fileheader, sizeof(fileheader), 1, fp);
	fseek(fp,
	      fileheader.f_symptr+fileheader.f_nsyms*SYMESZ,
	      0);
	fread(&i, sizeof(i), 1, fp);
	fseek(fp, i - sizeof(i), 1);
	while ((i = getc(fp)) == 0)
		;
	ungetc(i, fp);
#endif

#ifdef E15
	fp = faslfile->sm.sm_fp;
	fread(&header, sizeof(header), 1, fp);
	fseek(fp,
	      header.a_text+header.a_data+
	      header.a_syms+header.a_trsize+header.a_drsize,
	      1);
#endif
#endif
	data = read_fasl_vector(faslfile);

	vs_push(data);
	close_stream(faslfile);
	vs_reset;
	return(data);
}
