[net.sources] HOC 6 program from K&P

lef@nlm-vax.UUCP (06/20/84)

<>

Sorry about  the delay on this posting. I have been awaiting
permission from Prentice-Hall to reproduce this. Please
note the accompanying credit line.

This is the HOC 6 program from:

Brian Kernighan & Rob Pike, The Unix Programming Environment,
Copyright 1984.
Pages 335-347
Reproduced by permission of Prentice-Hall, Englewood Cliffs, NJ.


Extract the following text using the csh.
****************************************************************
# to unbundle, csh this file
echo 'x -' code.c
cat >code.c <<'End of code.c'
#include "hoc.h"
#include "y.tab.h"
#include <stdio.h>
#define NSTACK 256
static Datum  stack[NSTACK];  /* the stack */
static Datum  *stackp;        /* next free spot on stack */

#define NPROG  2000
Inst    prog[NPROG];    /* the machine */
Inst    *progp;          /* next free spot for code generation */
Inst    *pc;            /* program counter during execution */
Inst    *progbase = prog; /* start of current subprogram */
int     returning;      /* 1 if return stmt seen */

typedef struct Frame {  /* proc/func call stack frame */
	Symbol  *sp;    /* symbol table entry */
	Inst    *retpc; /* where to resume after return */
	Datum   *argn;  /* n-th argument on stack */
	int     nargs;  /* number of arguments */
} Frame;
#define NFRAME 100
Frame   frame[NFRAME];
Frame   *fp;            /* frame pointer */

initcode() { 
	progp= progbase;
        stackp = stack;
	fp = frame;
	returning = 0;
}

push(d)
        Datum d;
{
        if (stackp >= &stack[NSTACK])
                execerror("stack overflow", (char *) 0);
        *stackp++ = d;
}

Datum pop()
{
        if (stackp == stack)
                execerror("stack underflow", (char *) 0);
        return *--stackp;
}

constpush()
{
        Datum d;
        d.val = ((Symbol *)*pc++)->u.val;
        push(d);
}

varpush()
{
        Datum d;
        d.sym = (Symbol *)(*pc++);
        push(d);
}

eval()        /* evaluate variable on stack */
{
        Datum d;
        d = pop();
        if (d.sym->type != VAR && d.sym->type != UNDEF)
             execerror("attempt to evaluate non-variable", d.sym->name);
	if (d.sym->type == UNDEF)
		execerror("undefined variable", d.sym->name);
        d.val = d.sym->u.val;
        push(d);
}
add()
{
        Datum d1, d2;
        d2 = pop();
        d1 = pop();
        d1.val += d2.val;
        push(d1);
}
sub()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val -= d2.val;
	push(d1);
}

mul()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val *= d2.val;
	push(d1);
}

div()
{
	Datum d1, d2;
	d2 = pop();
	if (d2.val == 0.0) 
		execerror("division by zero", (char *)0);
        d1 = pop();
	d1.val /= d2.val;
	push(d1);
}

negate()
{
	Datum d;
	d = pop();
	d.val = -d.val;
	push(d);
}

gt()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val > d2.val);
	push(d1);
}

lt()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val < d2.val);
	push(d1);
}

ge()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val >= d2.val);
	push(d1);
}

eq()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val == d2.val);
	push(d1);
}

ne()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val != d2.val);
	push(d1);
}

and()
{ 
        Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val != 0.0 && d2.val != 0.0);
	push(d1);
}

or()
{
        Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val != 0.0 || d2.val != 0.0);
	push(d1);
}
	
not()
{
	Datum d;
	d = pop();
	d.val = (double)(d.val == 0.0);
	push(d);
}

power()
{
        Datum d1, d2;
	extern double Pow();
	d2 = pop();
	d1 = pop();
	d1.val = Pow(d1.val, d2.val);
	push(d1);
}

assign()      /* assign top value to next value */
{
        Datum d1, d2;
        d1 = pop();
        d2 = pop();
        if (d1.sym->type != VAR && d1.sym->type != UNDEF)
             execerror("assignment to non-variable",
             d1.sym->name);
        d1.sym->u.val = d2.val;
        d1.sym->type = VAR;
        push(d2);
}
print()       /* pop top value from stack, print it */
{
        Datum d;
        d = pop();
        printf("\t%.8g\n", d.val);
	
}
le()
{
	Datum d1, d2;
	d2 = pop();
	d1 = pop();
	d1.val = (double)(d1.val <= d2.val);
	push(d1);
}

whilecode()
{
	Datum d;
	Inst *savepc = pc;    
        
	execute(savepc+2);     /* condition */
	d = pop();
	while (d.val) {
		execute(*((Inst **)(savepc)));  /* body */
		if (returning)
			break;
                execute(savepc+2);      /* condition */ 
		d = pop();
	}
	if (!returning)
        	pc = *((Inst **)(savepc+1));  /* next statement */
}

ifcode()
{
	Datum d;
	Inst *savepc= pc;     /* then part */

	execute(savepc+3);    /* condition */
	d = pop();
	if (d.val)
		execute(*((Inst **)(savepc)));
        else if (*((Inst **)(savepc+1))) /* else part? */
		execute(*((Inst **)(savepc+1)));
        if (!returning)
        	pc = *((Inst **)(savepc+2));     /* next stmt */
}

define(sp)      /* put func/proc in symbol table */
	Symbol *sp;
{
	sp->u.defn = (Inst)progbase;    /* start of code */
	progbase = progp;       /* next code starts here */
}

call()           /* call a function */
{
	 Symbol *sp = (Symbol *)pc[0]; /* symbol table entry */
				       /* for function */
         if (fp++ >= &frame[NFRAME-1])
		 execerror(sp->name, "call nested too deeply");
         fp->sp = sp;
	 fp->nargs = (int)pc[1];
	 fp->retpc = pc + 2;
	 fp->argn = stackp - 1;  /* last argument */
	 execute(sp->u.defn);
	 returning = 0;
}

ret()            /* common return from func or proc */
{
	 int i;
	 for (i = 0; i < fp->nargs; i++)
		 pop();  /* pop arguments */
         pc = (Inst *)fp->retpc;
	 --fp;
	 returning = 1;
}

funcret()        /* return from a function */
{
	 Datum d;
	 if (fp->sp->type == PROCEDURE)
		 execerror(fp->sp->name, "(proc) returns value");
         d = pop();      /* preserve function return value */
	 ret();
	 push(d);
}

procret()        /* return from a procedure */
{
	if (fp->sp->type == FUNCTION)
		execerror(fp->sp->name,
			"(func) returns no value");
        ret();
}

double *getarg()         /* return pointer to argument */
{
	int nargs = (int) *pc++;
	if (nargs > fp->nargs)
	    execerror(fp->sp->name, "not enough arguments");
        return &fp->argn[nargs - fp->nargs].val;
}

arg()   /* push argument onto stack */
{
        Datum d;
	d.val = *getarg();
	push(d);
}

argassign()      /* store top of stack in argument */
{
	Datum d;
	d = pop();
	push(d);         /* leave value on stack */
	*getarg() = d.val;
}

bltin()
{
	Datum d;
	d = pop();
	d.val = (*(double (*)())*pc++)(d.val);
	push(d);
}

prexpr()           /* print numeric value */
{
	Datum d;
	d = pop();
	printf("%.8g ", d.val);
}

prstr()            /* print string value */
{
	printf("%s", (char *) *pc++);
}

varread()         /* read into variable */
{
	Datum d;
	extern FILE *fin;
	Symbol *var = (Symbol *) *pc++;
  Again:
	switch (fscanf(fin, "%lf", &var->u.val)) {
	case EOF:
		if (moreinput ())
			goto Again;
                d.val = var->u.val = 0.0;
		break;
        case 0:
		execerror("non-number read into", var->name);
		break;
        default:
		d.val = 1.0;
		break;
        }
	var->type = VAR;
	push(d);
}
Inst *code(f)  /* install one instruction or operand */
        Inst f;
{
        Inst *oprogp = progp;
        if (progp >= &prog[NPROG])
               execerror("program too big", (char *) 0);
        *progp++ = f;
        return oprogp;
}

execute(p)    /* run the machine */
          Inst *p;
{
          for (pc = p; *pc != STOP && !returning; )
                  (*(*pc++))();
}
'End of code.c'
echo 'x -' hoc.h
cat >hoc.h <<'End of hoc.h'
typedef struct Symbol { /* symbol table entry */
	char    *name;
	short   type;
	union {
	       double   val;            /* VAR */
	       double   (*ptr)();       /* BLTIN */
	       int      (*defn)();      /* FUNCTION, PROCEDURE */
	       char     *str;           /* STRING */
        } u;
	struct Symbol   *next;   /* to link to another */  
} Symbol;
Symbol  *install(), *lookup();

typedef union Datum {  /* interpreter stack type */
        double val;
        Symbol *sym;
} Datum;
extern Datum pop();
extern  eval(), add(), sub(), mul(), div(), negate(), power();

typedef int (*Inst)();  /* machine instruction */
#define STOP     (Inst) 0

extern  Inst *progp, *progbase, prog[], *code();
extern  assign(), bltin(), varpush(), constpush(), print(), varread();
extern	prexpr(), prstr();
extern	gt(), lt(), eq(), ge(), le(), ne(), and(), or(), not();
extern	ifcode(), whilecode(), call(), arg(), argassign();
extern	funcret(), procret();
'End of hoc.h'
echo 'x -' hoc.y
cat >hoc.y <<'End of hoc.y'
%{
#include "hoc.h"
#define code2(c1,c2)    code(c1); code(c2)
#define code3(c1,c2,c3) code(c1); code(c2)
%}
%union {
	Symbol  *sym;  /* symbol table pointer */
	Inst    *inst; /* machine instruction */
	int     narg;  /* number of arguments */
}
%token  <sym>   NUMBER STRING PRINT VAR BLTIN UNDEF WHILE IF ELSE
%token  <sym>   FUNCTION PROCEDURE RETURN FUNC PROC READ
%token  <narg>  ARG 
%type   <inst>  expr stmt asgn prlist stmtlist
%type   <inst>  cond while if begin end
%type   <sym>   procname 
%type   <narg>  arglist
%right	'='
%left	OR
%left	AND
%left	GT GE LT LE EQ NE
%left	'+' '-'
%left	'*' '/'
%left	UNARYMINUS NOT
%right	'^'
%%
list:     /* nothing */
	| list '\n'
	| list defn '\n'
	| list asgn '\n'  { code2(pop, STOP); return 1; }
	| list stmt '\n'  { code(STOP); return 1; }
	| list expr '\n'  { code2(print, STOP); return 1; }
	| list error '\n' { yyerrok; }
	;
asgn:     VAR '=' expr  { code3(varpush,(Inst)$1,assign); $$=$3; }
        | ARG '=' expr
	    { defnonly("$"); code2(argassign,(Inst)$1); $$=$3;}
	;
stmt:     expr  { code(pop); }
        | RETURN { defnonly("return"); code(procret); }
	| RETURN expr 
		{ defnonly("return"); $$=$2; code(funcret); }
        | PROCEDURE begin '(' arglist ')'
		{ $$ = $2; code3(call, (Inst)$1, (Inst)$4); }
        | PRINT prlist  { $$ = $2; }
	| while cond stmt end {
		($1) [1] = (Inst)$3;    /* body of loop */
		($1) [2] = (Inst)$4; }  /* end, if cond fails */
        | if cond stmt end {     /* else-less if */
		($1) [1] = (Inst)$3;    /* thenpart */
		($1) [3] = (Inst)$4; }  /* end, if cond fails */
        | if cond stmt end ELSE stmt end {      /* if with else */
		($1) [1] = (Inst)$3;    /* thenpart */
		($1) [2] = (Inst)$6;    /* elsepart */
		($1) [3] = (Inst)$7; }  /* end, if cond fails */
        | '{' stmtlist '}'       { $$ = $2; }
	;
cond:     '(' expr ')'  { code(STOP); $$ = $2; }
        ;
while:    WHILE { $$ = code3(whilecode,STOP,STOP); }
	;
if:       IF    { $$ = code(ifcode); code3(STOP,STOP,STOP); }
        ;
begin:    /* nothing */         { $$ = progp; }
	;
end:      /* nothing */         { code(STOP); $$ = progp; }
	;
stmtlist: /* nothing */         { $$ = progp; }
	| stmtlist '\n'
	| stmtlist stmt
	;
expr:     NUMBER { $$ = code2(constpush, (Inst)$1); }
	| VAR    { $$ = code3(varpush, (Inst)$1, eval); }
	| ARG    { defnonly("$"); $$ = code2(arg, (Inst)$1); }
	| asgn 
	| FUNCTION begin '(' arglist ')'
		{ $$ = $2; code3(call,(Inst)$1,(Inst)$4); }
        | READ '(' VAR ')' { $$ = code2(varread, (Inst)$3); }
	| BLTIN '(' expr ')' { $$=$3; code2(bltin, (Inst)$1->u.ptr); }
	| '(' expr ')'  { $$ = $2; }
	| expr '+' expr { code(add); }
	| expr '-' expr { code(sub); }
	| expr '*' expr { code(mul); }
	| expr '/' expr { code(div); }
	| expr '^' expr { code(power); }
	| '-' expr   %prec UNARYMINUS  { $$=$2; code(negate); }
	| expr GT expr  { code(gt); }
	| expr GE expr  { code(ge); }
	| expr LT expr  { code(lt); }
	| expr LE expr  { code(le); }
	| expr EQ expr  { code(eq); }
	| expr NE expr  { code(ne); }
	| expr AND expr { code(and); }
	| expr OR expr  { code(or); } 
	| NOT expr      { $$ = $2; code(not); }
	;
prlist:   expr                  { code(prexpr); }
	| STRING                { $$ = code2(prstr, (Inst)$1); }
        | prlist ',' expr       { code(prexpr); }
	| prlist ',' STRING     { code2(prstr, (Inst)$3); }
	;
defn:     FUNC procname { $2->type=FUNCTION; indef=1; }
	    '(' ')' stmt { code(procret); define($2); indef=0; }
        | PROC procname { $2->type=PROCEDURE; indef=1; }
	    '(' ')' stmt { code(procret); define($2); indef=0; }
        ;
procname: VAR
	| FUNCTION
	| PROCEDURE
	;
arglist:  /* nothing */         { $$ = 0; }
	| expr                  { $$ = 1; }
	| arglist ',' expr      { $$ = $1 + 1; }
	;
%%
       /* end of grammar */
#include <stdio.h>
#include <ctype.h>
char    *progname;
int     lineno = 1;
#include <signal.h>
#include <setjmp.h>
jmp_buf begin;
int     indef;
char    *infile;                /* input file name */
FILE    *fin;                   /* input file pointer */
char    **gargv;                /* global argument list */
int     gargc;
int c;		/* global for use by warning */
yylex()                  /*hoc6 */
{

	while ((c=getchar()) == ' ' || c == '\t')
		;
	if (c == EOF)
		return 0;
        if (c == '.' || isdigit(c))  { /* number */
                double d;
                ungetc(c, fin);
                fscanf(fin, "%lf", &d);
                yylval.sym = install("", NUMBER, d);
                return NUMBER;
	}
        if (isalpha(c)) {
                Symbol *s;
                char sbuf[100], *p =sbuf;
                do {
			if (p >= sbuf + sizeof(sbuf) -1 ) {
				*p = '\0';
				execerror("name too long", sbuf);
			}
			*p++=c;
		} while ((c=getchar()) != EOF && isalnum(c));
		ungetc(c, fin);
		*p = '\0';
		if ((s=lookup(sbuf)) == 0)
         		s = install(sbuf, UNDEF, 0.0);
		yylval.sym = s;
		return s->type == UNDEF ? VAR : s->type;
	}
        if (c == '$') { /* argument? */
	        int n = 0;
	        while (isdigit(c=getc(fin)))
	                n = 10 * n + c - '0';
		ungetc(c, fin);
		if (n == 0)
	        	execerror("strange $...", (char *)0);
		yylval.narg = n;
		return ARG;
	}
	if (c == '"') { /* quoted string */
		char sbuf[100], *p, *emalloc();
		for (p = sbuf; (c=getc(fin)) != '"'; p++) {
			if (c == '\n' || c == EOF)
				execerror("missing quote", "");
                	if (p >= sbuf + sizeof(sbuf) - 1) {
				*p = '\0';
				execerror("string too long", sbuf);
                	}
			*p = backslash(c);
        	}
		*p = 0;
		yylval.sym = (Symbol *)emalloc(strlen(sbuf)+1);
		strcpy(yylval.sym, sbuf);
		return STRING;
	}
	switch(c) {
	case '>':	return follow('=', GE, GT);
	case '<':	return follow('=', LE, LT);
	case '=':	return follow('=', EQ, '=');
	case '!':	return follow('=', NE, NOT);
	case '|':	return follow('|', OR, '|');
	case '&':	return follow('&', AND, '&');
	case '\n':	lineno++; return '\n';
	default:	return c;
	}
}
backslash(c)	/* get next char with \'s interpreted */
	int c;
{
        char *index();  /* `strchr()' in some systems */
	static char transtab[] = "b\bf\fn\nr\rt\t";
	if (c != '\\')
		return c;
        c = getc(fin);
	if (islower(c) && index(transtab, c))
		return index(transtab, c)[1];
        return c;
}
follow(expect, ifyes, ifno)     /* look ahead for >=, etc. */
{
	int c = getc(fin);

	if (c == expect)
		return ifyes;
        ungetc(c, fin);
	return ifno;
}
defnonly(s)	/* warn if illegal definition */
       char *s;
{
       if (!indef)
	       execerror(s, "used outside definition");
}
yyerror(s)     /* report compile-time error */ 
	char *s;
{
	warning(s, (char *) 0);
}
execerror(s,t) /* recover from run-time error */
       char *s, *t;
{
       warning(s,t);
       fseek(fin, 0L, 2);
       longjmp(begin, 0);
}
fpecatch()    /* catch floating point exceptions */
{
       execerror("floating point exception", (char *) 0);
}
main(argc, argv)  /* hoc4 */
        char *argv[];
{
        int i, fpecatch();
 
        progname = argv[0];
	if (argc == 1) {
		static char *stdinonly[] = { "-" };

		gargv = stdinonly;
		gargc = 1;
	} else {
		gargv = argv + 1;
		gargc = argc - 1;
	}
        init();
	while (moreinput())
		run();
        return 0;
}
moreinput()
{
        if (gargc-- <= 0)
		return 0;
        if (fin && fin != stdin)
		fclose(fin);
        infile = *gargv++;
	lineno = 1;
	if (strcmp(infile, "-") == 0) {
		fin = stdin;
		infile = 0;
        } else if ((fin=fopen(infile, "r")) == NULL) {
		fprintf(stderr, "%s: can't open %s\n", progname, infile);
		return moreinput();
        }
	return 1;
}
run()   /* execute until EOF */
{
	setjmp(begin);
	signal(SIGFPE, fpecatch);
	for (initcode(); yyparse(); initcode())
		execute(progbase);
}
warning(s, t)
	char *s, *t;
{
	fprintf(stderr, "%s: %s", progname,s);
	if (t)
		fprintf(stderr, " %s", t);
	if (infile)
		fprintf(stderr, " in %s", infile);
	fprintf(stderr, " near line %d\n", lineno);
	while (c != '\n' && c != EOF)
		c = getc(fin);	/*flush input line*/
	if (c == '\n')
		lineno++;
}
'End of hoc.y'
echo 'x -' init.c
cat >init.c <<'End of init.c'
#include "hoc.h" 
#include "y.tab.h"
#include  <math.h>

extern double  Log(), Log10(), Exp(), Sqrt(), integer();
static struct  {       /* Constants */
        char   *name;
        double cval;
} consts[] = {
       "PI",    3.14159265358979323846,
       "E",     2.71828182845904523636,
       "GAMMA", 0.57721566490153286060,   /* Euler */
       "DEG",  57.29577951308232087860,    /* deg/radian */
       "PHI",   1.61803398874989484820,   /* golden ratio */
       0,       0
};
static struct  {        /* Built-ins */
        char     *name;
        double   (*func)();
} builtins[] = {
        "sin", sin,
        "cos", cos,
        "atan",atan,
        "log", Log,     /* checks argument */
        "log10", Log10, /* checks argument */
        "exp", Exp,     /* checks argument */
        "sqrt", Sqrt,   /* checks argument */
        "int", integer,
        "abs", fabs,
        0,     0
};
static struct {         /* Keywords */
	char    *name;
	int     kval;
} keywords[] = {
	"proc",		PROC,
	"func",		FUNC,
	"return",	RETURN,
	"if",           IF,
	"else",         ELSE,
	"while",        WHILE,
	"print",        PRINT,
	"read",		READ,
	0,              0,
};

init()  /* install constants and built-ins in table */
{
        int i;
        Symbol *s;
	for (i = 0; keywords[i].name; i++)
		install(keywords[i].name, keywords[i].kval, 0.0);
        for (i = 0; consts[i].name; i++)
                install(consts[i].name, VAR, consts[i].cval);
        for (i = 0; builtins[i].name; i++) {
                s = install(builtins[i].name, BLTIN, 0.0);
                s->u.ptr = builtins[i].func;
        }
}
'End of init.c'
echo 'x -' makefile
cat >makefile <<'End of makefile'

YFLAGS = -d
OBJS = hoc.o code.o init.o math.o symbol.o

hoc6:  $(OBJS)
	cc $(CFLAGS) $(OBJS) -lm -o hoc6

hoc.o code.o init.o symbol.o : hoc.h

code.o init.o symbol.o : x.tab.h

x.tab.h : y.tab.h
	-cmp -s x.tab.h y.tab.h || cp y.tab.h x.tab.h

pr : hoc.y hoc.h code.c init.c math.c symbol.c
	@pr $?
	@touch pr

clean:
	rm -f $(OBJS) [xy].tab.[ch]
'End of makefile'
echo 'x -' math.c
cat >math.c <<'End of math.c'
#include <math.h>
#include <errno.h>
extern   int     errno;
double  errcheck();

double Log(x)
        double x;
{
        return errcheck(log(x), "log");
}
double Log10(x)
        double x;
{
        return errcheck(log10(x), "log10");
}
double Exp(x)
        double x;
{
        return errcheck(exp(x), "exp");
}
double Sqrt(x)
        double x; 
{
        return errcheck(sqrt(x), "sqrt");
}
double Pow(x,y)
	double	x,y;
{
        return errcheck(pow(x,y), "exponentiation");
}
double integer(x)
	double	x;
{
        return  (double)(long)x;
}
double errcheck(d, s)
	double d;
	char *s;
{
	if (errno == EDOM) {
		errno = 0;
		execerror(s, "argument out of domain");
	} else if (errno == ERANGE) {
		errno = 0;
		execerror(s, "result out of range");
	}
        return  d;
}
'End of math.c'
echo 'x -' symbol.c
cat >symbol.c <<'End of symbol.c'
#include "hoc.h" 
#include "y.tab.h"

static Symbol *symlist = 0;  /* symbol table: linked list */
Symbol *lookup(s)       /* find s in symbol table */
        char *s;
{
       Symbol *sp;
       for (sp = symlist; sp != (Symbol *) 0; sp = sp->next)
               if (strcmp(sp->name, s) == 0)
                      return sp;
       return 0;      /* 0 ==> not found */
}
Symbol *install(s, t, d)  /* install s in symbol table */
        char *s;
        int t;
        double d;
{
        Symbol *sp;
        char *emalloc();

        sp = (Symbol *) emalloc(sizeof(Symbol));
        sp->name = emalloc(strlen(s)+1); /* +1 for '\0' */
        strcpy(sp->name, s);
        sp->type = t;
        sp->u.val = d;
        sp->next = symlist; /* put at front of list */
        symlist = sp;
        return sp;
}
char *emalloc(n)        /* check return from malloc */
        unsigned n;
{
        char *p, *malloc();

        p = malloc(n);
        if (p == 0)
                execerror("out of memory", (char *) 0);
        return p;
}
'End of symbol.c'

lef@nlm-vax.ARPA (06/20/84)

<>

I forgot to mention in the posting of HOC 6 to net.sources
that it hasn't been completely tested. It compiles correctly
and appears to run correctly, but I have not verified all
aspects of its execution.

Testing it should be a good exercise for learning how this
program is put together.