/* nf.c -- this program can be run to generate a new environment for the
 * FORTH interpreter forth.c. It takes the dictionary from the standard input.
 * Normally, this dictionary is in the file "forth.dict", so 
 *	nf < forth.dict
 * will do the trick.
 */

#include <stdio.h>
#include <ctype.h>
#include "common.h"
#include "forth.lex.h"		/* #defines for lexical analysis */

#define isoctal(c)	(c >= '0' && c <= '7')	/* augument ctype.h */

#define assert(c,s)	(!(c) ? failassert(s) : 1)
#define chklit()	(!prev_lit ? dictwarn("Qustionable literal") : 1)

#define LINK struct linkrec
#define CHAIN struct chainrec

struct chainrec {
    char chaintext[32];
    int defloc;				/* CFA or label loc */
    int chaintype;			/* 0=undef'd, 1=absolute, 2=relative */
    CHAIN *nextchain;
    LINK *firstlink;
};

struct linkrec {
    int loc;
    LINK *nextlink;
};

CHAIN firstchain;

#define newchain()	(CHAIN *)(calloc(1,sizeof(CHAIN)))
#define newlink()	(LINK *)(calloc(1,sizeof(LINK)))

CHAIN *find();
CHAIN *lastchain();
LINK *lastlink();

char *strcat();
char *calloc();

int dp = DPBASE;
int latest;

short mem[INITMEM];

FILE *outf, *fopen();

main(argc, argv)
int argc;
char *argv[];
{
#ifdef DEBUG
	puts("Opening output file");
#endif DEBUG

    strcpy(firstchain.chaintext," ** HEADER **");
    firstchain.nextchain = NULL;
    firstchain.firstlink = NULL;

#ifdef DEBUG
    puts("call builddict");
#endif DEBUG
    builddict();
#ifdef DEBUG
    puts("Make FORTH and COLDIP");
#endif DEBUG
    mkrest();
#ifdef DEBUG
    puts("Call Buildcore");
#endif DEBUG
    buildcore();
#ifdef DEBUG
    puts("call checkdict");
#endif DEBUG
    checkdict();
#ifdef DEBUG
    puts("call writedict");
#endif DEBUG
    writedict();

    printf("%s: done.\n", argv[0]);
    exit(0);
}

buildcore()			/* set up low core */
{
	mem[USER_DEFAULTS+0] = INITS0;			/* initial S0 */
	mem[USER_DEFAULTS+1] = INITR0;			/* initial R0 */
	mem[USER_DEFAULTS+2] = TIB_START;		/* initial TIB */
	mem[USER_DEFAULTS+3] = MAXWIDTH;		/* initial WIDTH */
	mem[USER_DEFAULTS+4] = 0;			/* initial WARNING */
	mem[USER_DEFAULTS+5] = dp;			/* initial FENCE */
	mem[USER_DEFAULTS+6] = dp;			/* initial DP */
	mem[USER_DEFAULTS+7] = instance("FORTH") + 3;	/* initial CONTEXT */

	mem[SAVEDIP] = 0;				/* not a saved FORTH */
}

builddict()			/* read the dictionary */
{
    int prev_lit = 0, lit_flag = 0;
    int temp;
    char s[256];
    TOKEN *token;

    while ((token = yylex()) != NULL) {	/* EOF returned as a null pointer */
#ifdef DEBUG
	printf("\ntoken: %s: %d ",token->text, token->type);
#endif DEBUG
	switch (token->type) {

	case PRIM:
#ifdef DEBUG
	    printf("primitive ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get the next word */
		dicterr("No word following PRIM");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if ((token == yylex()) == NULL)	/* get the value */
		dicterr("No value following PRIM <word>");
	    mkword(s,mkval(token));
	    break;

	case CONST:
#ifdef DEBUG
	    printf("constant ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get the word */
		dicterr("No word following CONST");
	    strcpy (s,token->text);		/* s holds word */
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if (!find("DOCON"))
		dicterr ("Constant definition before DOCON: %s",s);
				/* put the CF of DOCON into this word's CF */
	    mkword(s,(int)mem[instance("DOCON")]);
	    if ((token = yylex()) == NULL)	/* get the value */
		dicterr("No value following CONST <word>");
	    temp = mkval(token);

	    /* two special-case constants */
	    if (strcmp(s,"FIRST") == 0) temp = INITR0;
	    else if (strcmp(s,"LIMIT") == 0) temp = DPBASE;

	    comma(temp);
	    break;

	case VAR:
#ifdef DEBUG
	    printf("variable ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get the variable name */
		dicterr("No word following VAR");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if (!find("DOVAR"))
		dicterr("Variable declaration before DOVAR: %s",s);
	    mkword (s, (int)mem[instance("DOVAR")]);
	    if ((token = yylex()) == NULL)	/* get the value */
		dicterr("No value following VAR <word>");
	    comma(mkval(token));
	    break;

	case USER:
#ifdef DEBUG
	    printf("uservar ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get uservar name */
		dicterr("No name following USER");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s. ",s);
#endif DEBUG
	    if (!find("DOUSE"))
		dicterr("User variable declared before DOUSE: %s",s);
	    mkword (s, (int)mem[instance("DOUSE")]);
	    if ((token = yylex()) == NULL)	/* get the value */
		dicterr("No value following USER <word>");
	    comma(mkval(token));
	    break;

	case COLON:
#ifdef DEBUG
	    printf("colon def'n ");
#endif DEBUG
	    if ((token = yylex()) == NULL)	/* get name of word */
		dicterr("No word following : in definition");
	    strcpy (s,token->text);
#ifdef DEBUG
	    printf(".%s.\n",s);
#endif DEBUG
	    if (!find("DOCOL"))
		dicterr("Colon definition appears before DOCOL: %s",s);

	    if (token->type == NUL) {	/* special zero-named word */
		int here = dp;		/* new latest */
#ifdef DEBUG
		printf("NULL WORD AT 0x%04x\n");
#endif DEBUG
		comma(0xC1);
		comma(0x80);
		comma(latest);
		latest = here;
		comma((int)mem[instance("DOCOL")]);
	    }
	    else {
		mkword (s, (int)mem[instance("DOCOL")]);
	    }
	    break;

	case SEMICOLON:
#ifdef DEBUG
	    puts("end colon def'n");
#endif DEBUG
	    comma (instance(";S"));
	    break;

	case SEMISTAR:
#ifdef DEBUG
	    printf("end colon w/IMMEDIATE ");
#endif DEBUG
	    comma (instance (";S"));	/* compile cfA of ;S, not CF */
	    mem[latest] |= IMMEDIATE;	/* make the word immediate */
	    break;

	case STRING_LIT:
#ifdef DEBUG
	    printf("string literal ");
#endif DEBUG
	    strcpy(s,token->text);
	    mkstr(s);		/* mkstr compacts the string in place */
#ifdef DEBUG
	    printf("string=(%d) \"%s\" ",strlen(s),s);
#endif DEBUG
	    comma(strlen(s));
	    {
		char *stemp;
		stemp = s;
		while (*stemp) comma(*stemp++);
	    }
	    break;
	
	case COMMENT:
#ifdef DEBUG
	    printf("comment ");
#endif DEBUG
	    skipcomment();
	    break;

	case LABEL:
#ifdef DEBUG
	    printf("label: ");
#endif DEBUG
	    if ((token = yylex()) == NULL)
		dicterr("No name following LABEL");
#ifdef DEBUG
	    printf(".%s. ", token->text);
#endif DEBUG
	    define(token->text,2);	/* place in sym. table w/o compiling
					   anything into dictionary; 2 means
					   defining a label */
	    break;

	case LIT:
		lit_flag = 1;		/* and fall through to the rest */

	default:
	    if (find(token->text) != NULL) {	/* is word defined? */
#ifdef DEBUG
		printf("  normal: %s\n",token->text);
#endif DEBUG
	    	comma (instance (token->text));
		break;
	    }

	    /* else */
	    /* the literal types all call chklit(). This macro checks to
	       if the previous word was "LIT"; if not, it warns */
	    switch(token->type) {
	    case DECIMAL: chklit(); comma(mkdecimal(token->text)); break;
	    case HEX: chklit(); comma(mkhex(token->text)); break;
	    case OCTAL: chklit(); comma(mkoctal(token->text)); break;
	    case C_BS: chklit(); comma('\b'); break;
	    case C_FF: chklit(); comma('\f'); break;
	    case C_NL: chklit(); comma('\n'); break;
	    case C_CR: chklit(); comma('\r'); break;
	    case C_TAB: chklit(); comma('\t'); break;
	    case C_BSLASH: chklit(); comma(0x5c); break;  /* ASCII backslash */
	    case C_LIT: chklit(); comma(*((token->text)+1)); break;

	    default:
#ifdef DEBUG
		printf("forward reference");
#endif DEBUG
		comma (instance (token->text));		/* create an instance,
						to be resolved at definition */
	    }
	}
#ifdef DEBUG
	if (lit_flag) puts("expect a literal");
#endif DEBUG
	prev_lit = lit_flag;	/* to be used by chklit() next time */
	lit_flag = 0;
    }
}

comma(i)			/* put at mem[dp]; increment dp */
{
    mem[dp++] = (unsigned short)i;
    if (dp > INITMEM) dicterr("DICTIONARY OVERFLOW");
}

/*
 * make a word in the dictionary.  the new word will have name *s, its CF
 * will contain v. Also, resolve any previously-unresolved references by
 * calling define()
 */

mkword(s, v)
char *s;
short v;
{
	int here, count = 0;
	char *olds;
	olds = s;		/* preserve this for resolving references */

#ifdef DEBUG
	printf("%s ",s);
#endif DEBUG

	here = dp;		/* hold this value to place length byte */

	while (*s) {		/* for each character */
		mem[++dp] = (unsigned short)*s;
		count++; s++;
	}

	if (count >= MAXWIDTH) dicterr("Input word name too long");

				/* set MSB on */
	mem[here] = (short)(count | 0x80);

	mem[dp++] |= 0x80;	/* set hi bit of last char in name */
	
	mem[dp++] = (short)latest;	/* the link field */

	latest = here;		/* update the link */

	mem[dp] = v;		/* code field; leave dp = CFA */

	define(olds,1);		/* place in symbol table. 1 == "not a label" */
	dp++;			/* now leave dp holding PFA */

	/* that's all. Now dp points (once again) to the first UNallocated
           spot in mem, and everybody's happy. */
}

mkrest()			/* Write out the word FORTH as a no-op with
				   DOCOL as CF, ;S as PF, followed by
				   0xA081, and latest in its PF.
				   Also, Put the CFA of ABORT at 
				   mem[COLDIP] */
{
	mem[COLDIP] = dp;	/* the cold-start IP is here, and the word
				   which will be executed is COLD */
	if ((mem[dp++] = instance("COLD")) == 0)
		dicterr("COLD must be defined to take control at startup");

	mem[ABORTIP] = dp;	/* the abort-start IP is here, and the word
				   which will be executed is ABORT */
	if ((mem[dp++] = instance("ABORT")) == 0)
		dicterr("ABORT must be defined to take control at interrupt");

	mkword("FORTH",mem[instance("DOCOL")]);
	comma(instance(";S"));
	comma(0xA081);	/* magic number for vocabularies */
	comma(latest);		/* NFA of last word in dictionary: FORTH */

	mem[LIMIT] = dp + 1024;
	if (mem[LIMIT] >= INITMEM) mem[LIMIT] = INITMEM-1;
}

writedict()			/* write memory to COREFILE and map 
			   	   to MAPFILE */
{
    FILE   *outfile;
    int     i, temp, tempb, firstzero, nonzero;
    char    chars[9], outline[80], tstr[6];

    if ((outfile = fopen(MAPFILE,"w")) == NULL) {
	printf ("nf: can't open %s for write.\n", MAPFILE);
	exit (1);
    }

    for (temp = 0; temp < dp; temp += 8) {
	nonzero = FALSE;
	sprintf (outline, "%04x:", temp);
	for (i = temp; i < temp + 8; i++) {
	    sprintf (tstr, " %04x", (unsigned short) mem[i]);
	    strcat (outline, tstr);
	    tempb = mem[i] & 0x7f;
	    if (tempb < 0x7f && tempb >= ' ')
		chars[i % 8] = tempb;
	    else
		chars[i % 8] = '.';
	    nonzero |= mem[i];
	}
	if (nonzero) {
	    fprintf (outfile, "%s %s\n", outline, chars);
	    firstzero = TRUE;
	}
	else
	    if (firstzero) {
		fprintf (outfile, "----- ZERO ----\n");
		firstzero = FALSE;
	    }
    }
    fclose (outfile);


    printf ("Writing %s; DPBASE=%d; dp=%d\n", COREFILE, DPBASE, dp);

    if ((outf = fopen (COREFILE, "w")) == NULL) {
	printf ("nf: can't open %s for write.\n", COREFILE);
	exit (1);
    }

    if (fwrite (mem, sizeof (*mem), mem[LIMIT], outf) != mem[LIMIT]) {
	fprintf (stderr, "Error writing to %s\n", COREFILE);
	exit (1);
    }

    if (fclose (outf) == EOF) {
	fprintf (stderr, "Error closing %s\n", COREFILE);
	exit (1);
    }
}

mkval(t)			/* convert t->text to integer based on type */
TOKEN *t;
{
	char *s = t->text;
	int sign = 1;

	if (*s == '-') {
		sign = -1;
		s++;
	}

	switch (t->type) {
	case DECIMAL:
		return (sign * mkdecimal(s));
	case HEX:
		return (sign * mkhex(s));
	case OCTAL:
		return (sign * mkoctal(s));
	default:
		dicterr("Bad value following PRIM, CONST, VAR, or USER");
		return (0);
	}
}

mkhex(s)
char *s;
{				/*  convert hex ascii to integer */
    int     temp;
    temp = 0;

    s += 2;			/* skip over '0x' */
    while (isxdigit (*s)) {	/* first non-hex char ends */
	temp <<= 4;		/* mul by 16 */
	if (isupper (*s))
	    temp += (*s - 'A') + 10;
	else
	    if (islower (*s))
		temp += (*s - 'a') + 10;
	    else
		temp += (*s - '0');
	s++;
    }
    return temp;
}

mkoctal(s)
char *s;
{				/*  convert Octal ascii to integer */
    int     temp;
    temp = 0;

    while (isoctal (*s)) {	/* first non-octal char ends */
	temp = temp * 8 + (*s - '0');
	s++;
    }
    return temp;
}

mkdecimal(s)			/* convert ascii to decimal */
char *s;
{
	return (atoi(s));	/* alias */
}

dicterr(s,p1)
char *s;
int p1;		/* might be char * -- printf uses it */
{
    fprintf(stderr,s,p1);
    fprintf(stderr,"\nLast word defined was ");
    printword(latest);
/*    fprintf(stderr, "; last word read was \"%s\"", token->text); */
    fprintf(stderr,"\n");
    exit(1);
}

dictwarn(s)		/* almost like dicterr, but don't exit */
char *s;
{
    fprintf(stderr,"\nWarning: %s\nLast word read was ",s);
    printword(latest);
    putc('\n',stderr);
}
    
printword(n)
int n;
{
    int count, tmp;
    count = mem[n] & 0x1f;
    for (n++;count;count--,n++) {
	tmp = mem[n] & ~0x80;		/* mask eighth bit off */
	if (tmp >= ' ' && tmp <= '~') putc(tmp, stderr);
    }
}

skipcomment()
{
    while(getchar() != ')');
}

mkstr(s)			/* modifies a string in place with escapes
				   compacted. Strips leading & trailing \" */
char *s;
{
    char *source;
    char *dest;

    source = dest = s;
    source++;			/* skip leading quote */
    while (*source != '"') {	/* string ends with unescaped \" */
	if (*source == '\\') {	/* literal next */
	    source++;
	}
	*dest++ = *source++;
    }
    *dest = '\0';
}

failassert(s)
char *s;
{
    puts(s);
    exit(1);
}

checkdict()			/* check for unresolved references */
{
    CHAIN *ch = &firstchain;

#ifdef DEBUG
    puts("\nCheck for unresolved references");
#endif DEBUG
    while (ch != NULL) {
#ifdef DEBUG
	printf("ch->chaintext = .%s. - ",ch->chaintext);
#endif DEBUG
	if ((ch->firstlink) != NULL) {
	    fprintf(stderr,"Unresolved forward reference: %s\n",ch->chaintext);
#ifdef DEBUG
	    puts("still outstanding");
#endif DEBUG
	}
#ifdef DEBUG
	else puts("clean.");
#endif DEBUG
	ch = ch->nextchain;
    }
}

    
/********* structure-handling functions find(s), define(s,t), instance(s) **/

CHAIN *find(s)		/* returns a pointer to the chain named s */
char *s;
{
	CHAIN *ch;
	ch = &firstchain;
	while (ch != NULL) {
		if (strcmp (s, ch->chaintext) == 0) return ch;
		else ch = ch->nextchain;
	}
	return NULL;	/* not found */
}

/* define must create a symbol table entry if none exists, with type t.
   if one does exist, it must have type 0 -- it is an error to redefine
   something at this stage. Change to type t, and fill in the outstanding
   instances, with the current dp if type=1, or relative if type=2. */

define(s,t)		/* define s at current dp */
char *s;
int t;
{
	CHAIN *ch;
	LINK *ln, *templn;

#ifdef DEBUG
	printf("define(%s,%d)\n",s,t);
#endif DEBUG

	if (t < 1 || t > 2)	/* range check */
		dicterr("Program error: type in define() not 1 or 2.");

	if ((ch = find(s)) != NULL) {		/* defined or instanced? */
		if (ch -> chaintype != 0)	/* already defined! */
			dicterr("Word already defined: %s",s);
		else {
#ifdef DEBUG
			printf("there are forward refs: ");
#endif DEBUG
			ch->chaintype = t;
			ch->defloc = dp;
		}
	}
	else {				/* must create a (blank) chain */
#ifdef DEBUG
		puts("no forward refs");
#endif DEBUG
		/* create a new chain, link it in, leave ch pointing to it */
		ch = ((lastchain() -> nextchain) = newchain());
		strcpy(ch->chaintext, s);
		ch->chaintype = t;
		ch->defloc = dp;	/* fill in for future references */
	}

	/* now ch points to the chain (possibly) containing forward refs */
	if ((ln = ch->firstlink) == NULL) return;	/* no links! */

	while (ln != NULL) {
#ifdef DEBUG
		printf("    Forward ref at 0x%x\n",ln->loc);
#endif DEBUG
		switch (ch->chaintype) {
		case 1: mem[ln->loc] = (short)dp;	/* absolute */
			break;
		case 2: mem[ln->loc] = (short)(dp - ln->loc);	/* relative */
			break;
		default: dicterr ("Bad type field in define()");
		}

		/* now skip to the next link & free this one */
		templn = ln;
		ln = ln->nextlink;
		free(templn);
	}
	ch->firstlink = NULL;	/* clean up that last pointer */
}

/*
   instance must return a value to be compiled into the dictionary at
   dp, consistent with the symbol s: if s is undefined, it returns 0,
   and adds this dp to the chain for s (creating that chain if necessary).
   If s IS defined, it returns <s> (absolute) or (s-dp) (relative), 
   where <s> was the dp when s was defined.
*/

instance(s)
char *s;
{
	CHAIN *ch;
	LINK *ln;

#ifdef DEBUG
	printf("instance(%s):\n",s);
#endif DEBUG

	if ((ch = find(s)) == NULL) {	/* not defined yet at all */
#ifdef DEBUG
		puts("entirely new -- create a new chain");
#endif DEBUG
		/* create a new chain, link it in, leave ch pointing to it */
		ch = ((lastchain() -> nextchain) = newchain());

		strcpy(ch->chaintext, s);
		ln = newlink();		/* make its link */
		ch->firstlink = ln;
		ln->loc = dp;		/* store this location there */
		return 0;		/* all done */
	}
	else {
		switch(ch->chaintype) {
		case 0:			/* not defined yet */
#ifdef DEBUG
			puts("still undefined -- add a link");
#endif DEBUG
			/* create a new link, point the last link to it, and
			   fill in the loc field with the current dp */
			(lastlink(ch)->nextlink = newlink()) -> loc = dp;
			return 0;
		case 1:			/* absolute */
#ifdef DEBUG
			puts("defined absolute.");
#endif DEBUG
			return ch->defloc;
		case 2:			/* relative */
#ifdef DEBUG
			puts("defined relative.");
#endif DEBUG
			return ch->defloc - dp;
		default:
			dicterr("Program error: bad type for chain");
			return (0);
		}
	}
}

CHAIN *lastchain()	/* starting from firstchain, find the last chain */
{
	CHAIN *ch = &firstchain;
	while (ch->nextchain != NULL) ch = ch->nextchain;
	return ch;
}

LINK *lastlink(ch)	/* return the last link in the chain */
CHAIN *ch;		/* CHAIN MUST HAVE AT LEAST ONE LINK */
{
	LINK *ln = ch->firstlink;

	while (ln->nextlink != NULL) ln = ln->nextlink;
	return ln;
}

yywrap()	/* called by yylex(). returning 1 means "all finished" */
{
    return 1;
}