HOC 6 program from K & P
lef at nlm-vax.UUCP
lef at nlm-vax.UUCP
Wed Jun 20 23:49:47 AEST 1984
<>
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'
More information about the Comp.sources.unix
mailing list