-h- focal.h Thu Nov 10 09:18:27 1983 FOCAL.H;1 /* * Focal, 1981. * Dedicated to the old times, * when an 8k PDP-8 was considered * a BIG machine. * Data definitions and macros. */ #include #include #include #include #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_fp)(); /* Function pointer */ } s_un; char s_id[]; /* Name */ }; #define S_SCAL 0 /* Scalar */ #define S_ARRAY 1 /* An array */ #define S_FUNC 2 /* A function */ extern char cbuf[]; extern int intflag; extern char abuf[]; extern char *ctp; extern struct line *line; extern struct line *clp; extern struct sym *sym; extern int mode; extern struct sym *forsp; extern double forlimit; extern double forstep; extern struct control *control; extern jmp_buf env; extern double atof(); extern double sqrt(); extern double fsqt(); extern double fabs(); extern double fsgn(); extern double eval(); extern double primary(); extern double term(); extern struct sym *getsym(); extern struct sym *lookup(); extern struct line *alocline(); -h- focal0.c Thu Nov 10 09:18:27 1983 FOCAL0.C;7 /* * Focal, 1981. * Dedicated to the old times, * when an 8k PDP-8 was considered * a BIG machine. * Driver and command handler. */ /*)BUILD $(PROGRAM) = focal $(INCLUDE) = focal.h $(FILES) = { focal0.c focal1.c focal2.c focal3.c } $(ATOD) = 1 $(DTOA) = 1 */ #ifdef DOCUMENTATION title focal Ancient Interpretive Language index Ancient Interpretive Language synopsis focal description Focal is a block-structured interpretive language. It is described in the PDP-8 "Introduction to Programming." There is also a PDP-11 Focal manual. This version of focal runs on Vax/VMS and Unix. author Dave Conroy #endif #include "focal.h" #ifdef vms #include #include #define IO_SUCCESS SS$_NORMAL #define IO_ERROR (STS$M_INHIB_MSG | SS$_ABORT) #else #ifndef IO_SUCCESS #define IO_SUCCESS 0 #endif #ifndef IO_ERROR #define IO_ERROR 1 #endif #endif 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 */ main() { register int c; /* builtin("fsqt", &fsqt); builtin("fabs", &fabs); builtin("fsgn", &fsgn); builtin("fitr", &fitr); builtin("fran", &fran); */ setjmp(env); catchcc(); 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(); } } } } /* * Handcraft the symbol table * entry for a builtin function. Used * at initialization time, to jam * the functions into the table, and * never used again! */ builtin(cp, fp) char *cp; double (*fp)(); { register struct sym *sp; sp = (struct sym *)malloc(sizeof(*sp)+strlen(cp)+1); if (sp == NULL) { fprintf(stderr, "No memory for %s\n", cp); exit(IO_ERROR); } sp->s_fp = sym; sym = sp; sp->s_type = S_FUNC; sp->s_subs = 0; sp->s_un.s_fp = fp; strcpy(sp->s_id, cp); } /* * This is the line evaluator. It runs * the do/for/return stack, checks for interrupts * and calls the required subfunctions to get * the focal commands executed. */ process() { double limit, step; double value; register int 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': ask(); 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_gnol_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(IO_SUCCESS); 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; } /* * Process the ask command. * The "ask" has already been read in. * The funny altmode thing, where a variable * is left unchanged, is not implemented. * The input expression must be a legal floating * point number, although no checking is done. */ ask() { register struct sym *sp; register int c; while ((c=getnb())!=0 && c!=';') { if (c == '"') { while ((c = *ctp++)!=0 && c!='"') putchar(c); if (c != 0) continue; diag("Missing `\"' in ask"); } if (c == ',') continue; --ctp; sp = getsym(); printf(": "); if (gets(abuf) == NULL) { putchar('\n'); diag("EOF in ask"); } sp->s_un.s_value = atof(abuf); } --ctp; } /* * Complain about bad line * numbers. Used all over the place. */ badline() { diag("Bad line number"); } /* * Push an entry onto the * control stack in "do" statement * format. */ 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; } /* * Push an entry onto the control * stack in "for" statement format. This * differs from "do" statement format in * that the loop variables are saved. */ 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; } /* * Pop a "do" format entry from * the control stack, restoring all of the * global variables. */ 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); } /* * Pop a "for" format item from the * control stack, restoring all the global * variables. */ 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); } /* * Dig in the control stack, * looking for "for" stack entries that * are controlling the variable whose symbol * table entry is pointed to by `sp'. Rip * them out. This makes everything work out * if you "go" out of a loop and then "for" * on the same variable. */ clearfors(sp) register struct sym *sp; { register struct control *cp1; register struct control *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; } } } /* * Inject a line of text, stored in * the normal command line buffer, into the * saved indirect program. The argument `c' * is the first character of the line * number, which is assumed to be valid. */ inject(c) register int c; { register struct line *lp1; register struct line *lp2; register struct line *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 `\"' in type"); 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_gnoln_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); } } } erasesyms() { register struct sym *sp1, *sp2; sp1 = sym; sym = NULL; while (sp1 != NULL) { sp2 = sp1->s_fp; free((char *) sp1); sp1 = sp2; } } -h- focal1.c Thu Nov 10 09:18:27 1983 FOCAL1.C;1 /* * Focal, 1981. * Expression evaluation. */ #include "focal.h" /* * Evaluate an expression. */ double eval() { double val; double rop; register int 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; double rop; register int c; val = term(); while ((c = getnb())=='*' || c=='/') { rop = term(); if (c == '*') val = val * rop; else val = val / rop; } --ctp; return (val); } double term() { register int c; register char *cp; double val; register int fsign; register int fdot; register int fexp; register int type; register int subs; register 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' && (sp=lookup(id, S_FUNC, 0))!=NULL) { while (c==' ' || c=='\t') c = *ctp++; if (c != '(') diag("Missing `(' for function"); val = eval(); if (getnb() != ')') diag("Missing `)' for function"); return ((*sp->s_un.s_fp)(val)); } */ type = S_SCAL; while (c==' ' || c=='\t') c = *ctp++; if (c == '(') { type = S_ARRAY; subs = (int) eval(); if (getnb() != ')') diag("Missing ) in subscript"); } else --ctp; if ((sp=lookup(id, type, subs)) == NULL) diag("Undefined variable"); return (sp->s_un.s_value); } diag("Expression syntax"); } struct sym * lookup(id, type, subs) char *id; register type; { register struct sym *sp; sp = sym; while (sp != NULL) { if (sp->s_type == type && (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, 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; type = S_SCAL; while (c==' ' || c=='\t') c = *ctp++; if (c == '(') { type = S_ARRAY; subs = (int) eval(); if (getnb() != ')') diag("Bad subscript"); } else --ctp; if ((sp=lookup(id, 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 = type; sp->s_subs = subs; strcpy(sp->s_id, id); } return (sp); } /* double fsqt(arg) double arg; { if (arg < 0.0) diag("Fsqt < 0.0"); return (sqrt(arg)); } */ double fabs(arg) double arg; { if (arg < 0) return (-arg); return (arg); } double fsgn(arg) double arg; { if (arg < 0) return (-1.0); if (arg == 0) return (0.0); return (1.0); } -h- focal2.c Thu Nov 10 09:18:27 1983 FOCAL2.C;3 /* * Focal, 1981. * Operating system dependent code. * Most has something to do with the syntax of * a file name or the format of the directory of the * disc; most of this is in the library command. */ #include "focal.h" /* * Process the library command. * This command (sadly) requires a rather * detailed knowledge of the file system of * the operating system. */ library() { register char *p; register int c; register int d; register char *sctp; register struct line *lp1; register struct line *lp2; register 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; case 'd': #ifdef vax if (delete(p) < 0) #else if (unlink(p) < 0) #endif diag("Cannot delete"); break; case 'l': #ifdef vax diag("Library list not implemented"); #else 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); #endif break; case 's': if ((fp=fopen(p, "w")) == NULL) diag("Cannot create"); save(NULL, fp); fclose(fp); break; } } /* * Set up to catch the user's * ^C interrupt. */ catchcc() { int onintr(); signal(SIGINT, &onintr); } /* * This routine is called by * the ^C signal handler. All it does * is set a flag, which is looked at * by the dispatcher. */ onintr() { ++intflag; } -h- focal3.c Thu Nov 10 09:18:27 1983 FOCAL3.C;1 /* * Focal, 1981. * A number of small routines that * don't go anywhere else. */ #include "focal.h" /* * Put out the text line * pointed to by `lp' to the FILE * pointed to by `fp'. * Used any time a source line is * printed. */ putline(lp, fp) register struct line *lp; FILE *fp; { fprintf(fp, "%02d.%02d %s\n", lp->l_gno, lp->l_lno, lp->l_text); } /* * Get a line number. * The `c' argument is the first * character, and is assumed to be ok. * The line number, along with its general * shape, is packed into the structure * pointed to by `lnop'. */ getlno(lnop, c) register struct lno *lnop; register c; { register gn, ln; static char badlno[] = "Bad line or group number"; 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; } /* * Get a number. The argument * `c' is the first character of the * number, and is assumed to be valid. * Return the number read. */ getnum(c) register c; { register n; n = 0; while (isdigit(c)) { n = 10*n + c - '0'; c = *ctp++; } --ctp; return (n); } /* * Allocate a new line, with a * data array large enough to hold the * string pointed to by `cp'. * The line and group number fields are * not filled in. * Return a pointer to the line. */ 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); } /* * Print a diagnostic. The `s' * argument is an error message. The * offending line is displayed, with a flag * at the point where the scan failed. * This routine does not return; it just * does a non local goto back to the command * dispatcher. */ 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); } /* * Get the next non blank * character from the current source line. * Return it. */ getnb() { register c; while ((c = *ctp++)==' ' || c=='\t') ; return (c); }