/*
 * 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 <stat.h>
#include <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;
        }
}