UNIX — страница 114 из 115

hoc6

3.7.1 ack

func ack() {
 n = n+1
 if ($1 == 0) return ($2+1)
 if ($2 == 0) return (ack($1 - 1, 1))
 return (ack($1 - 1, ack($1, $2 - 1)))
}
n=0
ack(3,3)
print n, "calls\n"

3.7.2 ack1

func ack() {
 n = n+1
 if ($1 == 0) return ($2+1)
 if ($2 == 0) return (ack($1 - 1, 1))
 return (ack($1 - 1, ack($1, $2 - 1)))
}
n=0
while (read(x)) {
 read(y)
 print ack(x,y), "\n"
}
print n,"\n"

3.7.3 code.c

#include "hoc.h"
#include "y.tab.h"
#include 

#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 too deep", (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);
}

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 stmt */
}

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);
}

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);
}

le() {
 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() {
 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);
}

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)
 Inst *p;
{
 for (pc = p; *pc != STOP && !returning; )
  (*((++pc)[-1]))();
}

3.7.4 double

proc double() {
 if ($1 > 1) {
  double($1/2)
 }
 print($1)
}
double(1024)

3.7.5 fac

func fac() {
 if ($1 <= 0) return 1 else return $1 * fac($1-1)
}

3.7.6 fac1

func fac() if ($1 <= 0) return 1 else return $1 * fac($1-1)
fac(0)
fac(7)
fac(10)

3.7.7 fac2

func fac() {
 if ($1 <= 0) {
  return 1
 }
 return $1 * fac($1-1)
}
i=0
while(i<=20){
 print "factorial of ", i, "is ", fac(i), "\n"
 i=i+1
}

3.7.8 fib

proc fib() {
 a = 0
 b = 1
 while (b < $1) {
  print b
  c = b
  b = a+b
  a = c
 }
 print "\n"
}

3.7.9 fib2

{
 n=0
 a=0
 b=1
 while(b<10000000){
  n=n+1
  c=b
  b=a+b
  a=c
  print(b)
 }
 print(n)
}

3.7.10 fibsum

proc fib(){
 a=1
 b=1
 c=2
 d=3
 sum = a+b+c+d
 while(d<$1){
  e=d+c
  print(e)
  a=b
  b=c
  c=d
  d=e
  sum=sum+e
 }
 print(sum)
}
fib(1000)

3.7.11 fibtest

proc fib() {
 a = 0
 b = 1
 while (b < $1) {
  c = b
  b = a+b
  a = c
 }
}
i = 1
while (i < 1000) {
 fib(1000)
 i = i + 1
}

3.7.12 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)();
#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();

3.7.13 hoc.ms

.EQ
delim @@
.EN
.TL
Hoc - An Interactive Language For Floating Point Arithmetic
.AU
Brian Kernighan
Rob Pike
.AB
.I Hoc
is a simple programmable interpreter
for floating point expressions.
It has C-style control flow,
function definition and the usual
numerical built-in functions such as cosine and logarithm.
.AE
.NH
Expressions
.PP
.I Hoc
is an expression language,
much like C:
although there are several control-flow statements,
most statements such as assignments
are expressions whose value is disregarded.
For example, the assignment operator
= assigns the value of its right operand
to its left operand, and yields the value,
so multiple assignments work.
The expression grammar is:
.DS
.I
expr: number
 | variable
 | ( expr )
 | expr binop expr
 | unop expr
 | function ( arguments )
.R
.DE
Numbers are floating point.
The input format is
that recognized by @scanf@(3):
.ix [scanf]
digits, decimal point, digits,
.ix [hoc] manual
.ix assignment expression
.ix multiple assignment
@e@ or @E@, signed exponent.
At least one digit or a decimal point
must be present;
the other components are optional.
.PP
Variable names are formed from a letter
followed by a string of letters and numbers,
@binop@ refers to binary operators such
as addition or logical comparison;
@unop@ refers to the two negation operators,
'!' (logical negation, 'not')
and '\-' (arithmetic negation, sign change).
Table 1 lists the operators.
.TS
center, box;
с s
lfCW l.
\fBTable 1:\fP Operators, in decreasing order of precedence
.sp .5
^       exponentiation (\s-1FORTRAN\s0 **), right associative
! \-    (unary) logical and arithmetic negation
* /     multiplication, division
+ \-    addition, subtraction
>>=    relational operators: greater, greater or equal,
<<=    less, less or equal,
\&== != equal, not equal (all same precedence)
&&      logical AND (both operands always evaluated)
||      logical OR (both operands always evaluated)
\&=     assignment, right associative
.ТЕ
.ix table~of [hoc] operators
.PP
Functions, as described later, may be defined by the user.
Function arguments are expressions separated by commas.
There are also a number of built-in functions,
all of which take a single argument,
described in Table 2.
.TS
center, box;
с s
lfCW l.
\fBTable 2:\fP Built-in Functions
.sp .5
abs(x)   @| x |@, absolute value of @x@
atan(x)  arc tangent of @x@
cos(x)   @cos (x)@, cosine of @x@
exp(x)   @e sup x@, exponential of @x@
int(x)   integer part of @x@, truncated towards zero
log(x)   @log (x)@, logarithm base @e@ of @x@
log10(x) @log sub 10 (x)@, logarithm base 10 of @x@
sin(x)   @sin (x)@, sine of @x@
sqrt(x)  @sqrt x@, @x sup half@
.ТЕ
.ix table~of [hoc] functions
.PP
Logical expressions have value 1.0 (true) and 0.0 (false).
As in C,
any non-zero value is taken to be true.
As is always the case with floating point numbers,
equality comparisons are inherently suspect. .PP
.I Hoc
also has a few built-in constants, shown in Table 3.
.TS
center, box;
c s s
lfCW n l.
\fBTable 3:\fP Built-in Constants
.sp .5
DEG   57.29577951308232087680 @180/ pi@, degrees per radian
E     2.71828182845904523536  @e@, base of natural logarithms
GAMMA 0.57721566490153286060  @gamma@, Euler-Mascheroni constant
PHI   1.61803398874989484820  @( sqrt 5 +1)/2@, the golden ratio
PI    3.14159265358979323846  @pi@, circular transcendental number
.ТЕ
.ix table~of [hoc] constants
.NH
Statements and Control Flow
.PP
.I Hoc
statements have the following grammar:
.DS
.I
stmt: expr
 | variable = expr
 | procedure ( arglist )
 | while ( expr ) stmt
 | if ( expr ) stmt
 | if ( expr ) stmt else stmt
 | { stmtlist }
 | print expr-list
 | return optional-expr

stmtlist: \fR(nothing)\fI
 | stmlist stmt
.R
.DE
An assignment is parsed by default as a statement rather than
an expression, so assignments typed interactively
do not print their value.
.PP
Note that semicolons are not special to
.ix [hoc] input~format
@hoc@: statements are terminated by newlines.
This causes some peculiar behavior.
The following are legal
.IT if
statements:
.DS
.ft CW
if (x < 0) print(y) else print(z)

if (x < 0) {
 print(y)
} else {
 print(z)
}
.ft
.DE
In the second example, the braces are mandatory:
the newline after the
.I if
would terminate the statement and produce a syntax error were
the brace omitted.
.PP
The syntax and semantics of @hoc@
control flow facilities are basically the same as in C.
The
.I while
and
.I if
statements are just as in C, except there are no @break@ or
@continue@ statements.
.NH
Input and Output: @read@ and @print@
.PP
.ix [hoc] [read]~statement
.ix [hoc] [print]~statement
The input function @read@, like the other built-ins,
takes a single argument. Unlike the built-ins, though, the argument
is not ал expression: it is the name of a variable.
The next number (as defined above) is read from the standard input
and assigned to the named variable.
The return value of @read@ is 1 (true) if a value was read, and 0 (false)
if @read@ encountered end of file or an error.
.PP
Output is generated with the ©print© statement.
The arguments to @print@ are a comma-separated list of expressions
and strings in double quotes, as in C.
Newlines must be supplied;
they are never provided automatically by @print@.
.PP
Note that @read@ is a special built-in function, and therefore takes
a single parenthesized argument, while @print@ is a statement that takes
a comma-separated, unparenthesized list:
.DS
.ft CW
while (read(x)) {
 print "value is ", x, "\n"
}
.ft
.DE
.NH
Functions and Procedures
.PP
Functions and procedures are distinct in @hoc@,
although they are defined by the same mechanism.
This distinction is simply for run-time error checking:
it is an error for a procedure to return a value,
and for a function @not@ to return one.
.PP
The definition syntax is:
.ix [hoc] function~definition
.ix [hoc] procedure~definition
.DS
.I
.ta 1i
function: func name() stmt

procedure: proc name() stmt
.R
.DE
.I name
may be the name of any variable \(em built-in functions are excluded.
The definition, up to the opening brace or statement,
must be on one line, as with the
.I if
statements above.
.PP
Unlike C,
the body of a function or procedure may be any statement, not
necessarily a compound (brace-enclosed) statement.
Since semicolons have no meaning in @hoc@,
a null procedure body is formed by an empty pair of braces.
.PP
Functions and procedures may take arguments, separated by commas,
when invoked. Arguments are referred to as in the shell:
.ix [hoc] arguments
.IT $3
refers to the third (1-indexed) argument.
They are passed by value and within functions
are semantically equivalent to variables.
It is an error to refer to an argument numbered greater than the
number of arguments passed to the routine. The error checking
is done dynamically, however, so a routine may have variable numbers
of arguments if initial arguments affect the number of arguments
to be referenced (as in C's @printf@).
.PP
Functions and procedures may recurse, but the stack has limited depth
(about a hundred calls). The following shows a
.I
hoc
definition of Ackermann's function:
.ix Ackermann's~function
.DS
.ft CW
.ix [ack]~function
.S $ "hoc
.S "func ack() {
.S " if ($1 == 0) return $2+1
.S " if ($2 == 0) return ack($1-1, 1)
.S " return ack($1-1, ack($1, $2-1))
.S "}
.S "ack(3, 2)
 29
.S "ack(3, 3)
 61
.S "ack(3, 4)
hoc: stack too deep near line 8
\&...
.ft
.DE
.bp
.NH
Examples
.PP
Stirling's~formula:
.ix Stirling's~formula
.EQ
n! ~\(ap~ sqrt {2n pi} (n/e) sup n (1+ 1 over 12n )
.EN
.DS
.ft CW
.S $ hoc
.S "func stirl() {
.S " return sqrt(2*$1*PI) * ($1/E)"$1*(1 + 1/(12*$1)) .S "}
.S "stirl(10)
 3628684.7
.S stirl(20)
 2.4328818e+18
.ft R
.DE
.PP
Factorial function, @n!@:
.ix [fac]~function
.DS
. S "func fac() if ($1 <= 0) return 1 else return $1 * fac($1-1)
.ft R
.DE
.PP
Ratio of factorial to Stirling approximation:
.DS
.S "i = 9
.S "while ((i = i+1) <= 20) {
.S \ \ \ \ \ \ \ \ print\ i,\ "\ \ ",\ fac(i)/stirl(i),\ "\en"
.S "} .ft CW
10 1.0000318
11 1.0000265
12 1.0000224
13 1.0000192
14 1.0000166
15 1.0000146
16 1.0000128
17 1.0000114
18 1.0000102
19 1.0000092
20 1.0000083
.ft
.DE

3.7.14 hoc.y

%{
#include "hoc.h"
#define code2(c1,c2) code(c1); code(c2)
#define code3(c1,c2,c3) code(c1); code(c2); code(c3)
%}
%union {
 Symbol *sym; /* symbol table pointer */
 Inst *inst; /* machine instruction */
 int narg; /* number of arguments */
}
%token  NUMBER STRING PRINT VAR BLTIN UNDEF WHILE IF ELSE
%token  FUNCTION PROCEDURE RETURN FUNC PROC READ
%token  ARG
%type  expr stmt asgn prlist stmtlist
%type  cond while if begin end
%type  procname
%type  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)UID = (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 
#include 
char *progname;
int lineno = 1;
#include 
#include 

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=getc(fin)) == ' ' || 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=getc(fin)) != 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 (с == '\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;
 с = getc(fin);
 if (islower(c) && index(transtab, c))
  return index(transtab, с)[1];
 return c;
}

follow(expect, ifyes, ifno) /* look ahead for >=, etc. */
{
 int с = 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); /* flush rest of file */
 longjmp(begin, 0);
}

fpecatch() /* catch floating point exceptions */
{
 execerror("floating point exception", (char*)0);
}

main(argc, argv) /* hoc6 */
 char *argv[];
{
 int i, fpecatch();

 progname = argv[0];
 if (argc == 1) { /* fake an argument list */
  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) /* print warning message */
 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)
  с = getc(fin); /* flush rest of input line */
 if (c == '\n')
  lineno++;
}

3.7.15 init.c

#include "hoc.h"
#include "y.tab.h"
#include 

extern double Log(), Log10(), Sqrt(), Exp(), integer();

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,
};

static struct { /* Constants */
 char *name;
 double eval;
} consts[] = {
 "PI",    3.14159265358979323846,
 "E",     2.71828182845904523536,
 "GAMMA", 0.57721566490153286060, /* Euler */
 "DEG",  57.29577951308232087680, /* 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 range */
 "log10", Log10, /* checks range */
 "exp",   Exp, /* checks range */
 "sqrt",  Sqrt, /* checks range */
 "int",   integer,
 "abs",   fabs,
 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].eval);
 for (i = 0; builtins[i].name; i++) {
  s = install(builtins[i].name, BLTIN, 0.0);
  s->u.ptr = builtins[i].func;
 }
}

3.7.16 makeapp

#!/bin/sh

cd hoc6
for i in hoc.y hoc.h symbol.c code.c init.c math.c makefile
do
 echo "
**** $i ***************************************
"
 sed 's/\\/\\e/g
 s/^$/.sp .5/' $i |
 awk '
                      { print }
  /(^ ;$)|(^})|(^%%)/ { print ".P3" }
 '
done

3.7.17 makefile

CC = lcc
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]

3.7.18 math.c

#include 
#include 

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 Sqrt(x)
 double x;
{
 return errcheck(sqrt(x), "sqrt");
}

double Exp(x)
 double x;
{
 return errcheck(exp(x), "exp");
}

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) /* check result of library call */
 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;
}

3.7.19 mbox

From: Polyhedron Software Ltd <[e-mail]>
To: ">INTERNET:[e-mail]" 
Subject: Message from Internet
Date: 10 May 91 04:07:07 EDT
Message-Id: <"910510080707 100013.461 CHE27-1"@CompuServe.COM>

Got your message. I'll pass it on to Tony. We haven't noticed any
errors at all in CompuServe mail, so far.

Regards

Graham Wood

From kam Thu May 9 10:58:06 EDT 1991
tony fritzpatrick called from england. he had spoken to you
last week about compuserve.
the number is:
100013,461

this is regarding the HOC6 listing.

he will call you back tomorrow

From pipe!subll276 Fri May 3 10:38:29 EDT 1991
Message to: BK

From: Tony Fitzpatrick
ECL
Highlands Farm
Greys Road
Henley OXON, RG 94 PS
ENGLAND

Telephone: 0491 - 575-989 (country code 45)

FAX: [phone]

1. H would like permission
   (which has already been granted by publisher) to
   use HUC 6 program — commercial software.

2. Is the listing available on floppy disk?

3. Thank you for a very interesting and useful book.

4. He left his fax # and telephone #. He wasn't sure of the country code.
   He would appreciate hearing from you via fax.

sub 11276

3.7.20 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;
}

3.8 Всякая всячина