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.