static  char sccsid[] = "%M% %I% %E%";
/*
 * Dynamic loader for Forth.  This program reads in a binary image of
 * a Forth system and executes it.  It connects standard input to the
 * Forth input stream (key and expect) and puts the Forth output stream
 * on standard output.
 *
 * An array of entry points for Unix system calls is provided to the
 * Forth system, so that Forth may conveniently access certain Unix
 * system calls.
 *
 * Synopsis:
 *
 * forth [ <forth-binary>.exe ] [ -v ] [ file ]
 *                         [ -s 'string of forth commands' ] ...
 *
 * <forth-binary> is the name of the ".exe" file containing the forth binary
 * image.  It is NOT in a.out format.  It is an exact image of the forth
 * dictionary, with an image of the initial user area appended to the end.
 * If the first argument does not end in ".exe", the default binary file
 * DEFAULT_EXE is used.
 *
 * If additional arguments are provided, they are taken to be the names of
 * files to be successively provided to the Forth system as it's input
 * stream.  If a "-" appears as one of the file arguments, the standard
 * input is connected to the the Forth input stream.
 *
 * An argument of the form   -s  "string of forth commands"
 * will pass the given string to the forth system when the argument is
 * encountered.
 *
 * An argument   -v   turns on reporting of file names as they are opened.
 *
 * If there are no additional file arguments, standard input is connected
 * the the Forth input stream.
 *
 * The Forth system may determine whether the input stream is coming from
 * a file or from standard input by calling the function "input_is_file()".
 * This is useful for deciding whether or not to prompt.
 */

#include <stdio.h>
#include <signal.h>
#include <sys/types.h>
#include <sys/ioctl.h>
#include <sys/stat.h>

#ifdef sun
#include <sys/wait.h>
#include <sys/mman.h>
#include <sys/time.h>
#else
#include <wait.h>
#include <time.h>
#endif

#include <math.h>

#ifdef SUN
#define DEFAULT_PATH ".:/usr/local/lib/forth"
#else
#define DEFAULT_PATH ".:/usr/local/lib/forth"
#endif
#define	DEFAULT_EXE "files.exe"

extern char *	substr();

extern int 	open(), creat();
extern int      close(), read(), write();
extern int	ioctl();
extern FILE *	open_next_file();
extern int	nextchar();
extern int	outputchar();
extern int	checkterm();
extern int	exit();
extern int	lseek();
extern int	unlink();
extern int	input_is_file();
extern int	getenv();
#ifdef sun
extern char	*valloc();
extern int	mmap();
extern struct tm *today();
extern int	timez();
extern char	*timezstr();
extern char	*timezone();
#endif
extern int	fork();
extern int	execve();
extern int	spawn();
extern int	system();
extern int	chdir();
extern int	getwd();
extern caddr_t	sbrk();
extern int	cexpect();
#ifdef USECOMMAND
extern int	scommand();
#endif
extern int	ctype();

/*
 * Only the first 13 (0-48) of these functions are absolutely necessary.
 * Number 108 is necessary too, now.
 * The rest are used by various extension packages and can be replaced
 * by dummy entries, with the loss of only that extension package
 */

int ( (*functions[])()) = {
/*	0		4	*/
	nextchar,	outputchar,

/*	8	12	16	20	24	28	32 */
	open,	creat,	close,	read,	write,	ioctl,	checkterm,

/*	36	40	44	48		52	*/
        exit,	lseek,	unlink,	input_is_file,	getenv,

#ifdef sun
/*	56,	60,		*/
	valloc,	mmap,

/*	64	68	72	*/
	today,	timez,	timezstr,
#else
 0, 0, 0, 0, 0,
#endif

/*	76,	80,	84,	88,	92,	96,	100,	*/
	fork,	execve,	spawn,	system,	signal,	chdir,	getwd,
/*	104,	*/
	sbrk,
/*	108	*/
	cexpect,
#ifdef USECOMMAND
/*	112	*/
	scommand,
#else
	0,
#endif
/*	116	*/
	ctype,
};

#define MAX_KERNEL_SIZE 512*1024

extern handle_signal();
/*
 * Insane is used by the error handling code to decide whether to do a
 * warm start or to give up.
 */
int insane;
int ip_is_file;
int gargc;
char **gargv;
FILE *fi;
char * faddr;

main(argc, argv)
	int argc;
	char **argv;
{
	int cnt;
	int f;
	int catch_signals;
	char * dictionary_file;

	/* If forth is invoked as "bomb", then we don't catch signals */
	catch_signals = strcmp(argv[0], "bomb");

	if( argc < 2
	||  strcmp(substr(argv[1],-4,4),".exe") != 0 ) {
	    dictionary_file = DEFAULT_EXE;
	} else {
	    dictionary_file = argv[1];
	    argc -= 1;
	    argv += 1;
	}
    	if( (f = path_open(dictionary_file) ) < 0 ) {
	    printf("forth: Can't open %s\n",dictionary_file);
	    perror("");
	    exit(1);
	}
	get_workspace(MAX_KERNEL_SIZE);
	if( (cnt = read(f, faddr, MAX_KERNEL_SIZE)) < 0 ) {
		printf("forth: Read failed\n");
 		exit(1);
	}
	gargc = argc; gargv = argv;

	ip_is_file = 0;
	fi = (argc <= 1) ? stdin : open_next_file() ;
	setbuf(stdout, NULL);

#ifdef CATCHINT
	if ( catch_signals ) {
		signal(SIGINT,handle_signal);
		signal(SIGILL,handle_signal);
		signal(SIGIOT,handle_signal);
		signal(SIGEMT,handle_signal);
		signal(SIGSEGV,handle_signal);
		signal(SIGBUS,handle_signal);
	}
#endif CATCHINT
	exit((*(int (*) ())faddr)(faddr+cnt,functions,&gargc,&gargv));
}

#ifdef CATCHINT
handle_signal(sig,code,scp)
	int sig, code;
	struct sigcontext * scp;
{

	switch(sig) {
	    case SIGINT:
	    	break;
	    case SIGILL:
	    	printf("Illegal Instruction\n");
		break;
	    case SIGSEGV:
	        printf("Segmentation violation\n");
		break;
	    case SIGBUS:
		printf("Bus Error\n");
	        break;
	    case SIGIOT:
		printf("IOT Instruction Trap\n");
	        break;
	    case SIGEMT:
		printf("EMT Instruction Trap\n");
	        break;
	}
/*
 * If the interrupt occurs when taking input from a file,
 * recovery is probably not possible,
 * so doing a warm start is inappropriate.
 */
	if( ip_is_file || insane++ )
		exit(1);
	else {
#ifdef sun
		scp->sc_pc = (int)(faddr+4);
#else
	/* Unblock all signals; the signal we're processing is blocked */
		sigsetmask(0);
		( *(int (*)())(faddr+4) )();
#endif sun
	}
}
#endif CATCHINT

checkterm()
{
	int nchars;
	if ( fi != stdin || (nchars = stdin->_cnt) == 0 )
		ioctl(0,FIONREAD,&nchars);

	return (nchars);
}

char strbuf[128];
char *argstring;
char *strptr;
#define STRINGINPUT (FILE *) -5

int
nextchar()
{
	register int c;

	insane = 0;
	do {
		if ( fi == STRINGINPUT ) {
		    if( (c = *strptr++) != '\0')
		    	return(c);
		} else {
		    if((c = getc(fi)) != EOF )
			return(c);
		    else
			if (fi!=stdin) fclose(fi);
		}
		fi = open_next_file();
	} while (fi != NULL);
	exit(0);
}

int
cexpect(max, buffer)
	register int max;
	char * buffer;
{
	register int c;
	register char *p = buffer;

	insane = 0;
	if ( fi == NULL )
	    if ((fi = open_next_file()) == NULL)
		exit(0);

	while ( fi == STRINGINPUT || feof( fi ) ) {
	    if ( fi == STRINGINPUT ) {
		while (max--)
		    if ( (*p++ = *argstring++) == '\0' )
			break;
		if ( max >= 0 )
		    --p;
		fi = NULL;
		return ( p - buffer );
	    }
	    if ( feof( fi ) ) {
		if (fi!=stdin)
		    fclose(fi);
		if ((fi = open_next_file()) == NULL)
		    exit(0);
	    }
	}

	while (max--  &&  (c = getc(fi)) != '\n'  &&  c != EOF )
	    *p++ = c;
	return ( p - buffer );
}


FILE *
open_next_file()
{
	register FILE * fi;
	static int vflag = 0; /* controls reporting of file names */

	while (--gargc > 0) {
		if ( (*++gargv)[0]=='-' ) {
			switch((*gargv)[1]) {
			case '\0':
				ip_is_file = 0;
				fi = stdin;
				return(fi);
			case 's':
				ip_is_file = 1;
				++gargv; --gargc;
				argstring = *gargv;
				strcpy(strbuf, *gargv);
				strptr = strcat(strbuf, "\n");
				return(STRINGINPUT);
			case 'v':
				vflag = 1;
				break;
			default:
				fprintf(stderr,"Unknown flag %s\n",*gargv);
			}
		}
		else {
			if ((fi = fopen(*gargv, "r")) == NULL) {
				perror(*gargv);
				continue;
			}
			else {
				if (vflag)
					printf("File: %s\n",*gargv);
				/* input is coming from a file */
				ip_is_file = 1;
				return(fi);
			}
		}
	}
	return(NULL);
}
outputchar(c)
int c;
{
	putchar(c);
}
ctype(len, addr)
register int len;
register char * addr;
{
	while (len--)
		putchar(*addr++);
}
/*
 * This routine is called by the forth system to determine whether
 * its input stream is connected to a file or to the possibly-interactive
 * stdin stream.  It uses this information to decide whether or not to
 * prompt at the beginning of a line.
 */
int input_is_file()
{
    return(ip_is_file);
}
char *
substr(str, pos, n)
	char *str;
	int pos, n;
{
	register int len = strlen(str);
	static char outstr[128];

	if( pos < 0 )
		pos += len+1;
	if( pos <= 0 )
		pos = 1;
	if (n < 0)
		n += len;
	if (pos + n - 1 > len) {
		n = len + 1  - pos;
		if (n < 0)
		    n = 0;
	}
	strncpy(outstr, str + pos - 1, n);
	outstr[n] = '\0';

	return(outstr);
}

align (current,boundary)
	int current, boundary;
{
    	return( ((current + boundary - 1) / boundary ) * boundary );
}

get_workspace(size)
	int size;
{
	int current;

	current = (int)sbrk(0);
	faddr = (char *) align(current,64*1024);
	if( brk(faddr) != 0 ) {
		fprintf(stderr,"forth: brk: couldn't get memory\n");
		exit(1);
	}
	if( sbrk(2*size) == -1 ) {  /* get extra space for metacompiler */
		fprintf(stderr,"forth: sbrk: couldn't get memory\n");
		exit(1);
	}
}

#ifdef sun
struct tm
*today()
{
	struct timeval tp;
	struct timezone tzp;

	gettimeofday(&tp, &tzp);
	return(localtime(&tp.tv_sec));
}    	
long
timez()
{
	struct timeval tp;
	struct timezone tzp;

	gettimeofday(&tp, &tzp);
	return(tzp.tz_minuteswest);
}
char
*timezstr()
{
	struct timeval tp;
	struct timezone tzp;
	struct tm *tb;

	gettimeofday(&tp, &tzp);
	tb = localtime(&tp.tv_sec);

	return(timezone(tzp.tz_minuteswest,tb->tm_isdst));
}
#endif sun

int
spawn(name, argv, envp)
     char *name, *argv[], *envp[];
{
	int pid;
	union wait status;

	if( (pid = vfork()) == -1 )
		return(0);
	else if (pid == 0) {	/* Child process */
		execve(name, argv, envp);
		_exit(1);	/* Random magic number */
	} else {		/* parent process */
		wait(&status);
		return( status.w_T.w_Retcode == 0 );
	}
}
/*
 * Tries to open the named file looking in each directory of the
 * search path specified by the environment variable FPATH.
 * Returns file descriptor or -1 if not found
 */
char    fnb[300];
path_open(fn)
register char *fn;
{
    static char *path;
    register char *dp;
    int     fd;
    register char  *lpath;

    if (fn == 0 )
	return -1;
    if (path == 0) {
	path = (char *) getenv ("FPATH");
	if (path == 0)
	    path = DEFAULT_PATH;
    }
    lpath = *fn == '/' ? "" : path;
    do {
	dp = fnb;
	while (*lpath && *lpath != ':')
	    *dp++ = *lpath++;
	if (dp != fnb)
	    *dp++ = '/';
	strcpy (dp, fn);
	if ((fd = open (fnb, 0)) >= 0)
	    break;
    } while (*lpath++);
}