Initial commit of OpenSPARC T2 architecture model.

[OpenSPARC-T2-SAM] / obp / obp / os / unix / fsys.c

/*
* ========== Copyright Header Begin ==========================================
*
* Hypervisor Software File: fsys.c
* 
* Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
* 
*  - Do no alter or remove copyright notices
* 
*  - Redistribution and use of this software in source and binary forms, with 
*    or without modification, are permitted provided that the following 
*    conditions are met: 
* 
*  - Redistribution of source code must retain the above copyright notice, 
*    this list of conditions and the following disclaimer.
* 
*  - Redistribution in binary form must reproduce the above copyright notice,
*    this list of conditions and the following disclaimer in the
*    documentation and/or other materials provided with the distribution. 
* 
*    Neither the name of Sun Microsystems, Inc. or the names of contributors 
* may be used to endorse or promote products derived from this software 
* without specific prior written permission. 
* 
*     This software is provided "AS IS," without a warranty of any kind. 
* ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
* INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
* PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
* MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
* ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
* DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
* OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
* FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
* DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
* ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
* SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
* 
* You acknowledge that this software is not designed, licensed or
* intended for use in the design, construction, operation or maintenance of
* any nuclear facility. 
* 
* ========== Copyright Header End ============================================
*/
/*
 * @(#)fsys.c 1.3 03/08/20
 * Copyright 1985-1994 Bradley Forthware
 * Copyright 1994-2003 Sun Microsystems, Inc.  All Rights Reserved
 * Copyright Use is subject to license terms.
 *
 * this file contains the routines that have the same function as
 * those in wrapper.c, except that they use the forth stack to take and
 * return arguments, effectively they are wrapper additions to the
 * forth engine hooked into the machine using the same vector interface
 * as wrapper.c.
 *
 */

#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <fcntl.h>
#include <strings.h>

#ifdef DLOPEN
#include <dlfcn.h>
#include <link.h>
#endif

#include <sys/types.h>
#include <sys/time.h>
#include <sys/param.h>
#include <sys/stat.h>

#include <signal.h>
#include <termios.h>

#include "wrapper.h"
#include "xref_support.h"
#include "defines.h"

#define	FPROTO(x)	static fstackp x(fstackp stack)
#define	UNIMPL(xx)	printf("%s:%d: Unimplemented syscall " #xx "\n", \
    __FILE__, __LINE__); \
    return (stack)

extern char *substr();
extern void s_bye(long code);

extern int	errno;		/* Wherever the error code goes */

struct termios ostate;
struct termios lstate;
struct termios kstate;
struct termios kqstate;

#define	M_ORIG 0
#define	M_KEY  1
#define	M_LINE 2
#define	M_KEYQ 3
static lmode = M_ORIG;

static fstackp
pop_fstring(fstackp stack, char **buf, int *len)
{
	char *fstr;
	*len = POP(stack);
	fstr = (char *)POP(stack);
	if (*len) {
		*buf = malloc(*len+1);
		strncpy(*buf, fstr, *len);
		(*buf)[*len] = 0;
		*len++;
	} else {
		*buf = NULL;
	}
	return (stack);
}

static fstackp
push_cstring(fstackp stack, char *buf, int len)
{
	PUSH(len, stack);
	PUSH(buf, stack);
	return (stack);
}

static void
initline(void)
{
	if (lmode != M_ORIG)
		return;

	tcgetattr(0, &ostate);			/* save old state */

	tcgetattr(0, &lstate);			/* base of line state */
	lstate.c_iflag |= IXON|IXANY|IXOFF;	/* XON/XOFF */
	lstate.c_iflag |= ICRNL;		/* CR/NL munging */
#ifndef FreeBSD
	lstate.c_iflag &= ~(IUCLC);		/* no case folding */
#endif
/* Always turning on ONLCR is safe, but it is a pain in an EMACS window  */
#ifdef notdef
	lstate.c_oflag |=  OPOST|ONLCR;		/* Map NL to CR-LF */
	lstate.c_oflag &= ~(OLCUC);		/* No case folding */
	lstate.c_oflag &= ~(OCRNL|ONLRET);	/* Don't swap cr and lf */
#else
	lstate.c_oflag |=  OPOST;
#endif
	lstate.c_lflag |= ICANON|ECHO;		/* Line editing on */
	lstate.c_cc[VMIN] = 1;			/* Don't hold up input */
	lstate.c_cc[VTIME] = 0;			/* No input delay */

	tcgetattr(0, &kstate);			/* base of key state */
	kstate.c_iflag &= ~(IXON|IXANY|IXOFF);  /* no XON/XOFF */
	kstate.c_iflag &= ~(INLCR|ICRNL);	/* no CR/NL munging */
#ifndef FreeBSD
	kstate.c_iflag &= ~(IUCLC);		/* no case folding */
#endif
/* Always turning on ONLCR is safe, but it is a pain in an EMACS window  */
#ifdef notdef
	kstate.c_oflag |=  OPOST|ONLCR;		/* Map NL to CR-LF */
	kstate.c_oflag &= ~(OLCUC);		/* No case folding */
	kstate.c_oflag &= ~(OCRNL|ONLRET);	/* Don't swap cr and lf */
#else
	kstate.c_oflag |=  OPOST;		/* */
#endif
	kstate.c_lflag &= ~(ICANON|ECHO);	/* No editing characters */
	kstate.c_cc[VMIN] = 1;			/* Don't hold up input */
	kstate.c_cc[VTIME] = 0;			/* No input delay */

	kqstate = kstate;
	kqstate.c_cc[VMIN] = 0;			/* Poll for character */

}

static void
linemode(void)
{
	initline();
	if (lmode != M_LINE) {
		tcsetattr(0, TCSANOW, &lstate);
		lmode = M_LINE;
	}
}

static void
keyqmode(void)
{
	initline();
	if (lmode != M_KEYQ) {
		tcsetattr(0, TCSANOW, &kqstate);
		lmode = M_KEYQ;
	}
}

static void
keymode(void)
{
	initline();
	if (lmode != M_KEY) {
		tcsetattr(0, TCSANOW, &kstate);
		lmode = M_KEY;
	}
}

static void
restoremode(void)
{
	initline();
	if (lmode != M_ORIG) {
		tcsetattr(0, TCSANOW, &ostate);
		lmode = M_ORIG;
	}
}

/*
 * Function semantics:
 *
 * Functions which are the names of Unix system calls have the semantics
 * of those Unix system calls.
 *
 * char c_key();				Gets next input character
 *	no echo or editing, don't wait for a newline.
 * c_emit(char c);				Outputs the character.
 * long f_open(char *path, long mode);		Opens a file.
 *	Mode must agree with wrsys.fth
 * long f_creat(char *path, long mode); 	Creates a file.
 *	Mode must agree with wrsys.fth
 * long f_read(long fd, char *buf, long cnt);	Reads from a file
 * long f_write(long fd, char *buf, long cnt);	Writes to a file
 * long f_ioctl(long fd, long code, char *buf);	Is not used right now.
 * long c_keyques();				True if a keystroke is pending.
 *	If you can't implement this, return false.
 * s_bye(long status);				Cleans up and exits.
 * long f_lseek(long fd, long offset, long whence);Changes file position.
 *	Whence:  0 - from start of file  1 - from current pos.  2 - from end
 * long f_unlink(char *path);			Deletes a file.
 * long fileques();				True if input stream has been
 *	redirected away from a keyboard.
 * long c_type(long len, char *addr);		Outputs len characters.
 * long c_expect(long max, char *buffer);	Reads an edited line of input.
 * long c_cr();					Advances to next line.
 * long f_crstr()				Returns file line terminator.
 * long syserror();				Error code from the last
 *	failed system call.
 */

extern char *progname;
extern char sccs_get_cmd[128]; /* sccs get command string */
extern int uflag;
extern int vflag;
extern int xref_enabled;
extern int show_symbols;

/*
 * Returns true if a key has been typed on the keyboard since the last
 * call to c_key().
 */
FPROTO(c_keyques)
{
	int nchars = 0;

	fflush(stdout);

#ifdef FreeBSD
	if ((nchars = stdin->_r) == 0) {
		char c[1];
		keyqmode();
		nchars = read(0, c, 1) > 0;
		if (nchars)
			ungetc(c[0], stdin);
	}
#else
#ifdef IRIS
	return (0);
#endif
#endif
	{
		char c[1];
		keyqmode();
		nchars = read(0, c, 1) > 0;
		if (nchars)
			ungetc(c[0], stdin);
	}

	PUSH(nchars, stack);
	return (stack);
}

FPROTO(f_bye)
{
	int status;

	status = POP(stack);
	s_bye(status);
	return (stack);
}

/*
 * Get the next character from the input stream.
 */
/*
 * There is a minor problem under Regulus relating to interrupted system
 * calls.  If the user types the INTERRUPT character (e.g. DEL) while
 * Forth is waiting for input, the read system call will be interrupted.
 * Forth will field the signal thus generated, save the state, and return
 * to the Forth interpreter.  If the user then tries to restart from the
 * saved state, the restarted system call will return 0, which is the same
 * code that is returned for end-of-file.  This is especially nasty when
 * using the Regulus standard-I/O package, because when it see the 0-length
 * read, it set a flag in the stdio file descriptor and returns EOF
 * forevermore.  What we really want to happen is for the read system call
 * to restart cleanly and continue waiting for input, rather than returning
 * 0.
 */

FPROTO(c_key)
{
	int c;

	keymode();

	fflush(stdout);
	if ((c = getc(stdin)) != EOF) {
		PUSH(c, stack);
		return (stack);
	}
	s_bye(0L);
	return (NULL);
}

/*
 * Send the character c to the output stream.
 */
FPROTO(c_emit)
{
	int c;

	c = (int)POP(stack);
	putchar(c);
	fflush(stdout);
	return (stack);
}

/*
 * This routine is called by the Forth system to determine whether
 * its input stream is connected to a file or to a terminal.
 * It uses this information to decide whether or not to
 * prompt at the beginning of a line.  If you are running in an environment
 * where input cannot be redirected away from the terminal, just return 0L.
 */
FPROTO(fileques)
{
	int status = !isatty(fileno(stdin));
	PUSH(status, stack);
	return (stack);
}

/*
 * Get an edited line of input from the keyboard, placing it at buffer.
 * At most "max" characters will be placed in the buffer.
 * The line terminator character is not stored in the buffer.
 */
FPROTO(c_expect)
{
	int c;
	long max;
	char *buffer;
	char *p;

	max = POP(stack);
	buffer = (char *)POP(stack);

	p = buffer;
	linemode();

	fflush(stdout);
	while (max-- && ((c = getc(stdin)) != '\n') && (c != EOF))
		*p++ = c;
	if (c == EOF)
		*p++ = '\n';
	keymode();

	PUSH((p-buffer), stack);
	return (stack);
}

/*
 * Send len characters from the buffer at addr to the output stream.
 */
FPROTO(c_type)
{
	long len;
	char *addr;

	len = POP(stack);
	addr = (char *)POP(stack);

	while (len--)
		putchar(*addr++);
	fflush(stdout);

	return (stack);
}

/*
 * Sends an end-of-line sequence to the output stream.
 */
FPROTO(c_cr)
{
	putchar('\n');
	fflush(stdout);
	return (stack);
}

/*
 * Returns the end-of-line sequence that is used within files as
 * a packed (leading count byte) string.
 */
FPROTO(f_crstr)
{
	char crstr[2] = { 0x01, '\n' };
	PUSH(crstr, stack);
	return (stack);
}

/* Find the error code returned by the last failing system call. */
FPROTO(syserror)
{
	PUSH(errno, stack);
	return (stack);
}

/* Display an error message */

FPROTO(pr_error)
{
	errno = POP(stack);
	perror("");
	return (stack);
}

FPROTO(f_open)
{
	char *name;
	int flag;
	mode_t mode;
	int status;

	mode = (mode_t)POP(stack);
	flag = (int)POP(stack);
	name = (char *)POP(stack);
	name = expand_name(name);

#ifdef SCCS
	if (uflag)
		if (isobsolete(name) == 1)
			system(sccs_get(name));
#endif SCCS
	if (vflag)
		printf("File: %s\n", name);

	status = open(name, flag, mode);
	return (stack);
}

FPROTO(f_creat)
{
#if 0
	(char *name, long mode)
	name = expand_name(name);

	return ((long)open(name, O_RDWR|O_CREAT|O_TRUNC, (int)mode));
#endif
	return (stack);
}

/* f_read ( fd buf len -- #bytes ) */
FPROTO(f_read)
{
	int fd;
	char *buf;
	size_t len;
	ssize_t bytes;

	len = POP(stack);
	buf = (char *)POP(stack);
	fd = POP(stack);
	bytes = read(fd, buf, len);
	PUSH(bytes, stack);
	return (stack);
}

/* f_write ( fd adr len -- #written ) */
FPROTO(f_write)
{
	int fd;
	char *buf;
	size_t len;
	ssize_t bytes;

	len = POP(stack);
	buf = (char *)POP(stack);
	fd = POP(stack);

	bytes = write(fd, buf, len);
	PUSH(bytes, stack);
	return (stack);
}

FPROTO(f_close)
{
	int fd, status;

	fd = POP(stack);
	status = close(fd);
	return (stack);
}

/* unlink ( str,len -- ok? ) */
FPROTO(f_unlink)
{
	int len;
	char *buffer;
	char *path;
	int status;

	stack = pop_fstring(stack, &path, &len);
#if 0
	status = unlink(path);
#else
	printf("UNLINK: %s\n", path);
#endif
	free(path);
	PUSH(status, stack);
	return (stack);
}

/* f_seek ( fd offset whence -- ) */
FPROTO(f_lseek)
{
	int fd;
	off_t offset;
	int whence;
	off_t status;

	whence = POP(stack);
	offset = POP(stack);
	fd = POP(stack);

	status = lseek(fd, offset, whence);

	PUSH(status, stack);
	return (stack);
}

FPROTO(f_ioctl)
{
	int fd;
	char *buf;
	int code;
	int status;

	buf = (char *)POP(stack);
	code = POP(stack);
	fd = POP(stack);

	status = ioctl(fd, code, buf);
	PUSH(status, stack);
	return (stack);
}

FPROTO(s_signal)
{
	void (*disp)(int);
	int sig;
	void (*prev)(int);

	disp = (void (*)())POP(stack);
	sig = POP(stack);
	prev = signal(sig, disp);
	PUSH(prev, stack);
	return (stack);
}

FPROTO(s_system)
{
	int len, status;
	char *buf;
	char *sbuf;

	stack = pop_fstring(stack, &sbuf, &len);

	linemode();
	status = system(sbuf);
	keymode();
	free(sbuf);

	PUSH(status, stack);
	return (stack);
}

/* chdir ( str,len -- ok? ) */
FPROTO(s_chdir)
{
	int len, status;
	char *buf;
	char *sbuf;

	stack = pop_fstring(stack, &sbuf, &len);
	status = chdir(sbuf);
	free(sbuf);

	PUSH(status, stack);
	return (stack);
}

/* getwd ( -- str,len ) */
FPROTO(s_getwd)
{
	char *buf, *sbuf;
	int len;

	buf = malloc(MAXPATHLEN+1);
	sbuf = getwd(buf);
	if (sbuf != NULL) {
		len = strlen(buf);
		sbuf = strdup(buf);
		free(buf);
		buf = sbuf;
	} else {
		free(buf);
		len = 0;
	}
	PUSH(buf, stack);
	PUSH(len, stack);
	return (stack);
}

/* alloc ( len -- buf ) */
FPROTO(m_alloc)
{
	size_t size;
	void *buf;

#ifdef PPCSIM
	size = (size+7) & ~7;
#endif
	buf = malloc(size);
	if (buf != NULL)
		memset(buf, 0, size);

	PUSH(buf, stack);
	return (stack);
}

/* free ( adr,len -- ) */
FPROTO(m_free)
{
	int len;
	char *buf;

	len = POP(stack);
	buf = (char *)POP(stack);
	free(buf);
	return (stack);
}

/* sbrk ( size -- va ) */
FPROTO(m_sbrk)
{
	intptr_t size;
	void *ptr;

	size = POP(stack);
	ptr = sbrk(size);
	PUSH(ptr, stack);
	return (stack);
}

#ifndef DLOPEN
FPROTO(f_dlopen)
{
	UNIMPL(f_dlopen);
}

FPROTO(f_dlclose)
{
	UNIMPL(f_dlclose);
}

FPROTO(f_dlsym)
{
	UNIMPL(f_dlsym);
}

FPROTO(f_dlerror)
{
	UNIMPL(f_dlerror);
}
#else
/* dlopen ( str,len mode -- handle ) */
FPROTO(f_dlopen)
{
	int mode;
	int len;
	char *lib;
	void *handle;

	mode = POP(stack);
	stack = pop_fstring(stack, &lib, &len);

	handle = dlopen(lib, mode);
	free(lib);
	PUSH(handle, stack);
	return (stack);
}

/* dlclose ( handle -- ) */
FPROTO(f_dlclose)
{
	void *handle;
	handle = (void *)POP(stack);
	dlclose(handle);
	return (stack);
}

/* dlerror ( -- str,len ) */
FPROTO(f_dlerror)
{
	int len;
	char *err = dlerror();

	if (err != NULL) {
		stack = push_cstring(stack, err, strlen(err));
	} else {
		stack = push_cstring(stack, err, 0);
	}
	return (stack);
}

/* dlsym ( str,len handle -- ptr ) */
FPROTO(f_dlsym)
{
	void *handle, *symptr;
	char *sym;
	int len;

	handle = (void *)POP(stack);
	stack = pop_fstring(stack, &sym, &len);
	symptr = dlsym(handle, sym);
	free(sym);
	PUSH(symptr, stack);
	return (stack);
}
#endif

/* getenv ( str,len -- buf,len ) */
FPROTO(c_getenv)
{
	int len, blen;
	char *cstr, *sbuf, *buf;

	stack = pop_fstring(stack, &sbuf, &len);
	buf = getenv(sbuf);
	free(sbuf);
	if (buf == NULL) {
		blen = 0;
	} else {
		blen = strlen(buf);
	}
	PUSH(buf, stack);
	PUSH(blen, stack);
	return (stack);
}

FPROTO(today)
{
	long tadd;

	time(&tadd);
	PUSH(localtime(&tadd), stack);
	return (stack);
}

FPROTO(timez)
{
	UNIMPL(timez);
}

FPROTO(timezstr)
{
	UNIMPL(timezstr);
}

/*
 * Flush the data cache if necessary and possible.  Used after writing
 * instructions into the dictionary.
 */
FPROTO(s_flushcache)
{
#ifdef NeXT
	asm("trap #2");
#endif
	UNIMPL(s_flushcache);
}

FPROTO(f_init)
{
	UNIMPL(f_init);
}

FPROTO(f_op)
{
	UNIMPL(f_op);
}

FPROTO(f_move)
{
	UNIMPL(f_move);
}

FPROTO(f_rows)
{
	UNIMPL(f_rows);
}

FPROTO(f_cols)
{
	UNIMPL(f_cols);
}

FPROTO(pathname)
{
	UNIMPL(pathname);
}

#ifdef SIMFORTH
FPROTO(find_next)
{
	int shift = POP(stack);
	int token_size = POP(stack);
	int origin = POP(stack);
	char *link = (char *)POP(stack);
	char *str = (char *)POP(stack);
	int len, nextlen;
	char *namep;
	char *p = str;

	len = strlen(p);

	if (tshift == 0)
	    link = (char *)((*(unsigned long *)(link)) +(origin));
	else
	    link = (char *)((*(unsigned short *)(link) << tshift) +(origin));

	while (link != (char *)origin) {
		p = str;
		namep = link - token_size - 1;
		nextlen = (*namep) & 0x1f;
		namep = namep - nextlen;
		if (len == nextlen)
			while (nextlen--)
				if (*(namep++) != *(p++))
					break;
		if (nextlen == -1) {
			PUSH((((long)link)-token_size), stack);
			return (stack);
		}

		if (tshift == 0)
			link = (char *)((*(unsigned long *)(link-token_size))
			    +(origin));
		else
			link = (char *)((*(unsigned short *)(link-token_size)
			    << tshift) +(origin));
	}

	PUSH(0, stack);
	return (stack);
}
#endif /* SIMFORTH */

/* save-image ( up,len origin,len name,len -- ) */
FPROTO(save_image)
{
	char *fname;
	uchar_t *upaddr, *dicaddr;
	int flen, ulen, dlen;
	FILE *file;

	stack = pop_fstring(stack, &fname, &flen);
	dlen = POP(stack);
	dicaddr = (uchar_t *)POP(stack);
	ulen = POP(stack);
	upaddr = (uchar_t *)POP(stack);

	file = fopen(fname, "wb");
	if (file == NULL) {
		fprintf(stderr, "save_image: failed to create %s\n",
		    fname);
		return (stack);
	}
	fwrite(dicaddr, 1, dlen, file);
	fwrite(upaddr, 1, ulen, file);
	fclose(file);
	return (stack);
}

static include_file_t *includes = NULL;

/* include ( str,len -- str,len ) */
FPROTO(includefile)
{
	include_file_t *newfile;
	FILE *fd;
	char *cname, *name;
	char *fname;
	int len;
	fstackp current;

	(void) pop_fstring(stack, &cname, &len);

	name = expand_name(cname);

#ifdef SCCS
	if (uflag)
		if (isobsolete(name) == 1)
			system(sccs_get(name));
#endif
	/*
	 * open the file, using SCCS if required
	 */
	fd = fopen(name, "r");
	if (fd == NULL) {
		printf("failed to open %s\n", name);
	}
	newfile = malloc(sizeof (include_file_t));
	if (newfile == NULL) {
		printf("Malloc failed for include file: %s\n", name);
		exit(1);
	}
	newfile->next = includes;
	newfile->linenum = 0;
	newfile->name = strdup(name);
	newfile->fd = fd;
	includes = newfile;
	if (vflag) {
		printf("File: %s\n", name);
	}
	free(cname);
	return (current);
}

/* bootstrap ( str,len -- buf,len ) */
FPROTO(bootstrap)
{
	int fd;
	char *cname, *name;
	struct stat sbuf;
	int flen, len;
	char *fname, *buffer;

	stack = pop_fstring(stack, &cname, &len);
	if (len == 0) {
		buffer = NULL;
		goto error;
	}
	name = expand_name(cname);

	printf("Bootstrap: %s (%s)\n", cname, name);
#ifdef SCCS
	if (uflag)
		if (isobsolete(name) == 1)
			system(sccs_get(name));
#endif

	/*
	 * open the file, using SCCS if required
	 */
	fd = open(name, O_RDONLY);
	if (fd < 0) {
		printf("failed to open bootstrap file %s\n", name);
		buffer = NULL;
		goto error;
	}
	fstat(fd, &sbuf);
	buffer = malloc(sbuf.st_size+1);
	if (buffer == NULL) {
		printf("Malloc failed for bootstrap file: %s\n", name);
		buffer = NULL;
		goto error;
	}
	len = read(fd, buffer, sbuf.st_size);
	buffer[len] = 0;
	close(fd);
	if (len != sbuf.st_size) {
		printf("Short read on bootstrap file %s\n", name);
		free(buffer);
		buffer = NULL;
		len = 0;
		goto error;
	} else {
		if (vflag > 1) {
			printf("Bootstrapped: %s [%d bytes]\n",
			    name, sbuf.st_size);
		}
	}
error:
	if (cname != NULL)
		free(cname);
	PUSH(buffer, stack);
	PUSH(len, stack);
	return (stack);
}

/*
 * xref_symbol ( str,len  line# state -- str,len  )
 *   state:
 *	0	symbol_reference
 *	1	symbol_definition
 *	2	smybol_hide
 *	3	symbol_reveal
 *	4	string content
 */
FPROTO(xref_symbol)
{
	int state;
	int len;
	char *name;
	char *fnname = NULL;
	int line;
	state = POP(stack);

#ifdef SHOWREFS
#define	RPRINTF(x)	printf x
#else
#define	RPRINTF(x)
#endif

	if (xref_enabled) {
		switch (state) {
		case 0:
			line = POP(stack);
			pop_fstring(stack, &fnname, &len);
			RPRINTF(("ref: %s\n", fnname));
			xref_add_symbol_reference(fnname, line);
			break;

		case 1:
			line = POP(stack);
			pop_fstring(stack, &fnname, &len);
			RPRINTF(("define: %s\n", fnname));
			xref_add_symbol_definition(fnname, line);
			break;

		case 2:
			pop_fstring(stack, &fnname, &len);
			RPRINTF(("hide: %s\n", fnname));
			xref_modify_symbol_definition(fnname, 0);
			break;

		case 3:
			pop_fstring(stack, &fnname, &len);
			RPRINTF(("reveal: %s\n", fnname));
			xref_modify_symbol_definition(fnname, 1);
			break;

		case 4:
			line = POP(stack);
			pop_fstring(stack, &fnname, &len);
			RPRINTF(("string: %s\n", fnname));
			xref_add_string(fnname, len, line);
			break;

		default:
			printf("%s:%d: xref_symbol invalid state %d\n",
			    __FILE__, __LINE__, state);
			break;
		}
		if (fnname != NULL)
			free(fnname);
	}
	return (stack);
}

/* xref-file ( [name,len,-1 -- name,len] | [ 0 -- ] ) */
FPROTO(xref_file)
{
	int state;
	int len;
	char *name;
	char *fname = NULL;

	state = POP(stack);
	if (state) {
		/*
		 * We dont actually pop the stack though..
		 */
		pop_fstring(stack, &fname, &len);
#if 0
		printf("Pushing.. %s\n", fname);
#endif
	}

	if ((xref_enabled) || 1) {
		if (state) {
			xref_add_file_reference(fname);
		} else {
			xref_remove_file_reference();
		}
	}
	if (fname != NULL)
		free(fname);
	return (stack);
}

/* xref_trigger ( state -- ) */
FPROTO(xref_trigger)
{
	int what;
	char *symbol;
	char *preload;
	extern int xref_enable_forward_refs;

	what = POP(stack);
	switch (what) {
	case 0:
		/*
		 * Xref Off
		 * Flush the xref-file to disk.
		 */
		if (xref_enabled)
			xref_generate(1);
		xref_enabled = 0;
		break;

	case 1:
		/*
		 * Xref On
		 */
		symbol = "XREF-FILE";
		if (symbol_defined(symbol)) {
			xref_enabled = 1;
		}
		break;

	case -1:
		/*
		 * Init; extract the xref variables from the symbol table.
		 */
		symbol = "XREF-FILE";
		if (symbol_defined(symbol)) {
			char *symdata = extract_symbol(symbol);
			char *preload = extract_symbol("XREF-PRELOAD");
			xref_init(symdata, preload, xref_enable_forward_refs);
			PUSH(-1, stack);
		} else {
			PUSH(0, stack);
		}
		break;

	default:
		printf("%s:%d Unexpected Xref trigger\n", __FILE__, __LINE__);
		break;
	}
	return (stack);
}

/* xref_stat ( -- ) */
FPROTO(xref_stat)
{
	printf("Xref enabled?: %d\n", xref_enabled);
	xref_status();
	return (stack);
}

/* symbol-set ( data,dlen symbol,len create? -- ) */
FPROTO(symbol_set)
{
	int create;
	int slen;
	char *sname;
	int dlen;
	char *data;
	char *symbol;

	create = POP(stack);
	stack = pop_fstring(stack, &symbol, &slen);
	if (create) {
		stack = pop_fstring(stack, &data, &dlen);
		if (dlen) {
			char cstr[256];

			snprintf(cstr, sizeof (cstr), "%s=%s", symbol, data);
			free(data);
			free(symbol);
			symbol = strdup(cstr);
		}
		define_symbol(symbol, FORTH_DEFINE);
	} else {
		undef_symbol(symbol, FORTH_UNDEF);
	}
	free(symbol);
	return (stack);
}

/* symbol-exists( symbol,len -- exists? ) */
FPROTO(symbol_exists)
{
	int slen;
	char *symname;
	char *symbol;
	int defined;
	int invert = 0;

	stack = pop_fstring(stack, &symbol, &slen);
	symname = symbol;
	if (symname[0] == '!') {
		symname++;
		invert = 1;
	}
	defined = symbol_defined(symname);
	if (invert) {
		defined = !defined;
	}
	free(symbol);
	PUSH(defined, stack);
	return (stack);
}

/* symbol-value( symbol,len -- value,len ) */
FPROTO(symbol_value)
{
	int slen;
	int invert = 0;
	char *symname;
	char *symbol;
	char *value;
	char *symdata;

	stack = pop_fstring(stack, &symname, &slen);
	symbol = symname;
	if (symname[0] == '!') {
		symbol++;
		invert = 1;
	}
	if (symbol_defined(symbol)) {
		symdata = extract_symbol(symbol);
		if (symdata == NULL) {
			symdata = (char *)&slen;
			slen = 0;
		} else {
			slen = strlen(symdata);
		}
		if (invert) {
			symdata = NULL;
			slen = 0;
		}
	} else {
		symdata = NULL;
		if (invert) {
			symdata = (char *)&slen;
		}
		slen = 0;
	}
	free(symname);
	PUSH(symdata, stack);
	PUSH(slen, stack);
	return (stack);
}

FPROTO(stack_syscall)
{
	long tos;
	int i;

	tos = POP(stack);
	printf("Tos: %x\n", tos);
	PUSH(1, stack);
	PUSH(2, stack);

	return (stack);
}

FPROTO(compile_info)
{
	extern int compile_msgs;
	compile_msgs++;
	return (stack);
}

FPROTO(compile_abort)
{
	extern int compile_errors;
	compile_errors++;
	return (stack);
}

FPROTO(compile_warn)
{
	extern int compile_warnings;
	compile_warnings++;
	return (stack);
}

/*
 * Now the function table.
 */
fstackp ((*sfunctions[])(fstackp)) = {
	/* 0		1					*/
	c_key,		c_emit,

	/* 2		3		4		5	*/
	f_open,		f_creat,	f_close, 	f_read,

	/* 6		7		8			*/
	f_write,	f_ioctl,	c_keyques,

	/* 9		10		11		12	*/
	f_bye,		f_lseek,	f_unlink,	fileques,

	/* 13		14		15			*/
	c_type,		c_expect,	syserror,

	/* 16		17		18			*/
	today,		timez,		timezstr,

	/* 19		20					*/
#if 0
	fork,		execve,
#else
	0L,		0L,
#endif
	/* 21							*/
	c_getenv,

	/* 22		23					*/
	s_system,	s_signal,

	/* 24		25					*/
	s_chdir,	s_getwd,

	/* 26		27		28			*/
	m_alloc,	c_cr,		f_crstr,

	/* 29		30		31			*/
	s_flushcache,	pr_error,	0,

	/* 32							*/
	m_free,

	/* 33		34		35		36	37 */
	f_init,		f_op,		f_move,		f_rows,	f_cols,

	/* 38							*/
	pathname,

#ifdef PPCSIM
	/* 39		40		41		42	*/
	printnum,	mmap,		open,		close,
#else
	/* 39							*/
	m_sbrk,

	/* 40		41		42		43	*/
	f_dlopen,	f_dlsym,	f_dlerror,	f_dlclose,

	/* 44							*/
#ifdef SIMFORTH
	find_next,
#else
	0,
#endif
	/* 45,		, 46		, 47		, 48	*/
	save_image,	bootstrap,	 includefile,	0,

	/* 49,		50		51		, 52	*/
	xref_symbol,	xref_file,	xref_trigger, 	xref_stat,

	/* 53,		54,		55,			*/
	symbol_set,	symbol_exists,	symbol_value,

	/* 56							*/
	stack_syscall,

	/* 57		58,		59,		60	*/
	compile_info,	compile_abort,	compile_warn,	0,
#endif
	/* EOT 							*/
	0
};