Category : UNIX Files
Archive : CFORTH.ZIP
Filename : NF.C
Output of file : NF.C contained in archive : CFORTH.ZIP
* 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
#include
#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]);
}
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
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
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
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
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] */
{
int temp;
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];
outfile = fopen(MAPFILE,"w");
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 output.\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");
}
}
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
where
*/
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");
}
}
}
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;
}
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/