/************************************************************************/
/*                                                                      */
/* Copyright (c) 1988 -                                                 */
/*     The Rector and Visitors of the University of Virginia            */
/*                                                                      */
/* This code may not be distributed further without permission          */
/*      from the University of Virginia.                                */
/* This code is distributed WITHOUT ANY WARRANTY.  No claims are        */
/*      made as to whether it serves any particular purpose or even     */
/*      works at all.                                                   */
/*                                                                      */
/************************************************************************/

# include <stdio.h>
# include <string.h>
# include <math.h>
# include <ctype.h>
# include "size.h"
# include "runtime.h"

char *malloc(), *mktemp();

extern int errno;

static FILEAREA *ftbl[_NFILE];
static int maxused = -1;

/*
 * For each file variable, the compiler allocates enough memory for
 * a FILEAREA struct and an adjacent file WINDOW (i.e., the file buffer
 * variable).  The starting address of the WINDOW is the address
 * immediately following the FILEAREA.
 */

#define WINDOW(ptr) ((char*)((ptr)+1))

static char eofmsg[] = "unexpected EOF on file \"%s\"";

#define eoferror(ptr) \
	if ((ptr)->_flags & _EOF) RERROR(0, eofmsg, (ptr)->_filename); else;

/*
 * RERROR() outputs an error message and terminates program execution.
 */

static void
RERROR (errnum, fmt, str)
	int     errnum;
	char   *fmt, *str;
{
	char     fullstr [256];
	extern char *sys_errlist[];

	sprintf (fullstr, fmt, str);
	if (errnum) {
		strcat (fullstr, ": ");
		strcat (fullstr, sys_errlist[errnum]);
	}
	RT_abort (fullstr); 
}

/*
 * RT_initfile() initializes a file's FILEAREA struct.  It sets the _magic
 * field to the magic number allowing for quick verification of this
 * initialization.  The pointer to the FILEAREA is stored in an array of
 * currently active files.  There is a system limit on how many active
 * files may exist at one time, but there is no limit to the number of
 * file variables that may be declared in the program. The "filename"
 * is the unix pathname of the file.  If "filename" is null, this is a
 * local file so RT_initfile generates a unique pathname.  If the "reclength"
 * parameter is <= 0, this is a text file.  If reclength is negative,
 * this is "input", "ouput", or "errfile", which get special treatment.
 */

void
RT_initfile (areaptr, filename, reclength)
	register
	FILEAREA   * areaptr;
	char       * filename;
	int          reclength;
{
	register int index;
	char  * localname;

	areaptr->_magic = _MAGIC;
	areaptr->_filename = filename;
	areaptr->_reclength = reclength;
	areaptr->_flags = (reclength <= 0) ? _TEXT : 0;
	if (filename) {
		areaptr->_flags |= _PERMFILE;
		if (reclength < 0) {
			switch(*filename) {

			case 'i':  /* "input" */
				areaptr->_flags |= (_STDIN|_OPEN|_LAZY);
				areaptr->_stream = stdin;
				break;

			case 'o':  /* "output" */
				areaptr->_flags |= (_STDOUT|_OPEN|_EOLN);
				areaptr->_stream = stdout;
				break;

			case 'e':  /* "errfile" */
				areaptr->_flags |= (_STDERR|_OPEN|_EOLN);
				areaptr->_stream = stderr;
				break;
			}
		}
	}
	else  {
		if ((localname = malloc(10)) == NULL)
			RERROR(errno, "malloc() failed in RT_initfile()", (char*)0);
		strcpy(localname, "locXXXXXX");
		areaptr->_filename = mktemp (localname);
	}

	/* Make entry in initialized file table  */

	for (index = areaptr->_flags & (_STDIN|_STDOUT|_STDERR) ? 0 : 3;
		index < _NFILE && ftbl[index]; index++)
	{
	}
		
	if (index >= _NFILE)
		RERROR(0, "too many active files", (char*)0);
	if (index > maxused)
		maxused = index;
	ftbl[index] = areaptr;
}

/*
 * CHKFILE() makes sure that the FILEAREA has been initialized and that
 * input operations are not being attempted on files open for output
 * and vice versa.
 */

static void
CHKFILE (areaptr, action)
	register
	FILEAREA   * areaptr;
	int          action;
{
	if (areaptr->_magic != _MAGIC || !(areaptr->_flags & _OPEN))
		RERROR (0, "file accessed before reset() or rewrite()",
			(char*)0);
	if (!(areaptr->_stream->_flag & action)) {
		if (action == _IOREAD)
			RERROR (0, "input operation on file \"%s\" after rewrite()",
				areaptr->_filename);
		else
			RERROR (0, "output operation on file \"%s\" after reset()",
				areaptr->_filename);
	}
}

/*
 * RT_reset() is the Pascal required procedure "reset".  It opens or
 * re-opens a file for input.  If not null, the "filename" parameter
 * is a unix pathname that the user specified.  When closing a text
 * file, RT_reset tacks on a newline if needed.
 */

void
RT_reset (areaptr, filename)
	register
	FILEAREA   * areaptr;
	char       * filename;
{
	register int flags;

	if (areaptr->_magic != _MAGIC)
		RERROR (0, "reset() on a local file before a rewrite()",
			(char*)0);
	flags = areaptr->_flags;  /* save old flags */

	/*  Illegal to reset "output" or "errfile"  */

	if (flags & (_STDOUT|_STDERR)) 
		RERROR (0, "reset() on file \"%s\"",
			flags & _STDOUT ? "output" : "errfile");

	areaptr->_flags |= (_OPEN|_LAZY);
	areaptr->_flags &= ~(_WNDOLIVE|_EOLN|_EOF);

	/* close file if its open and not stdin, etc. */

	if ((flags & _OPEN) && (!(flags & _STDIN) || filename)) {

		/* tack on a newline if necessary */

		if ((flags & (_TEXT|_EOLN)) == _TEXT &&
			(areaptr->_stream->_flag & _IOWRT))
		{
			putc('\n', areaptr->_stream);
		}
		if (fclose (areaptr->_stream) == EOF)  
			RERROR (errno, "fclose() failed for \"%s\" in reset()",
					areaptr->_filename);
	}
		
	/* Change name of file ? */

	if (filename && strcmp (areaptr->_filename, filename)) {
		areaptr->_filename = malloc ((unsigned) (strlen(filename)+1));
		if (areaptr->_filename == NULL)
			RERROR (errno, "malloc() failed for \"%s\" in reset()",
				filename);
		strcpy (areaptr->_filename, filename);
	}
	
	/* Do the open */

	if ((flags & _STDIN) && !filename) {

		/* reset(input) -- rewind or else put back old flags */

		if (fseek(areaptr->_stream, 0L, 0))
			areaptr->_flags = flags;
	}
	else {
		areaptr->_stream = fopen (areaptr->_filename, "r");
		if (areaptr->_stream == NULL)
			RERROR (errno, "fopen() failed for \"%s\" in reset()",
				areaptr->_filename);
	}
}

/*
 * RT_rewrite() is the Pascal required procedure "rewrite".  It opens or
 * re-opens a file for output.  If non-null, the "filename" parameter
 * is a unix pathname that the user specified.  When closing a text file,
 * RT_rewrite tacks on a newline if needed.
 */

void
RT_rewrite (areaptr, filename, reclength)
	register
	FILEAREA   * areaptr;
	char       * filename;
	int          reclength;
{
	register int flags;

	/*  FILEAREA for this file not initialized => new temp file  */

	if (areaptr->_magic != _MAGIC)
		RT_initfile (areaptr, filename, reclength);
	flags = areaptr->_flags;  /* save old flags */

	/*  Illegal to rewrite "input"  */

	if (flags & _STDIN)
		RERROR (0, "rewrite() on file \"input\"", (char*)0);

	areaptr->_flags |= (_OPEN|_EOLN|_EOF);
	areaptr->_flags &= ~(_WNDOLIVE|_LAZY);
	
	/*  If file was already open, close it.  */

	if ((flags & _OPEN)  && (!(flags & (_STDOUT|_STDERR)) || filename)) {

		/* tack on a newline if necessary */

		if ((flags & (_TEXT|_EOLN)) == _TEXT &&
			(areaptr->_stream->_flag & _IOWRT))
		{
			putc('\n', areaptr->_stream);
		}

		if (fclose (areaptr->_stream) == EOF)  
			RERROR (errno, "fclose() failed for \"%s\" in rewrite()",
				areaptr->_filename);
	}
		
	/* If opening under new name, change file name */

	if (filename && strcmp(areaptr->_filename, filename)) {
		areaptr->_filename = malloc ((unsigned) (strlen(filename)+1));
		if (areaptr->_filename == NULL)
			RERROR (errno, "malloc() failed for \"%s\" in rewrite()",
				filename);
		strcpy (areaptr->_filename, filename);
	}
	
	/* Do the open  */

	if (flags & (_STDOUT|_STDERR) && !filename) {

		/* No explicit file to open, just restore old flags. */

		areaptr->_flags = flags; 
	}
	else {
		areaptr->_stream = fopen (areaptr->_filename, "w");  
		if (areaptr->_stream == NULL)
			RERROR (errno, "fopen() failed for \"%s\" in rewrite()",
				areaptr->_filename);
	}
}

/*
 * RT_fclose2() closes all files in the active file table whose
 * FILEAREAs lie between the addresses "low" and "high".  
 * If low == 0, all active files are closed.
 */

void
RT_fclose2 (low, high)
	register FILEAREA *low, *high;
{
	register FILEAREA *areaptr;
	register int i;

	for (i = maxused; i >= 0; i--) {
		areaptr = ftbl[i];
		if (areaptr && (!low || (areaptr >= low && areaptr <= high))) {

			/* tack on newline if needed */

			if ((areaptr->_flags & (_TEXT|_OPEN|_PERMFILE|_EOLN)) ==
				(_TEXT|_OPEN|_PERMFILE) &&
				(areaptr->_stream->_flag & _IOWRT))
			{
				putc('\n', areaptr->_stream);
			}

			if (areaptr->_flags & _OPEN)
				fclose (areaptr->_stream); 
			if (!(areaptr->_flags & _PERMFILE))
				unlink (areaptr->_filename);
			areaptr->_magic = 0;
			ftbl[i] = (FILEAREA*)0;
		}
		if (i == maxused && !ftbl[i])
			--maxused;
	}
}

/*
 * RT_fclose() closes files and removes them from the active file table.
 * When a procedure activation that contains local file variables is about
 * to terminate, it calls RT_fclose.  RT_fclose finds the active files by
 * calculating two stack addresses "low" and "high" that delimit the portion
 * of the stack where the caller's local variables are stored and closes
 * any files whose FILEAREAs lie between "low" and "high".  The main program
 * also calls RT_fclose just prior to exiting, in which case "blklvl" == 1,
 * and all active files are closed.
 *
 * CAUTION:  calculation of low and high is entirely system dependent!
 */

void
RT_fclose (blklvl)
	int blklvl;
{
	register FILEAREA *low, *high;

	if (blklvl == 1)  {    /* main program -- close everything */
		RT_fclose2((FILEAREA*)0, (FILEAREA*)0);
		return;
	}

	/* high == caller's %sp == current %ap == &blklvl */

	high = (FILEAREA *)&blklvl;

	/* low == caller's %fp; (on the stack 3 words after blklvl) */

	low = ((FILEAREA **)&blklvl)[3];

	RT_fclose2(low, high);
}

/*
 * WNDO_FILL() implements Pascal's "get()" procedure.  It reads the
 * next file component into the file buffer variable.  WNDO_FILL is
 * called whenever the _LAZY flag is set, indicating that the file
 * buffer variable should have been filled earlier, but wasn't.  This
 * "lazy" approach to input helps synchronize interactive prompts and
 * responses from terminals.
 */

static void
WNDO_FILL(areaptr)
	register FILEAREA *areaptr;
{
	register int ch1;
	areaptr->_flags &= ~(_LAZY|_EOLN|_EOF|_WNDOLIVE);
	if (areaptr->_flags & _TEXT) {
		switch(ch1 = getc(areaptr->_stream)) {

		case EOF:
			areaptr->_flags |= _EOF;
			return;

		case '\n':
			ch1 = ' ';
			areaptr->_flags |= _EOLN;
		}
		*WINDOW(areaptr) = ch1;
		areaptr->_flags |= _WNDOLIVE;
	}
	else if (fread (WINDOW(areaptr), 1, areaptr->_reclength,
		areaptr->_stream) == areaptr->_reclength)
	{
		areaptr->_flags |= _WNDOLIVE;
	}
	else if (feof(areaptr->_stream))
		areaptr->_flags |= _EOF;
	else
		RERROR(0, "input operation failed on file \"%s\"",
			areaptr->_filename);
}

/*
 * RT_get() is the Pascal required procedure "get".  Note that "RT_get"
 * and all other input procedures use "lazy input".  Instead of
 * actually reading from the file, the _LAZY flag is set indicating
 * that the buffer should have been filled, but wasn't.  The next
 * file operation, seeing the _LAZY flag, will then fill the buffer.
 */

void
RT_get(areaptr)
	register FILEAREA *areaptr;
{
	CHKFILE(areaptr, _IOREAD);
	if (areaptr->_flags & _LAZY)
		WNDO_FILL(areaptr);
	eoferror(areaptr);
	areaptr->_flags |= _LAZY;
}

/*
 * RT_readchar() reads a character from a text file.
 */

char
RT_readchar (areaptr)
	register FILEAREA   * areaptr;
{
	CHKFILE(areaptr, _IOREAD);
	if (areaptr->_flags & _LAZY)  
		WNDO_FILL(areaptr);
	eoferror(areaptr);
	areaptr->_flags |= _LAZY;
	return(*WINDOW(areaptr));
}

/*
 * RT_readint() reads a character string from a text file and converts
 * it to an integer.
 */

int
RT_readint (areaptr)
	register FILEAREA  *areaptr;
{
	int i;

	CHKFILE(areaptr, _IOREAD);
	if (!(areaptr->_flags & _LAZY)) 
		ungetc(*WINDOW(areaptr), areaptr->_stream);

	switch (fscanf(areaptr->_stream, "%d", &i)) {

	case 1:   /* success */
		break;

	case EOF:
		RERROR (0, eofmsg, areaptr->_filename);
		break;
	
	default:
		RERROR (0, "scan for integer failed on file \"%s\"",
			areaptr->_filename);
		break;
	}
	areaptr->_flags |= _LAZY;
	return (i);
}

/*
 * RT_readreal() reads a character string from a text file and converts
 * it to a double.
 */

double
RT_readreal (areaptr)
	register FILEAREA   * areaptr;
{
	double x;

	CHKFILE(areaptr, _IOREAD);
	if (!(areaptr->_flags & _LAZY))
		ungetc(*WINDOW(areaptr), areaptr->_stream);

	switch(fscanf(areaptr->_stream, "%lf", &x)) {

	case 1:   /* success */
		break;

	case EOF:
		RERROR(0, eofmsg, areaptr->_filename);
		break;

	default:
		RERROR (0, "scan for real value failed on file \"%s\"",
			areaptr->_filename);
		break;
	}
	areaptr->_flags |= _LAZY;
	return (x);
}

/*
 * RT_readln() reads characters from a text file until an end of line
 * is reached.
 */
  
void
RT_readln (areaptr)
	register FILEAREA *areaptr;
{
	CHKFILE(areaptr, _IOREAD);
	if (areaptr->_flags & _LAZY)  
		WNDO_FILL(areaptr);
	while(!(areaptr->_flags & (_EOLN|_EOF)))
		WNDO_FILL(areaptr);
	eoferror(areaptr);
	areaptr->_flags |= _LAZY;
}

/*
 * RT_eoln() is Pascal's required function "eoln".  Returns 1 if the text
 * file is at end of line, otherwise 0.
 */

int
RT_eoln (areaptr)
	register FILEAREA   * areaptr;
{
	CHKFILE (areaptr, _IOREAD);
	if (areaptr->_flags & _LAZY)
		WNDO_FILL(areaptr);
	eoferror(areaptr);
	return (areaptr->_flags & _EOLN ? 1 : 0);
}

/*
 * RT_eof() is Pascal's required function "eof".  Returns 1 if at end of
 * file, otherwise 0.
 */

int
RT_eof (areaptr)
	register FILEAREA   * areaptr;
{
	CHKFILE (areaptr, _IOREAD|_IOWRT);
	if (areaptr->_flags & _LAZY)
		WNDO_FILL(areaptr);
	return (areaptr->_flags & _EOF ? 1 : 0);
}

/*
 * RT_put() is Pascal's required procedure "put".  It outputs the file buffer
 * variable to the end of the file, making sure the buffer is defined.
 */

void
RT_put (areaptr)
	register
	FILEAREA   * areaptr;
{
	CHKFILE (areaptr, _IOWRT);
	if (!(areaptr->_flags & _WNDOLIVE))
		RERROR(0, "buffer variable for file \"%s\" undefined",
			areaptr->_filename);
	areaptr->_flags &= ~(_WNDOLIVE|_EOLN);
	if (areaptr->_flags & _TEXT)
		putc (*WINDOW(areaptr), areaptr->_stream);
	else 
		fwrite (WINDOW(areaptr), 1, areaptr->_reclength,
			areaptr->_stream);
	if (ferror(areaptr->_stream))
		RERROR(errno, "output operation failed on file \"%s\"",
			areaptr->_filename);
}

/*
 * RT_writef() converts the parameter "valout" to a character string and
 * writes it to a text file.  Parameters "fieldwidth", "fracleng",
 * and "fmtchar" determine the type of "valout" and the string
 * format.  RT_writef outputs real, integer, string, character, or
 * boolean data types.
 */

void
RT_writef (areaptr, fieldwidth, fracleng, fmtchar, valout)
	FILEAREA   * areaptr;
	register
	int          fieldwidth, fracleng;
	int          valout;
	char         fmtchar;
{
	char fmt [20];
	register char *sp;
	double dbl, expo;
	register int i, need;


	CHKFILE(areaptr, _IOWRT);
	if (islower(fmtchar) && fieldwidth < 1)
		RERROR (0, "field width specifier less than 1", (char*)0);

	switch (fmtchar) {

	/* output an integer */

	case 'D':
		fieldwidth = 10;  /* fall through */

	case 'd':
		sprintf (fmt, "%%%dd", fieldwidth);
		fprintf (areaptr->_stream, fmt, valout);
		break;

	/* output a real */

	case 'E':
		fieldwidth = 15;  /* fall through */

	case 'f':
		if (fmtchar == 'f' && fracleng <= 0)
			RERROR (0, "fractional digits specifier less than 1",
				(char*)0);
		/* fall through */

	case 'e':
		if ((fieldwidth < 8) && (fmtchar != 'f'))
			fieldwidth = 8;
		dbl = * (double *) &valout;  
		if ((fmtchar != 'f') && (dbl != 0.0)) {
			/*
			 *  Compute fracleng needed to
			 *  fill total fieldwidth
			 */
			expo = floor (log10 (fabs (dbl)));
			if (expo != 0.0)
				need = ((int) floor (log10 (fabs (expo)))) + 1;
			else
				need = 2;
			need = (need < 2 ? 2 : need);
			need += 4;
			need += (dbl > 0 ? 0 : 1);
			fracleng = fieldwidth - need - 1;
			if (fracleng < 0)
				fracleng = 0;
		}
		if ((fmtchar == 'e') && (dbl == 0.0))
			fracleng = fieldwidth - 7;
		sprintf (fmt, "%%%d.%d%c", fieldwidth, fracleng, fmtchar);
		fprintf (areaptr->_stream, fmt, dbl);
		break;

	/* output a character */

	case 'C':
		fieldwidth = 1;  /* fall through */

	case 'c':
		for (i = 1; i < fieldwidth; i++)
			putc(' ', areaptr->_stream);
		putc(valout, areaptr->_stream);
		break;

	 /* output a string -- ("fracleng" is actual length of string) */

	case 'S':
		fieldwidth = fracleng;  /* fall through */

	case 's':
		for (i = fracleng; i < fieldwidth; i++)
			putc(' ', areaptr->_stream);
		if (fracleng > fieldwidth)
			fracleng = fieldwidth;
		for (sp = (char *)valout, i = 0; i < fracleng; i++)
			putc(*sp++, areaptr->_stream);
		break;

	/* output boolean -- " true" or "false" */

	case 'B':
		fieldwidth = 5;  /* fall through */

	case 'b':
		if (valout == 1) {
			fracleng = 4;
			sp = "true";
		}
		else {
			fracleng = 5;
			sp = "false";
		}
		for (i = fracleng; i < fieldwidth; i++)
			putc(' ', areaptr->_stream);
		if (fracleng > fieldwidth)
			fracleng = fieldwidth;
		for (i = 0; i < fracleng; i++)
			putc(*sp++, areaptr->_stream);
		break;
	}
	areaptr->_flags &= ~(_WNDOLIVE|_EOLN);
}


/*
 * RT_writeln() writes a newline to a text file.
 */

void
RT_writeln (areaptr)
	register FILEAREA  *areaptr;
{
	CHKFILE(areaptr, _IOWRT);
	putc ('\n', areaptr->_stream);
	areaptr->_flags &= ~_WNDOLIVE;
	areaptr->_flags |= _EOLN;
}

/*
 * RT_page() is Pascal's required procedure "page".  It writes a form feed
 * to a text file.
 */

void
RT_page (areaptr)
	register FILEAREA  *areaptr;
{
	CHKFILE (areaptr, _IOWRT);
	putc ('\f', areaptr->_stream);
	areaptr->_flags &= ~(_WNDOLIVE|_EOLN);
}
	
/*
 * RT_wndo_ptr() returns a pointer to the file buffer variable.
 * RT_wndo_ptr is called whenever the Pascal program accesses the file
 * buffer variable.  RT_wndo_ptr is also called when reading/writing
 * non-text files.
 */

char *
RT_wndo_ptr (areaptr, inspecting)
	register FILEAREA   *areaptr;
	int inspecting;
{
	CHKFILE(areaptr, _IOREAD|_IOWRT);
	if (areaptr->_flags & _LAZY)
		WNDO_FILL(areaptr);
	if (inspecting && !(areaptr->_flags & _WNDOLIVE))
		RERROR(0, "buffer variable for file \"%s\" is undefined",
			areaptr->_filename);
	areaptr->_flags |= _WNDOLIVE;
	return (WINDOW(areaptr));
}
