Subject: FOCAL in C with doc and example

From: [email-masked] (Jonathan Chandross)
Date: 23 Oct 93 02:42:05 GMT

A few days ago someone posted a version of FOCAL that was written
in C.  Alas, it would not compile and came with no documentation.

I hacked it enough to make it compile (the original version as posted
is included), added a Makefile, wrote up a brief manual for it, and
wrote an example FOCAL script.  (As I've never written a FOCAL program
before this, experienced FOCAL programmers may take issue with it.)

I have tested it under SCO 3.2.4 and SunOS.  Change the OS line in the
Makefile to reflect your os.  I had to make a change (about 5 minutes
ago) to the line 170 in focal.c to make it work under SunOS:
	ctp = clp->l_text;
became:
	if (clp != NULL) {
		ctp = clp->l_text;
	} else
		ctp = NULL;
I also had to change DIRSIZ to dp.d_namelen on two lines.

I have tested the fixes (made a few minutes ago) under both SCO and SunOS
and the example program works correctly.  All of my poking around was done
under SCO, so the SunOS version may not be as robust.  I do not know if
these changes have broken something.

DISCLAIMER:
	I did not write the code; if you don't like the programming
	style, or the constructs make you shudder, don't blame me.

	I do not expect this to work on your machine. If it does not
	and you have a fix, send it to me.  I cannot provide assistance
	in debugging any problems you might encounter.

	I know next to nothing about the internals.

	Flamage to /dev/null.

Enjoy.

If you send me an interesting program I may include it in the next posting
of this, assuming I don't live to regret this posting version. 

Jonathan A. Chandross
Internet: [email-masked]
UUCP: rutgers!pilot.njin.net!jac
********************************************************************************
:	This is a shell archive.
:	Remove everything above this line and
:	run the following text with /bin/sh to create:
:	Read.Me
:	example
:	Makefile
:	focal.c
:	focal.c.ORIG
: This archive created: Fri Oct 22 22:22:12 1993
cat << 'SHAR_EOF' > Read.Me

FOCAL 1981 Reference Manual

FOCAL stands for "Formulating On-line Calculations in Algebraic Language"
and is a very simple language performing calculations of various sorts.
This version of FOCAL, which I did *not* write, implements only a subset
of the FOCAL language as defined by DEC.  Major missing features include
built-in functions and the trace feature.  The error messages do not
conform to the DEC syntax, although this can be considered an
improvement.  Finally, the floating point math range is limited since it
uses doubles instead of the 24-bit two's complement mantissa and 12-bit
two's complement exponent format used by the PDP-8 implementation.

The contents of this all to brief manual were derived from:
	Title  = Programming Languages
	Series = Digital PDP-8 Handbook Series
	Author = Digital Equipment Corporation
	Date   = May, 1970
which contains greater details.

The "focal.c" program was posted to the net without any documentation in
1981 and reposted by a third party in 1993.  I took the 1993 posting, made
the program compile, and added a makefile, while keeping as close to the
original author's coding style as possible.  The original version can be
found in "focal.c.ORIG".  I don't know who the original author is and
neither does the fellow who reposted it in 1993.  I used my copy of the
_Programming Languages_ book to write up enough to use the package.

Files in this distribution:
	Makefile		Make script
	Read.Me			This file
	example			Example of the major FOCAL constructs
	focal.c			Focal interpreter in C
	focal.c.ORIG		Original version as posted to net

To run the example, invoke focal and then type:
	library call example
	go
or
	l c example
	g
depending upon how terse you like to be.  Alternatively, you can invoke
FOCAL and type commands at it.  The FOCAL prompt is a "*".

I had absolutely nothing whatsoever to do with the software other than
making the few minor changes necessary to make it work.

I make no representation that the information contained herein is
accurate or useful, nor do I make no representation that the software
will compile or execute properly on your machine.  If it does not, I
do not want to know about it.

Documentation and code changes COPYRIGHT 1993 by Jonathan A. Chandross.
Redistribution permitted so long as no charge is made and modifications
to either the code or the manual are clearly marked as such, and no
change leads the reader to conclude that I had anything to do with the
software.

I would like to thank Doug Jones for his useful comments on this brief
description of FOCAL.

Jonathan A. Chandross
[email-masked]
10/20/93

********************************************************************************

Command   Abbreviation   Example of Form	Description
ask		a	 ask x,y,z		FOCAL types a colon for
						each variable; the user
						types a value to define
						each variable
comment		c	 comment		If a line begins with the
						letter C, the remainder
						of the line will be ignored
do		d	 do 4.1			Execute line 4.1; return
						to command following "do"
						command
			 do 4			Execute all lines in group 4;
						return to command following
						"do" command
			 do 4.0			Execute all lines in group 4;
						return to command following
						"do" command
erase		e	 erase			Erases the symbol table
			 erase 2.0		Erases all group 2 lines
			 erase 2.1		Deletes line 2.1
			 erase all		Deletes all lines
for		f	 for index=initial,limit,step; (commands)
			 for index=initial,limit; (commands)
						For loop.  Execute (commands)
						for each value:
						   index = initial
						   while index <= limit
						       <commands>
						       index = index + step
						For example,
							for i=1,10,2;t i!
						loops from 1 to 10 stepping
						by 2, printing out the loop
						index each time. If no step
						is specified, the value "1"
						is used.
go		g	 go			Starts execution with lowest
						numbered line number.
			 go 4.2			Go to line 4.2
goto		g	 goto			Starts execution with lowest
						numbered line number.
			 goto 4.2		Go to line 4.2
library call	l c	 library call <name>	Load program <name> from
						current directory
library delete	l d	 library delete <name>	Delete program <name> from
						current directory
library list	l l	 library list		List current directory
library save	l s	 library save <name>	Save program as <name>
if 		i	 if (x) L0, L1, L2	Where X is a defined
			 if (X) L0, L1;		identifier, a value, or an
			    (commands)		expression, followed by one
			 if (X) L0;		to three line numbers:
			    (commands)		  If X < 0 goto L0
						  if X = 0 goto L1
						  if X > 0 goto L2
quit		q	 quit			Exit FOCAL
return		r	 return			Terminates "do" subroutine
						and returns to caller
set		s	 set a = 5/b*c;		Defines identifiers in the
						symbol table
type		t	 type a * b + c;	Evaluates expression and
						types out "=" and result
						in current output format
			 type a - b, c/e;	Computes and types each
						expression separated by
						commas.
			 type "text"		Types "text".  May be
						followed by "!" to
						generate carriage-return
						line-feed, or "#" to
						generate carriage-return.
						The "$" option is not
						supported.
write		w	 write			FOCAL types out the entire
			 write all		indirect program
			 write 1.0		FOCAL types out all group
						1 lines
			 write 1.1		FOCAL types out line 1.1
						1 lines

********************************************************************************

Operators:
	Name	Syntax		Description
	+	a + b		Addition
	-	a - b		Subtraction
	*	a * b		Multiplication
	/	a / b		Division

********************************************************************************

Grouping operators: (),<>,[]
	()
	<>
	[]

	Example:
		set x = [<(a * b) + c> / d]

	Note that the "(" and ")" operators are also used for arrays.

********************************************************************************

Arrays:
	An array element is defined by assigning to it.  Referring to
	an undefined element results in an error.  For example, the
	command below creates an array with ten elements by setting
	each element to the value "30":
		for i=1,10; set coeff(i) = 30;
	The command below prints out the array:
		for i=1,10; t coeff(i)!;

********************************************************************************

Output Control:
	Name	Syntax		Description
	"	"..."		Text string.
					t "this is a string"
	!	"..."!		Output a carriage-return, line-feed after
				the string
					t "this is a string"!
	#	"..."#		Output a carriage-return after string
					t "this is a string"#
	%	%x.y		Output in scientific notation
				   x	total number of digits to be output
				   y	number of digits to right of decimal
					point

********************************************************************************

Line Numbering:
	Any line not beginning with a line number is executed immediately.
	Line numbers take the form:
		<group> "." <line>
	For example:
		2.1 type "This is line 2.1"!
	This creates the line "1" in the group "2".

	The <group> provides a way to package a sequence of lines.  This
	allows the sequence to be invoked as a subroutine, or manipulated
	in other ways, such as deleting the group as a whole or printing
	it out as a whole.  For example, the command:
		erase 2
	deletes all lines in group 2.

********************************************************************************

Line Syntax:

	Multiple commands can be placed on the same line provided each
	is separated by a ";".  The syntax is:
		<command> [";" <command>]*
	For example:
		set x = 3;set y =5; type x + y

	This ";" separator is also used by the "for" statement to separate
	the statements to execute during each iteration.  Given a "for"
	loop of the form:
		for ...;s1,s2,s3
	s1, s2, and s3 are the statements executed during each iteration
	of the "for" loop.  For example
		for i = 1,10,2; type "i is ", i!; type "i + 2 is ", i + 2!
SHAR_EOF
cat << 'SHAR_EOF' > example
1.01 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1.02 C
1.03 C Brief demonstration of FOCAL's features.
1.04 C
1.05 C COPYRIGHT 1993 by Jonathan A. Chandross ([email-masked])
1.06 C All Rights Reserved
1.07 C Redistribution without fee permitted.
1.08 C
1.09 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1.10 set a=1; set b=2
1.20 type "Calling subroutine 10, value is: ",%1.a+b!
1.21 do 10
1.22 type "Returned from subroutine, exiting."!
1.23 type "Calling subroutine 20"!
1.24 do 20
1.25 type "Calling line 11 in subroutine 20"!
1.26 do 20.11
1.30 type "Calling subroutine 30"!
1.31 do 30
1.40 type "Calling subroutine 40"!
1.41 do 40
1.50 type "Calling subroutine 50"!
1.51 do 50
1.94 quit
1.95 type "THIS LINE NEVER EXECUTES"!

10.01 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10.02 C
10.03 C Group 10
10.04 C
10.05 C Give global variables "a" and "b" new values
10.06 C Print out message and sum
10.07 C Return
10.08 C
10.09 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10.10 set a=3; set b=4
10.11 type "In Subroutine, value is: ",%1.a+b!
10.12 return
10.13 type "THIS LINE IN SUBROUTINE NEVER EXECUTES"!

20.01 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
20.02 C
20.03 C Group 20
20.04 C
20.06 C Print out message 1
20.06 C Print out message 2
20.08 C
20.09 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
20.10 type "In Subroutine 20, line 10, MESSAGE 1"!
20.11 type "In Subroutine 20, line 11, MESSAGE 2"!
20.12 return

30.01 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30.02 C
30.03 C Group 30
30.04 C
30.06 C Output what we are doing
30.06 C output numbers from 1 to 10, stepping by 2
30.08 C
30.09 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
30.10 type "Counting to 10 by 2's"!
30.11 for i = 1,10,2; type i!
30.12 return

40.01 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
40.02 C
40.03 C Group 40
40.04 C
40.06 C Prompt for a number
40.06 C Print out whether number is < 0, = 0, or > 0
40.08 C
40.09 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
40.10 type "Input a number"
40.20 ask x
40.25 if x 40.30, 40.40, 40.50
40.30 type "Value ", x, " < 0"!; return
40.40 type "Value ", x, " = 0"!; return
40.50 type "Value ", x, " > 0"!; return

50.01 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50.02 C
50.03 C Group 50
50.04 C
50.06 C Demonstrates arrays
50.06 C for i = 1 to 3
50.07 C		value[i] = 10 + i
50.08 C		print "Entry[" i "] is" value[i]
50.09 C
50.10 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50.20 for i = 1,3; set value(i) = 10 + i; type "Entry(",i,") = ",value(i)!
SHAR_EOF
cat << 'SHAR_EOF' > Makefile

CC	= /usr/local/bin/gcc

OS	= -Dunix -Dbsd_unix
#OS	= -Dunix -Dsysv_unix
#OS	= -Dvms
#OS	= -Ddecus

FLAGS	= $(OS) -g2

all: focal

focal: focal.c
	$(CC) $(FLAGS) -o focal focal.c
	
clean:
	rm -f focal

SHAR_EOF
cat << 'SHAR_EOF' > focal.c
/*
 * Focal, 1981.
 * Dedicated to the old times,
 * when an 8k PDP-8 was considered
 * a BIG machine.
 */

#include <stdio.h>

#ifndef decus
#include <ctype.h>
#include <signal.h>
#else
int     $$narg = 1;                     /* No argv prompt               */
#endif

#include <setjmp.h>

#ifdef  bsd_unix
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/dir.h>
#endif

#ifdef  sysv_unix
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/dir.h>
#endif

#define NID     16                      /* # characters in id */

struct  line
{
        struct  line *l_fp;             /* Link */
        char    l_lno;                  /* Line */
        char    l_gno;                  /* Group */
        char    *l_text;                /* Text */
};

struct  lno
{
        char    ln_lno;                 /* Line */
        char    ln_gno;                 /* Group */
        int     ln_type;                /* Type */
};

#define LN_ALL  0                       /* All */
#define LN_GRP  1                       /* Group */
#define LN_LINE 2                       /* Line */
#define LN_NONE 3                       /* No number */

struct  control
{
        struct  control *c_fp;          /* Link */
        int     c_mode;                 /* Control mode */
        struct  line *c_lp;             /* Saved current line */
        char    *c_tp;                  /* Saved text pointer */
        struct  sym *c_sp;              /* Symbol (for) */
        double  c_limit;                /* Limit (for) */
        double  c_step;                 /* Step (for) */
};

#define C_TOP   0                       /* Top level */
#define C_DLINE 1                       /* Do line */
#define C_DGRP  2                       /* Do group */
#define C_DALL  3                       /* Do all */
#define C_FOR   4                       /* FOR loop */

struct  sym
{
        struct  sym *s_fp;              /* Link */
        int     s_type;                 /* Type of entry */
        int     s_subs;                 /* Subscript */
        union   {
                double  s_value;        /* The data */
                double  (*s_funp)();    /* Function pointer */
        } s_un;
        char    *s_id;                 /* Name */
};

#define S_SCAL  0
#define S_ARRAY 1
#define S_FUNC  2

char    cbuf[128];                      /* Command buffer */
char    abuf[128];                      /* Ask buffer */
char    *ctp;                           /* Current text pointer */
struct  line    *line;                  /* Line list header */
struct  line    *clp;                   /* Current line pointer */
struct  sym     *sym;                   /* Symbol table */
int     mode;                           /* Current processing mode */
struct  sym     *forsp;                 /* Symbol pointer (for) */
double  forlimit;                       /* Loop limit (for) */
double  forstep;                        /* Loop step (for) */
struct  control *control;               /* Control stack */
jmp_buf env;                            /* Saved state for errors */
int     intflag;                        /* Interrupt flag */

extern double  atof();
extern void    onintr();                       /* ^C catcher */
extern double  eval();
extern double  primary();
extern double  term();
extern struct  sym     *getsym();
extern struct  sym     *lookup();
extern struct  line    *alocline();

main()
{
        register c;

        setjmp(env);
#ifndef decus
        signal(SIGINT, &onintr);
#endif
	printf("\nFOCAL 1981\n\n");
        for (;;) {
                putchar('*');
                if (gets(cbuf) == NULL) {
                        putchar('\n');
                        break;
                }
                mode = C_TOP;
                clp  = NULL;
                ctp  = cbuf;
                if ((c=getnb()) != 0) {
                        if (isdigit(c))
                                inject(c);
                        else {
                                --ctp;
                                process();
                        }
                }
        }
}

process()
{
        double limit, step;
        double value;
        register c;
        register struct sym *sp;
        register struct line *lp;
        struct lno lno;
        struct line *lp1, *lp2, *lp3;
        int grp;

loop:
        if (intflag) {
                intflag = 0;
                diag("^C");
        }
        while ((c=getnb()) == ';')
                ;
        if (c == 0) {
                if (mode == C_FOR) {
                        forsp->s_un.s_value += forstep;
                        if (forstep>0.0 && forsp->s_un.s_value<=forlimit
                        ||  forstep<0.0 && forsp->s_un.s_value>=forlimit) {
                                clp = control->c_lp;
                                ctp = control->c_tp;
                                goto loop;
                        }
                        popfor();
                }
                if (clp != NULL) {
                        grp = clp->l_gno;
                        clp = clp->l_fp;
			if (clp != NULL) {
				ctp = clp->l_text;
			} else
				ctp = NULL;
                }
                if (clp == NULL) {
                        if (mode == C_TOP)
                                return;
                        popdo();
                } else if (mode == C_DLINE
                || (mode==C_DGRP && grp!=clp->l_gno))
                        popdo();
                goto loop;
        }
        while (isalpha(*ctp))
                ++ctp;
        if (isupper(c))
                c = tolower(c);
        switch (c) {

        case 'a':
                do {
                        sp = getsym();
                        putchar(':');
                        if (gets(abuf) == NULL) {
                                putchar('\n');
                                diag("EOF in ask");
                        }
                        sp->s_un.s_value = atof(abuf);
                } while ((c=getnb()) == ',');
                --ctp;
                break;

        case 'c':
                while (*ctp != 0)
                        ++ctp;
                break;

        case 'd':
                getlno(&lno, -1);
                pushdo();
                if (lno.ln_type==LN_NONE || lno.ln_type==LN_ALL) {
                        if ((clp=line) == NULL)
                                diag("No program");
                        ctp = clp->l_text;
                        mode = C_DALL;
                        goto loop;
                }
                if (lno.ln_type == LN_GRP) {
                        lp = line;
                        while (lp!=NULL && lp->l_gno<lno.ln_gno)
                                lp = lp->l_fp;
                        if (lp!=NULL && lp->l_gno==lno.ln_gno) {
                                clp = lp;
                                ctp = clp->l_text;
                                mode = C_DGRP;
                                goto loop;
                        }
                        badline();
                }
                lp = line;
                while (lp != NULL
                && (lp->l_gno != lno.ln_gno
                ||  lp->l_lno != lno.ln_lno))
                        lp = lp->l_fp;
                if (lp != NULL) {
                        clp = lp;
                        ctp = clp->l_text;
                        mode = C_DLINE;
                        goto loop;
                }
                badline();

        case 'e':
                getlno(&lno, -1);
                if (lno.ln_type == LN_NONE) {
                        erasesyms();
                        break;
                }
                lp1 = NULL;
                lp2 = line;
                while (lp2 != NULL) {
                        if (lno.ln_type == LN_ALL
                        || (lp2->l_gno  == lno.ln_gno
                        && (lno.ln_type==LN_GRP || lp2->l_lno==lno.ln_lno))) {
                                if (lp2 == clp)
                                        diag("Erasing current line");
                                lp3 = lp2;
                                lp2 = lp2->l_fp;
                                if (lp1 == NULL)
                                        line = lp2; else
                                        lp1->l_fp = lp2;
                                free((char *) lp3);
                        } else {
                                lp1 = lp2;
                                lp2 = lp2->l_fp;
                        }
                }
                break;

        case 'f':
                sp = getsym();
                clearfors(sp);
                if (getnb() != '=')
                        diag("Missing = sign");
                sp->s_un.s_value = eval();
                if (getnb() != ',')
                        diag("Missing comma");
                limit = eval();
                if ((c=getnb()) == ';')
                        step = 1.0;
                else if (c == ',') {
                        step = eval();
                        if (getnb() != ';')
                                diag("Missing semi");
                } else
                        diag("Bad for");
                pushfor();
                forsp = sp;
                forlimit = limit;
                forstep = step;
                mode = C_FOR;
                break;

        case 'g':
                getlno(&lno, -1);
                if (lno.ln_type == LN_NONE) {
                        if ((clp=line) == NULL)
                                diag("No program");
                        ctp = clp->l_text;
                        goto loop;
                } else if (lno.ln_type == LN_LINE) {
                        lp = line;
                        while (lp != NULL
                        && (lp->l_gno != lno.ln_gno
                        ||  lp->l_lno != lno.ln_lno))
                                lp = lp->l_fp;
                        if (lp != NULL) {
                                clp = lp;
                                ctp = clp->l_text;
                                goto loop;
                        }
                }
                badline();

        case 'i':
                value = eval();
                if (value >= 0.0) {
                        while ((c = *ctp)!=0 && c!=',' && c!=';')
                                ++ctp;
                        if (c != ',')
                                goto loop;
                        ++ctp;
                        if (value != 0.0) {
                                while ((c = *ctp)!=0 && c!=',' && c!=';')
                                        ++ctp;
                                if (c != ',')
                                        goto loop;
                                ++ctp;
                        }
                }
                getlno(&lno, -1);
                if (lno.ln_type == LN_LINE) {
                        lp = line;
                        while (lp != NULL
                        && (lp->l_gno != lno.ln_gno
                        ||  lp->l_lno != lno.ln_lno))
                                lp = lp->l_fp;
                        if (lp != NULL) {
                                clp = lp;
                                ctp = clp->l_text;
                                goto loop;
                        }
                }
                badline();

        case 'l':
                library();
                break;

        case 'q':
                if (clp == NULL)
                        exit(0);
                return;

        case 't':
                type();
                break;

        case 'r':
                while (mode == C_FOR)
                        popfor();
                popdo();
                break;

        case 's':
                sp = getsym();
                if (getnb() != '=')
                        diag("Missing = sign");
                sp->s_un.s_value = eval();
                break;

        case 'w':
                getlno(&lno, -1);
                save(&lno, stdout);
                break;

        default:
                diag("Illegal command");
        }
        goto loop;
}

badline()
{
        diag("Bad line number");
}

pushdo()
{
        register struct control *cp;

        if ((cp=(struct control *)malloc(sizeof(struct control))) == NULL)
                diag("Out of space (control stack)");
        cp->c_fp = control;
        control  = cp;
        cp->c_mode = mode;
        cp->c_tp = ctp;
        cp->c_lp = clp;
}

pushfor()
{
        register struct control *cp;

        if ((cp=(struct control *)malloc(sizeof(struct control))) == NULL)
                diag("Out of space (control stack)");
        cp->c_fp = control;
        control  = cp;
        cp->c_mode = mode;
        cp->c_tp = ctp;
        cp->c_lp = clp;
        cp->c_sp = forsp;
        cp->c_limit = forlimit;
        cp->c_step = forstep;
}

popdo()
{
        register struct control *cp;

        if ((cp=control) == NULL)
                diag("Return not in do");
        control = cp->c_fp;
        ctp = cp->c_tp;
        clp = cp->c_lp;
        mode = cp->c_mode;
        free((char *) cp);
}

popfor()
{
        register struct control *cp;

        if ((cp=control) == NULL)
                diag("For stack botch");
        control = cp->c_fp;
        forsp = cp->c_sp;
        forlimit = cp->c_limit;
        forstep = cp->c_step;
        mode = cp->c_mode;
        free((char *) cp);
}

clearfors(sp)
register struct sym *sp;
{
        register struct control *cp1, *cp2;

        if (mode==C_FOR && forsp==sp)
                popfor();
        else {
                cp1 = NULL;
                cp2 = control;
                while (cp2 != NULL) {
                        if (cp2->c_mode==C_FOR && cp2->c_sp==sp) {
                                if (cp1 == NULL)
                                        control = cp2->c_fp; else
                                        cp1->c_fp = cp2->c_fp;
                                free((char *) cp2);
                                break;
                        }
                        cp1 = cp2;
                        cp2 = cp2->c_fp;
                }
        }
}

library()
{
        register char *p;
        register c, d;
        char *sctp;
        struct line *lp1, *lp2;
#ifdef  bsd_unix
        struct direct db;
#endif
#ifdef  sysv_unix
        struct direct db;
#endif
        struct stat sb;
        int     fd;
        register FILE *fp;

        c = getnb();
        if (c!='c' && c!='s' && c!='l' && c!='d')
                diag("Bad library command");
        while (isalpha(*ctp))
                ++ctp;
        while ((d = *ctp)==' ' || d=='\t')
                ++ctp;
        if (c!='l' && d==0)
                diag("Missing file name");
        p = ctp;
        while (*ctp != 0)
                ++ctp;
        switch (c) {

        case 'c':
                if ((fp=fopen(p, "r")) == NULL)
                        diag("Cannot open");
                lp1 = line;
                while (lp1 != NULL) {
                        lp2 = lp1->l_fp;
                        free ((char *) lp1);
                        lp1 = lp2;
                }
                line = NULL;
                sctp = ctp;
                while (getline(abuf, fp) != 0) {
                        ctp = abuf;
                        if ((c=getnb()) != 0) {
                                if (isdigit(c) == 0)
                                        diag("Direct line in call");
                                inject(c);
                        }
                }
                fclose(fp);
                ctp = sctp;
                break;

#ifdef  unix
        case 'd':
                if (unlink(p) < 0)
                        diag("Cannot delete");
                break;

        case 'l':
                if (d == 0)
                        p = ".";
                if (stat(p, &sb) < 0
                || (sb.st_mode&S_IFMT) != S_IFDIR
                || (fd = open(p, 0)) < 0)
                        diag("Bad directory");
#ifdef  bsd_unix
                while (read(fd, &db, sizeof(db)) == sizeof(db)) {
                        if (db.d_ino == 0
                        ||  strncmp(db.d_name, ".",  db.d_namlen) == 0
                        ||  strncmp(db.d_name, "..", db.d_namlen) == 0)
                                continue;
                        printf("%.*s\n", db.d_namlen, db.d_name);
                }
#endif
#ifdef sysv_unix
                while (read(fd, &db, sizeof(db)) == sizeof(db)) {
                        if (db.d_ino == 0
                        ||  strncmp(db.d_name, ".",  DIRSIZ) == 0
                        ||  strncmp(db.d_name, "..", DIRSIZ) == 0)
                                continue;
                        printf("%.*s\n", DIRSIZ, db.d_name);
                }
#endif
                close(fd);
                break;
#endif
        case 's':
                if ((fp=fopen(p, "w")) == NULL)
                        diag("Cannot create");
                save(NULL, fp);
                fclose(fp);
                break;
        }
}

inject(c)
register c;
{
        register struct line *lp1, *lp2, *lp3;
        struct lno  lno;

        getlno(&lno, c);
        if (lno.ln_type != LN_LINE)
                diag("Illegal line number");
        lp1 = NULL;
        lp2 = line;
        while (lp2 != NULL
        && (lp2->l_gno < lno.ln_gno
        || (lp2->l_gno==lno.ln_gno&&lp2->l_lno<=lno.ln_lno))) {
                if (lp2->l_gno == lno.ln_gno
                &&  lp2->l_lno == lno.ln_lno) {
                        lp3 = lp2;
                        lp2 = lp2->l_fp;
                        if (lp1 == NULL)
                                line = lp2; else
                                lp1->l_fp = lp2;
                        free((char *) lp3);
                        break;
                }
                lp1 = lp2;
                lp2 = lp2->l_fp;
        }
        if ((c=getnb()) != 0) {
                lp3 = alocline(--ctp);
                lp3->l_fp  = lp2;
                lp3->l_gno = lno.ln_gno;
                lp3->l_lno = lno.ln_lno;
                strcpy(lp3->l_text, ctp);
                if (lp1 == NULL)
                        line = lp3; else
                        lp1->l_fp = lp3;
        }
}

getline(cp, fp)
register char *cp;
register FILE *fp;
{
        register c;

        while ((c=getc(fp))!=EOF && c!='\n')
                *cp++ = c;
        if (c == EOF)
                return (0);
        *cp = 0;
        return (1);
}

type()
{
        register char *fmt;
        register c;
        char fmtb[20];
        int x, y;

        fmt = "%6e";
        while ((c=getnb())!=0 && c!=';') {
                if (c == '%') {
                        if ((c=getnb())==0 || c==';' || c==',') {
                                fmt = "%6e";
                                --ctp;
                                continue;
                        }
                        x = getnum(c);
                        if (getnb() != '.')
                                diag("Missing . in format");
                        y = getnum(getnb());
                        sprintf(fmtb, "%%%d.%df", x, y);
                        fmt = fmtb;
                        continue;
                }
                if (c == ',')
                        continue;
                if (c == '!') {
                        putchar('\n');
                        continue;
                }
                if (c == '#') {
                        putchar('\r');
                        continue;
                }
                if (c == '"') {
                        while ((c = *ctp++)!='\0' && c!='"')
                                putchar(c);
                        if (c == '\0') {
                                diag("Missing string quote");
                                break;
                        }
                        continue;
                }
                --ctp;
                printf(fmt, eval());
        }
        --ctp;
}

save(lnop, fp)
register struct lno *lnop;
FILE *fp;
{
        struct lno lno;
        register struct line *lp;
        register tgroup, lgroup;

        if (lnop == NULL) {
                lno.ln_type = LN_ALL;
                lnop = &lno;
        }
        lp = line;
        if (lnop->ln_type!=LN_NONE && lnop->ln_type!=LN_ALL) {
                while (lp!=NULL && lp->l_gno<lnop->ln_gno)
                        lp = lp->l_fp;
                if (lp==NULL || lp->l_gno!=lnop->ln_gno)
                        diag("Line not found");
                if (lnop->ln_type == LN_LINE) {
                        while (lp!=NULL && lp->l_lno!=lnop->ln_lno)
                                lp = lp->l_fp;
                        if (lp == NULL)
                                diag("Line not found");
                }
        }
        while (lp != NULL) {
                putline(lp, fp);
                if (lnop->ln_type == LN_LINE)
                        break;
                lgroup = lp->l_gno;
                if ((lp = lp->l_fp) != NULL) {
                        tgroup = lp->l_gno;
                        if (lnop->ln_type==LN_GRP && tgroup!=lnop->ln_gno)
                                break;
                        if (tgroup != lgroup)
                                putc('\n', fp);
                }
        }
}

double
eval()
{
        double val, rop;
        register c;

        if ((c=getnb())=='+' || c=='-') {
                val = primary();
                if (c == '-')
                        val = -val;
        } else {
                --ctp;
                val = primary();
        }
        while ((c=getnb())=='+' || c=='-') {
                rop = primary();
                if (c == '+')
                        val = val + rop;
                else
                        val = val - rop;
        }
        --ctp;
        return (val);
}

double
primary()
{
        double val, rop;
        register c;

        val = term();
        while ((c = getnb())=='*' || c=='/') {
                rop = term();
                if (c == '*')
                        val = val * rop;
                else
                        val = val / rop;
        }
        --ctp;
        return (val);
}

double
term()
{
        register c;
        register char *cp;
        double val;
        int fsign, fdot, fexp;
        int term_type, subs;
        struct sym *sp;
        char id[NID];
        char nbuf[20];

        if ((c = getnb())=='(' || c=='[' || c=='<') {
                val = eval();
                if (++c != ')')
                        ++c;
                if (c != getnb())
                        diag("Mismatched enclosures");
                return (val);
        }
        if (c=='.' || isdigit(c)) {
                fsign = 1;
                fexp = 0;
                fdot = 0;
                if (c == '.')
                        ++fdot;
                cp = &nbuf[0];
                for (;;) {
                        if (cp >= &nbuf[19])
                                diag("Number too long");
                        *cp++ = c;
                        if ((c = *ctp++) == '.') {
                                if (fdot++)
                                        break;
                        } else if (c == 'e') {
                                if (fexp++)
                                        break;
                                fsign = 0;
                                fdot = 1;
                        } else if (c=='+' || c=='-') {
                                if (fsign++)
                                        break;
                        } else if (!isdigit(c))
                                break;
                }
                --ctp;
                *cp = '\0';
                return (atof(nbuf));
        }
        if (isalpha(c)) {
                cp = &id[0];
                do {
                        if (cp < &id[NID-1])
                                *cp++ = c;
                        c = *ctp++;
                } while (isalnum(c));
                *cp = 0;
                if (id[0] == 'f') {
                        /* ... */
                }
                term_type = S_SCAL;
                while (c==' ' || c=='\t')
                        c = *ctp++;
                if (c == '(') {
                        term_type = S_ARRAY;
                        subs = (int) eval();
                        if (getnb() != ')')
                                diag("Missing ) in subscript");
                } else
                        --ctp;
                if ((sp=lookup(id, term_type, subs)) == NULL)
                        diag("Undefined variable");
                return (sp->s_un.s_value);
        }
        diag("Expression syntax");
}

struct  sym *
lookup(id, lookup_type, subs)
char *id;
register lookup_type;
{
        register struct sym *sp;

        sp = sym;
        while (sp != NULL) {
                if (sp->s_type == lookup_type
                && (lookup_type!=S_ARRAY || sp->s_subs==subs)
                &&  strcmp(id, sp->s_id) == 0)
                        break;
                sp = sp->s_fp;
        }
        return (sp);
}

struct sym *
getsym()
{
        register c;
        char id[NID];
        register char *cp;
        register struct sym *sp;
        int subs, getsym_type;

        if (isalpha(c = getnb()) == 0)
                diag("Missing variable");
        cp = &id[0];
        do {
                if (cp < &id[NID-1])
                        *cp++ = c;
                c = *ctp++;
        } while (isalnum(c));
        *cp = 0;
        getsym_type = S_SCAL;
        while (c==' ' || c=='\t')
                c = *ctp++;
        if (c == '(') {
                getsym_type = S_ARRAY;
                subs = (int) eval();
                if (getnb() != ')')
                        diag("Bad subscript");
        } else
                --ctp;
        if ((sp=lookup(id, getsym_type, subs)) == NULL) {
                sp = (struct sym *)malloc(sizeof(*sp));
                if (sp == NULL)
                        diag("Out of space (symbols)");
                sp->s_id = (char *)malloc(strlen(id)+1);
                sp->s_fp = sym;
                sym = sp;
                sp->s_type = getsym_type;
                sp->s_subs = subs;
                strcpy(sp->s_id, id);
        }
        return (sp);
}

putline(lp, fp)
register struct line *lp;
FILE *fp;
{
        fprintf(fp, "%02d.%02d %s\n", lp->l_gno, lp->l_lno, lp->l_text);
}

static char badlno[] = "Bad line or group number";

getlno(lnop, c)
register struct lno *lnop;
register c;
{
        register gn, ln;

        if (c < 0)
                c = getnb();
        if (c=='\0' || c==';') {
                --ctp;
                lnop->ln_type = LN_NONE;
                return;
        }
        if (c=='A' || c=='a') {
                while (isalpha(*ctp))
                        ++ctp;
                lnop->ln_type = LN_ALL;
                return;
        }
        if (!isdigit(c))
                diag(badlno);
        if ((gn = getnum(c))<1 || gn>99)
                diag(badlno);
        if (*ctp != '.') {
                lnop->ln_gno = gn;
                lnop->ln_lno = 0;
                lnop->ln_type = LN_GRP;
                return;
        }
        ++ctp;
        if ((ln=getnum(*ctp++)) == 0) {
                lnop->ln_gno = gn;
                lnop->ln_lno = 0;
                lnop->ln_type = LN_GRP;
                return;
        }
        if (ln<1 | ln>99)
                diag(badlno);
        lnop->ln_gno = gn;
        lnop->ln_lno = ln;
        lnop->ln_type = LN_LINE;
}

getnum(c)
register c;
{
        register n;

        n = 0;
        while (isdigit(c)) {
                n = 10*n + c - '0';
                c = *ctp++;
        }
        --ctp;
        return (n);
}

struct line *
alocline(cp)
register char *cp;
{
        register struct line *lp;

        lp = (struct line *) malloc(sizeof(*lp));
        if (lp == NULL)
                diag("Out of memory");
	lp->l_text = (char *)malloc(strlen(cp)+1);
        return (lp);
}

diag(s)
char *s;
{
        register struct line *lp;
        register char *cp;

        printf("%s!\n", s);
        if ((lp=clp) != NULL) {
                putline(lp, stdout);
                printf("      ");
                cp = lp->l_text;
        } else {
                printf("*%s\n ", cbuf);
                cp = cbuf;
        }
        while (cp < ctp) {
                putchar(' ');
                ++cp;
        }
        printf("^\n");
        while (control != NULL)
                popdo();
        longjmp(env, 0);
}

getnb()
{
        register c;

        while ((c = *ctp++)==' ' || c=='\t')
                ;
        return (c);
}

void onintr()
{
        ++intflag;
}

erasesyms()
{
        register struct sym *sp1, *sp2;

        sp1 = sym;
        sym = NULL;
        while (sp1 != NULL) {
                sp2 = sp1->s_fp;
                free((char *) sp1);
                sp1 = sp2;
        }
}

SHAR_EOF
cat << 'SHAR_EOF' > focal.c.ORIG
/*
 * Focal, 1981.
 * Dedicated to the old times,
 * when an 8k PDP-8 was considered
 * a BIG machine.
 */
/*)BUILD
                $(DTOA) = 1
*/

#define unix
#ifdef  vms
#undef  unix
#endif
#ifdef  decus
#undef  unix
#endif
#include <stdio.h>
#ifndef decus
#include <ctype.h>
#include <signal.h>
#else
int     $$narg = 1;                     /* No argv prompt               */
#endif

#include <setjmp.h>

#ifdef  unix
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/dir.h>
#endif

#define NID     16                      /* # characters in id */

struct  line
{
        struct  line *l_fp;             /* Link */
        char    l_lno;                  /* Line */
        char    l_gno;                  /* Group */
        char    l_text[];               /* Text */
};

struct  lno
{
        char    ln_lno;                 /* Line */
        char    ln_gno;                 /* Group */
        int     ln_type;                /* Type */
};

#define LN_ALL  0                       /* All */
#define LN_GRP  1                       /* Group */
#define LN_LINE 2                       /* Line */
#define LN_NONE 3                       /* No number */

struct  control
{
        struct  control *c_fp;          /* Link */
        int     c_mode;                 /* Control mode */
        struct  line *c_lp;             /* Saved current line */
        char    *c_tp;                  /* Saved text pointer */
        struct  sym *c_sp;              /* Symbol (for) */
        double  c_limit;                /* Limit (for) */
        double  c_step;                 /* Step (for) */
};

#define C_TOP   0                       /* Top level */
#define C_DLINE 1                       /* Do line */
#define C_DGRP  2                       /* Do group */
#define C_DALL  3                       /* Do all */
#define C_FOR   4                       /* FOR loop */

struct  sym
{
        struct  sym *s_fp;              /* Link */
        int     s_type;                 /* Type of entry */
        int     s_subs;                 /* Subscript */
        union   {
                double  s_value;        /* The data */
                double  (*s_funp)();    /* Function pointer */
        } s_un;
        char    s_id[];                 /* Name */
};

#define S_SCAL  0
#define S_ARRAY 1
#define S_FUNC  2

char    cbuf[128];                      /* Command buffer */
char    abuf[128];                      /* Ask buffer */
char    *ctp;                           /* Current text pointer */
struct  line    *line;                  /* Line list header */
struct  line    *clp;                   /* Current line pointer */
struct  sym     *sym;                   /* Symbol table */
int     mode;                           /* Current processing mode */
struct  sym     *forsp;                 /* Symbol pointer (for) */
double  forlimit;                       /* Loop limit (for) */
double  forstep;                        /* Loop step (for) */
struct  control *control;               /* Control stack */
jmp_buf env;                            /* Saved state for errors */
int     intflag;                        /* Interrupt flag */

extern double  atof();
extern int     onintr();                       /* ^C catcher */
extern double  eval();
extern double  primary();
extern double  term();
extern struct  sym     *getsym();
extern struct  sym     *lookup();
extern struct  line    *alocline();

main()
{
        register c;

        setjmp(env);
#ifndef decus
        signal(SIGINT, &onintr);
#endif
        for (;;) {
                putchar('*');
                if (gets(cbuf) == NULL) {
                        putchar('\n');
                        break;
                }
                mode = C_TOP;
                clp  = NULL;
                ctp  = cbuf;
                if ((c=getnb()) != 0) {
                        if (isdigit(c))
                                inject(c);
                        else {
                                --ctp;
                                process();
                        }
                }
        }
}

process()
{
        double limit, step;
        double value;
        register c;
        register struct sym *sp;
        register struct line *lp;
        struct lno lno;
        struct line *lp1, *lp2, *lp3;
        int grp;

loop:
        if (intflag) {
                intflag = 0;
                diag("^C");
        }
        while ((c=getnb()) == ';')
                ;
        if (c == 0) {
                if (mode == C_FOR) {
                        forsp->s_un.s_value += forstep;
                        if (forstep>0.0 && forsp->s_un.s_value<=forlimit
                        ||  forstep<0.0 && forsp->s_un.s_value>=forlimit) {
                                clp = control->c_lp;
                                ctp = control->c_tp;
                                goto loop;
                        }
                        popfor();
                }
                if (clp != NULL) {
                        grp = clp->l_gno;
                        clp = clp->l_fp;
                        ctp = clp->l_text;
                }
                if (clp == NULL) {
                        if (mode == C_TOP)
                                return;
                        popdo();
                } else if (mode == C_DLINE
                || (mode==C_DGRP && grp!=clp->l_gno))
                        popdo();
                goto loop;
        }
        while (isalpha(*ctp))
                ++ctp;
        if (isupper(c))
                c = tolower(c);
        switch (c) {

        case 'a':
                do {
                        sp = getsym();
                        putchar(':');
                        if (gets(abuf) == NULL) {
                                putchar('\n');
                                diag("EOF in ask");
                        }
                        sp->s_un.s_value = atof(abuf);
                } while ((c=getnb()) == ',');
                --ctp;
                break;

        case 'c':
                while (*ctp != 0)
                        ++ctp;
                break;

        case 'd':
                getlno(&lno, -1);
                pushdo();
                if (lno.ln_type==LN_NONE || lno.ln_type==LN_ALL) {
                        if ((clp=line) == NULL)
                                diag("No program");
                        ctp = clp->l_text;
                        mode = C_DALL;
                        goto loop;
                }
                if (lno.ln_type == LN_GRP) {
                        lp = line;
                        while (lp!=NULL && lp->l_gno<lno.ln_gno)
                                lp = lp->l_fp;
                        if (lp!=NULL && lp->l_gno==lno.ln_gno) {
                                clp = lp;
                                ctp = clp->l_text;
                                mode = C_DGRP;
                                goto loop;
                        }
                        badline();
                }
                lp = line;
                while (lp != NULL
                && (lp->l_gno != lno.ln_gno
                ||  lp->l_lno != lno.ln_lno))
                        lp = lp->l_fp;
                if (lp != NULL) {
                        clp = lp;
                        ctp = clp->l_text;
                        mode = C_DLINE;
                        goto loop;
                }
                badline();

        case 'e':
                getlno(&lno, -1);
                if (lno.ln_type == LN_NONE) {
                        erasesyms();
                        break;
                }
                lp1 = NULL;
                lp2 = line;
                while (lp2 != NULL) {
                        if (lno.ln_type == LN_ALL
                        || (lp2->l_gno  == lno.ln_gno
                        && (lno.ln_type==LN_GRP || lp2->l_lno==lno.ln_lno))) {
                                if (lp2 == clp)
                                        diag("Erasing current line");
                                lp3 = lp2;
                                lp2 = lp2->l_fp;
                                if (lp1 == NULL)
                                        line = lp2; else
                                        lp1->l_fp = lp2;
                                free((char *) lp3);
                        } else {
                                lp1 = lp2;
                                lp2 = lp2->l_fp;
                        }
                }
                break;

        case 'f':
                sp = getsym();
                clearfors(sp);
                if (getnb() != '=')
                        diag("Missing = sign");
                sp->s_un.s_value = eval();
                if (getnb() != ',')
                        diag("Missing comma");
                limit = eval();
                if ((c=getnb()) == ';')
                        step = 1.0;
                else if (c == ',') {
                        step = eval();
                        if (getnb() != ';')
                                diag("Missing semi");
                } else
                        diag("Bad for");
                pushfor();
                forsp = sp;
                forlimit = limit;
                forstep = step;
                mode = C_FOR;
                break;

        case 'g':
                getlno(&lno, -1);
                if (lno.ln_type == LN_NONE) {
                        if ((clp=line) == NULL)
                                diag("No program");
                        ctp = clp->l_text;
                        goto loop;
                } else if (lno.ln_type == LN_LINE) {
                        lp = line;
                        while (lp != NULL
                        && (lp->l_gno != lno.ln_gno
                        ||  lp->l_lno != lno.ln_lno))
                                lp = lp->l_fp;
                        if (lp != NULL) {
                                clp = lp;
                                ctp = clp->l_text;
                                goto loop;
                        }
                }
                badline();

        case 'i':
                value = eval();
                if (value >= 0.0) {
                        while ((c = *ctp)!=0 && c!=',' && c!=';')
                                ++ctp;
                        if (c != ',')
                                goto loop;
                        ++ctp;
                        if (value != 0.0) {
                                while ((c = *ctp)!=0 && c!=',' && c!=';')
                                        ++ctp;
                                if (c != ',')
                                        goto loop;
                                ++ctp;
                        }
                }
                getlno(&lno, -1);
                if (lno.ln_type == LN_LINE) {
                        lp = line;
                        while (lp != NULL
                        && (lp->l_gno != lno.ln_gno
                        ||  lp->l_lno != lno.ln_lno))
                                lp = lp->l_fp;
                        if (lp != NULL) {
                                clp = lp;
                                ctp = clp->l_text;
                                goto loop;
                        }
                }
                badline();

        case 'l':
                library();
                break;

        case 'q':
                if (clp == NULL)
                        exit(0);
                return;

        case 't':
                type();
                break;

        case 'r':
                while (mode == C_FOR)
                        popfor();
                popdo();
                break;

        case 's':
                sp = getsym();
                if (getnb() != '=')
                        diag("Missing = sign");
                sp->s_un.s_value = eval();
                break;

        case 'w':
                getlno(&lno, -1);
                save(&lno, stdout);
                break;

        default:
                diag("Illegal command");
        }
        goto loop;
}

badline()
{
        diag("Bad line number");
}

pushdo()
{
        register struct control *cp;

        if ((cp=(struct control *)malloc(sizeof(struct control))) == NULL)
                diag("Out of space (control stack)");
        cp->c_fp = control;
        control  = cp;
        cp->c_mode = mode;
        cp->c_tp = ctp;
        cp->c_lp = clp;
}

pushfor()
{
        register struct control *cp;

        if ((cp=(struct control *)malloc(sizeof(struct control))) == NULL)
                diag("Out of space (control stack)");
        cp->c_fp = control;
        control  = cp;
        cp->c_mode = mode;
        cp->c_tp = ctp;
        cp->c_lp = clp;
        cp->c_sp = forsp;
        cp->c_limit = forlimit;
        cp->c_step = forstep;
}

popdo()
{
        register struct control *cp;

        if ((cp=control) == NULL)
                diag("Return not in do");
        control = cp->c_fp;
        ctp = cp->c_tp;
        clp = cp->c_lp;
        mode = cp->c_mode;
        free((char *) cp);
}

popfor()
{
        register struct control *cp;

        if ((cp=control) == NULL)
                diag("For stack botch");
        control = cp->c_fp;
        forsp = cp->c_sp;
        forlimit = cp->c_limit;
        forstep = cp->c_step;
        mode = cp->c_mode;
        free((char *) cp);
}

clearfors(sp)
register struct sym *sp;
{
        register struct control *cp1, *cp2;

        if (mode==C_FOR && forsp==sp)
                popfor();
        else {
                cp1 = NULL;
                cp2 = control;
                while (cp2 != NULL) {
                        if (cp2->c_mode==C_FOR && cp2->c_sp==sp) {
                                if (cp1 == NULL)
                                        control = cp2->c_fp; else
                                        cp1->c_fp = cp2->c_fp;
                                free((char *) cp2);
                                break;
                        }
                        cp1 = cp2;
                        cp2 = cp2->c_fp;
                }
        }
}

library()
{
        register char *p;
        register c, d;
        char *sctp;
        struct line *lp1, *lp2;
#ifdef  unix
        struct dir db;
        struct stat sb;
        int     fd;
#endif
        register FILE *fp;

        c = getnb();
        if (c!='c' && c!='s' && c!='l' && c!='d')
                diag("Bad library command");
        while (isalpha(*ctp))
                ++ctp;
        while ((d = *ctp)==' ' || d=='\t')
                ++ctp;
        if (c!='l' && d==0)
                diag("Missing file name");
        p = ctp;
        while (*ctp != 0)
                ++ctp;
        switch (c) {

        case 'c':
                if ((fp=fopen(p, "r")) == NULL)
                        diag("Cannot open");
                lp1 = line;
                while (lp1 != NULL) {
                        lp2 = lp1->l_fp;
                        free ((char *) lp1);
                        lp1 = lp2;
                }
                line = NULL;
                sctp = ctp;
                while (getline(abuf, fp) != 0) {
                        ctp = abuf;
                        if ((c=getnb()) != 0) {
                                if (isdigit(c) == 0)
                                        diag("Direct line in call");
                                inject(c);
                        }
                }
                fclose(fp);
                ctp = sctp;
                break;

#ifdef  unix
        case 'd':
                if (unlink(p) < 0)
                        diag("Cannot delete");
                break;

        case 'l':
                if (d == 0)
                        p = ".";
                if (stat(p, &sb) < 0
                || (sb.st_mode&S_IFMT) != S_IFDIR
                || (fd = open(p, 0)) < 0)
                        diag("Bad directory");
                while (read(fd, &db, sizeof(db)) == sizeof(db)) {
                        if (db.d_ino == 0
                        ||  strncmp(db.d_name, ".",  DIRSIZ) == 0
                        ||  strncmp(db.d_name, "..", DIRSIZ) == 0)
                                continue;
                        printf("%.*s\n", DIRSIZ, db.d_name);
                }
                close(fd);
                break;
#endif
        case 's':
                if ((fp=fopen(p, "w")) == NULL)
                        diag("Cannot create");
                save(NULL, fp);
                fclose(fp);
                break;
        }
}

inject(c)
register c;
{
        register struct line *lp1, *lp2, *lp3;
        register struct lno  lno;

        getlno(&lno, c);
        if (lno.ln_type != LN_LINE)
                diag("Illegal line number");
        lp1 = NULL;
        lp2 = line;
        while (lp2 != NULL
        && (lp2->l_gno < lno.ln_gno
        || (lp2->l_gno==lno.ln_gno&&lp2->l_lno<=lno.ln_lno))) {
                if (lp2->l_gno == lno.ln_gno
                &&  lp2->l_lno == lno.ln_lno) {
                        lp3 = lp2;
                        lp2 = lp2->l_fp;
                        if (lp1 == NULL)
                                line = lp2; else
                                lp1->l_fp = lp2;
                        free((char *) lp3);
                        break;
                }
                lp1 = lp2;
                lp2 = lp2->l_fp;
        }
        if ((c=getnb()) != 0) {
                lp3 = alocline(--ctp);
                lp3->l_fp  = lp2;
                lp3->l_gno = lno.ln_gno;
                lp3->l_lno = lno.ln_lno;
                strcpy(lp3->l_text, ctp);
                if (lp1 == NULL)
                        line = lp3; else
                        lp1->l_fp = lp3;
        }
}

getline(cp, fp)
register char *cp;
register FILE *fp;
{
        register c;

        while ((c=getc(fp))!=EOF && c!='\n')
                *cp++ = c;
        if (c == EOF)
                return (0);
        *cp = 0;
        return (1);
}

type()
{
        register char *fmt;
        register c;
        char fmtb[20];
        int x, y;

        fmt = "%6e";
        while ((c=getnb())!=0 && c!=';') {
                if (c == '%') {
                        if ((c=getnb())==0 || c==';' || c==',') {
                                fmt = "%6e";
                                --ctp;
                                continue;
                        }
                        x = getnum(c);
                        if (getnb() != '.')
                                diag("Missing . in format");
                        y = getnum(getnb());
                        sprintf(fmtb, "%%%d.%df", x, y);
                        fmt = fmtb;
                        continue;
                }
                if (c == ',')
                        continue;
                if (c == '!') {
                        putchar('\n');
                        continue;
                }
                if (c == '#') {
                        putchar('\r');
                        continue;
                }
                if (c == '"') {
                        while ((c = *ctp++)!='\0' && c!='"')
                                putchar(c);
                        if (c == '\0') {
                                diag("Missing string quote");
                                break;
                        }
                        continue;
                }
                --ctp;
                printf(fmt, eval());
        }
        --ctp;
}

save(lnop, fp)
register struct lno *lnop;
FILE *fp;
{
        struct lno lno;
        register struct line *lp;
        register tgroup, lgroup;

        if (lnop == NULL) {
                lno.ln_type = LN_ALL;
                lnop = &lno;
        }
        lp = line;
        if (lnop->ln_type!=LN_NONE && lnop->ln_type!=LN_ALL) {
                while (lp!=NULL && lp->l_gno<lnop->ln_gno)
                        lp = lp->l_fp;
                if (lp==NULL || lp->l_gno!=lnop->ln_gno)
                        diag("Line not found");
                if (lnop->ln_type == LN_LINE) {
                        while (lp!=NULL && lp->l_lno!=lnop->ln_lno)
                                lp = lp->l_fp;
                        if (lp == NULL)
                                diag("Line not found");
                }
        }
        while (lp != NULL) {
                putline(lp, fp);
                if (lnop->ln_type == LN_LINE)
                        break;
                lgroup = lp->l_gno;
                if ((lp = lp->l_fp) != NULL) {
                        tgroup = lp->l_gno;
                        if (lnop->ln_type==LN_GRP && tgroup!=lnop->ln_gno)
                                break;
                        if (tgroup != lgroup)
                                putc('\n', fp);
                }
        }
}

double
eval()
{
        double val, rop;
        register c;

        if ((c=getnb())=='+' || c=='-') {
                val = primary();
                if (c == '-')
                        val = -val;
        } else {
                --ctp;
                val = primary();
        }
        while ((c=getnb())=='+' || c=='-') {
                rop = primary();
                if (c == '+')
                        val = val + rop;
                else
                        val = val - rop;
        }
        --ctp;
        return (val);
}

double
primary()
{
        double val, rop;
        register c;

        val = term();
        while ((c = getnb())=='*' || c=='/') {
                rop = term();
                if (c == '*')
                        val = val * rop;
                else
                        val = val / rop;
        }
        --ctp;
        return (val);
}

double
term()
{
        register c;
        register char *cp;
        double val;
        int fsign, fdot, fexp;
        int term_type, subs;
        struct sym *sp;
        char id[NID];
        char nbuf[20];

        if ((c = getnb())=='(' || c=='[' || c=='<') {
                val = eval();
                if (++c != ')')
                        ++c;
                if (c != getnb())
                        diag("Mismatched enclosures");
                return (val);
        }
        if (c=='.' || isdigit(c)) {
                fsign = 1;
                fexp = 0;
                fdot = 0;
                if (c == '.')
                        ++fdot;
                cp = &nbuf[0];
                for (;;) {
                        if (cp >= &nbuf[19])
                                diag("Number too long");
                        *cp++ = c;
                        if ((c = *ctp++) == '.') {
                                if (fdot++)
                                        break;
                        } else if (c == 'e') {
                                if (fexp++)
                                        break;
                                fsign = 0;
                                fdot = 1;
                        } else if (c=='+' || c=='-') {
                                if (fsign++)
                                        break;
                        } else if (!isdigit(c))
                                break;
                }
                --ctp;
                *cp = '\0';
                return (atof(nbuf));
        }
        if (isalpha(c)) {
                cp = &id[0];
                do {
                        if (cp < &id[NID-1])
                                *cp++ = c;
                        c = *ctp++;
                } while (isalnum(c));
                *cp = 0;
                if (id[0] == 'f') {
                        /* ... */
                }
                term_type = S_SCAL;
                while (c==' ' || c=='\t')
                        c = *ctp++;
                if (c == '(') {
                        term_type = S_ARRAY;
                        subs = (int) eval();
                        if (getnb() != ')')
                                diag("Missing ) in subscript");
                } else
                        --ctp;
                if ((sp=lookup(id, term_type, subs)) == NULL)
                        diag("Undefined variable");
                return (sp->s_un.s_value);
        }
        diag("Expression syntax");
}

struct  sym *
lookup(id, lookup_type, subs)
char *id;
register lookup_type;
{
        register struct sym *sp;

        sp = sym;
        while (sp != NULL) {
                if (sp->s_type == lookup_type
                && (lookup_type!=S_ARRAY || sp->s_subs==subs)
                &&  strcmp(id, sp->s_id) == 0)
                        break;
                sp = sp->s_fp;
        }
        return (sp);
}

struct sym *
getsym()
{
        register c;
        char id[NID];
        register char *cp;
        register struct sym *sp;
        int subs, getsym_type;

        if (isalpha(c = getnb()) == 0)
                diag("Missing variable");
        cp = &id[0];
        do {
                if (cp < &id[NID-1])
                        *cp++ = c;
                c = *ctp++;
        } while (isalnum(c));
        *cp = 0;
        getsym_type = S_SCAL;
        while (c==' ' || c=='\t')
                c = *ctp++;
        if (c == '(') {
                getsym_type = S_ARRAY;
                subs = (int) eval();
                if (getnb() != ')')
                        diag("Bad subscript");
        } else
                --ctp;
        if ((sp=lookup(id, getsym_type, subs)) == NULL) {
                sp = (struct sym *)malloc(sizeof(*sp)+strlen(id)+1);
                if (sp == NULL)
                        diag("Out of space (symbols)");
                sp->s_fp = sym;
                sym = sp;
                sp->s_type = getsym_type;
                sp->s_subs = subs;
                strcpy(sp->s_id, id);
        }
        return (sp);
}

putline(lp, fp)
register struct line *lp;
FILE *fp;
{
        fprintf(fp, "%02d.%02d %s\n", lp->l_gno, lp->l_lno, lp->l_text);
}

static char badlno[] = "Bad line or group number";

getlno(lnop, c)
register struct lno *lnop;
register c;
{
        register gn, ln;

        if (c < 0)
                c = getnb();
        if (c=='\0' || c==';') {
                --ctp;
                lnop->ln_type = LN_NONE;
                return;
        }
        if (c=='A' || c=='a') {
                while (isalpha(*ctp))
                        ++ctp;
                lnop->ln_type = LN_ALL;
                return;
        }
        if (!isdigit(c))
                diag(badlno);
        if ((gn = getnum(c))<1 || gn>99)
                diag(badlno);
        if (*ctp != '.') {
                lnop->ln_gno = gn;
                lnop->ln_lno = 0;
                lnop->ln_type = LN_GRP;
                return;
        }
        ++ctp;
        if ((ln=getnum(*ctp++)) == 0) {
                lnop->ln_gno = gn;
                lnop->ln_lno = 0;
                lnop->ln_type = LN_GRP;
                return;
        }
        if (ln<1 | ln>99)
                diag(badlno);
        lnop->ln_gno = gn;
        lnop->ln_lno = ln;
        lnop->ln_type = LN_LINE;
}

getnum(c)
register c;
{
        register n;

        n = 0;
        while (isdigit(c)) {
                n = 10*n + c - '0';
                c = *ctp++;
        }
        --ctp;
        return (n);
}

struct line *
alocline(cp)
register char *cp;
{
        register struct line *lp;

        lp = (struct line *) malloc(sizeof(*lp)+strlen(cp)+1);
        if (lp == NULL)
                diag("Out of memory");
        return (lp);
}

diag(s)
char *s;
{
        register struct line *lp;
        register char *cp;

        printf("%s!\n", s);
        if ((lp=clp) != NULL) {
                putline(lp, stdout);
                printf("      ");
                cp = lp->l_text;
        } else {
                printf("*%s\n ", cbuf);
                cp = cbuf;
        }
        while (cp < ctp) {
                putchar(' ');
                ++cp;
        }
        printf("^\n");
        while (control != NULL)
                popdo();
        longjmp(env, 0);
}

getnb()
{
        register c;

        while ((c = *ctp++)==' ' || c=='\t')
                ;
        return (c);
}

onintr()
{
        ++intflag;
}

erasesyms()
{
        register struct sym *sp1, *sp2;

        sp1 = sym;
        sym = NULL;
        while (sp1 != NULL) {
                sp2 = sp1->s_fp;
                free((char *) sp1);
                sp1 = sp2;
        }
}

SHAR_EOF
:	End of shell archive
exit 0