v23i098: ABC interactive programming environment, Part19/25
Rich Salz
rsalz at bbn.com
Thu Dec 20 04:54:42 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 98
Archive-name: abc/part19
#! /bin/sh
# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to comp-sources-unix at uunet.uu.net if you want that tool.
# Contents: abc/bed/e1edit.c abc/bed/e1goto.c abc/bed/e1wide.c
# abc/bint2/i2dis.c abc/bint3/i3typ.c abc/bio/i4rec.c
# abc/btr/i1btr.h abc/tc/termcap.c
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:28:16 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
echo If this archive is complete, you will see the following message:
echo ' "shar: End of archive 19 (of 25)."'
if test -f 'abc/bed/e1edit.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1edit.c'\"
else
echo shar: Extracting \"'abc/bed/e1edit.c'\" \(7312 characters\)
sed "s/^X//" >'abc/bed/e1edit.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Read unit from file.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "feat.h"
X#include "bmem.h"
X#include "erro.h"
X#include "bobj.h"
X#include "node.h"
X#include "tabl.h"
X#include "gram.h"
X#include "supr.h"
X#include "queu.h"
X
X#define TABSIZE 8
X#define MAXLEVEL 128
Xstatic short *indent;
Xstatic int level;
X
X/*
X * Read (edit) parse tree from file into the focus.
X * Rather ad hoc, we use ins_string for each line
X * and do some magic tricks to get the indentation right
X * (most of the time).
X * If line > 0, position the focus at that line, if possible;
X * otherwise the focus is left at the end of the inserted text.
X */
X
XVisible bool
Xreadfile(ep, filename, line, creating)
X register environ *ep;
X string filename;
X int line;
X bool creating;
X{
X
X int lines = 0;
X register FILE *fp = fopen(filename, "r");
X register int c;
X string buf;
X auto string cp;
X auto queue q = Qnil;
X
X if (!fp) {
X ederrS(MESS(6200, "Sorry, I can't edit file \"%s\""), filename);
X return No;
X }
X
X buf= (string) getmem(BUFSIZ);
X if (indent == NULL) {
X indent= (short*) getmem((unsigned) (MAXLEVEL * sizeof(short)));
X }
X
X level= 0;
X indent[0]= 0;
X
X do {
X do {
X for (cp = buf; cp < buf + BUFSIZ - 1; ++cp) {
X c = getc(fp);
X if (c == EOF || c == '\n')
X break;
X if (c < ' ' || c >= 0177)
X c = ' ';
X *cp = c;
X }
X if (cp > buf) {
X *cp = 0;
X if (!ins_string(ep, buf, &q, 0) || !emptyqueue(q)) {
X qrelease(q);
X fclose(fp);
X freemem((ptr) buf);
X return No;
X }
X qrelease(q);
X }
X } while (c != EOF && c != '\n');
X ++lines;
X if (c != EOF && !editindentation(ep, fp)) {
X fclose(fp);
X freemem((ptr) buf);
X return No;
X }
X } while (c != EOF);
X freemem((ptr) buf);
X fclose(fp);
X if (ep->mode == FHOLE || ep->mode == VHOLE && (ep->s1&1)) {
X cp = "";
X VOID soften(ep, &cp, 0);
X }
X if (lines > 1 && line > 0) {
X if (line >= lines) line= lines-1;
X VOID gotoyx(ep, line-1, 0);
X oneline(ep);
X }
X if (creating)
X ins_newline(ep);
X return Yes;
X}
X
X
X/*
X * Do all the footwork required to get the indentation proper.
X */
X
XHidden Procedure
Xeditindentation(ep, fp)
X register environ *ep;
X register FILE *fp;
X{
X register int ind= 0;
X register int c;
X
X for (;;) {
X c= getc(fp);
X
X if (c == ' ')
X ++ind;
X else if (c == '\t')
X ind= (ind/TABSIZE + 1) * TABSIZE;
X else
X break;
X }
X ungetc(c, fp);
X if (c == EOF || c == '\n')
X return Yes;
X if (ind > indent[level]) {
X if (level == MAXLEVEL-1) {
X ederr(MESS(6201, "excessively nested indentation"));
X return No;
X }
X indent[++level]= ind;
X }
X else if (ind < indent[level]) {
X while (level > 0 && ind <= indent[level-1])
X --level;
X if (ind != indent[level]) {
X ederr(MESS(6202, "indentation messed up"));
X return No;
X }
X }
X if (!ins_newline(ep)) {
X#ifndef NDEBUG
X debug("[Burp! Can't insert a newline.]");
X#endif /* NDEBUG */
X return No;
X }
X if (level > Level(ep->focus)) {
X ederr(MESS(6203, "unexpected indentation increase"));
X return No;
X }
X while (level < Level(ep->focus)) {
X if (!ins_newline(ep)) {
X#ifndef NDEBUG
X debug("[Burp, burp! Can't decrease indentation.]");
X#endif /* NDEBUG */
X return No;
X }
X }
X fixit(ep);
X return Yes;
X}
X
X/* ------------------------------------------------------------ */
X
X#ifdef SAVEBUF
X
X/*
X * Read the next non-space character.
X */
X
XHidden int
Xskipspace(fp)
X register FILE *fp;
X{
X register int c;
X
X do {
X c = getc(fp);
X } while (c == ' ');
X return c;
X}
X
X
X/*
X * Read a text in standard B format when the initial quote has already
X * been read.
X */
X
XHidden value
Xreadtext(fp, quote)
X register FILE *fp;
X register char quote;
X{
X auto value v = Vnil;
X char buf[BUFSIZ];
X register string cp = buf;
X register int c;
X auto int i;
X value w;
X
X for (; ; ++cp) {
X c = getc(fp);
X if (!isascii(c) || c != ' ' && !isprint(c)) {
X#ifndef NDEBUG
X if (c == EOF)
X debug("readtext: EOF");
X else
X debug("readtext: bad char (0%02o)", c);
X#endif /* NDEBUG */
X release(v);
X return Vnil; /* Bad character or EOF */
X }
X if (c == quote) {
X c = getc(fp);
X if (c != quote) {
X ungetc(c, fp);
X break;
X }
X }
X else if (c == '`') {
X c = skipspace(fp);
X if (c == '$') {
X i = 0;
X if (fscanf(fp, "%d", &i) != 1
X || i == 0 || !isascii(i)) {
X#ifndef NDEBUG
X debug("readtext: error in conversion");
X#endif /* NDEBUG */
X release(v);
X return Vnil;
X }
X c = skipspace(fp);
X }
X else
X i = '`';
X if (c != '`') {
X#ifndef NDEBUG
X if (c == EOF)
X debug("readtext: EOF in conversion");
X else
X debug("readtext: bad char in conversion (0%o)", c);
X#endif /* NDEBUG */
X release(v);
X return Vnil;
X }
X c = i;
X }
X if (cp >= &buf[sizeof buf - 1]) {
X *cp = 0;
X w= mk_etext(buf);
X if (v) {
X e_concto(&v, w);
X release(w);
X }
X else
X v = w;
X cp = buf;
X }
X *cp = c;
X }
X *cp = 0;
X w= mk_etext(buf);
X if (!v)
X return w;
X e_concto(&v, w);
X release(w);
X return v;
X}
X
X
XHidden int
Xreadsym(fp)
X register FILE *fp;
X{
X register int c;
X char buf[100];
X register string bufp;
X
X for (bufp = buf; ; ++bufp) {
X c = getc(fp);
X if (c == EOF)
X return -1;
X if (!isascii(c) || !isalnum(c) && c != '_') {
X if (ungetc(c, fp) == EOF)
X syserr(MESS(6204, "readsym: ungetc failed"));
X break;
X }
X *bufp = c;
X }
X *bufp = 0;
X if (isdigit(buf[0]))
X return atoi(buf);
X if (strcmp(buf, "Required") == 0) /***** Compatibility hack *****/
X return Hole;
X return nametosym(buf);
X}
X
X
X/*
X * Read a node in internal format (recursively).
X * Return nil pointer if EOF or error.
X */
X
XHidden node
Xreadnode(fp)
X FILE *fp;
X{
X int c;
X int nch;
X node ch[MAXCHILD];
X node n;
X int sym;
X
X c = skipspace(fp);
X switch (c) {
X case EOF:
X return Nnil; /* EOF hit */
X
X case '(':
X sym = readsym(fp);
X if (sym < 0) {
X#ifndef NDEBUG
X debug("readnode: missing symbol");
X#endif /* NDEBUG */
X return Nnil; /* No number as first item */
X }
X if (sym < 0 || sym > Hole) {
X#ifndef NDEBUG
X debug("readnode: bad symbol (%d)", sym);
X#endif /* NDEBUG */
X return Nnil;
X }
X nch = 0;
X while ((c = skipspace(fp)) == ',' && nch < MAXCHILD) {
X n = readnode(fp);
X if (!n) {
X for (; nch > 0; --nch)
X noderelease(ch[nch-1]);
X return Nnil; /* Error encountered in child */
X }
X ch[nch] = n;
X ++nch;
X }
X if (c != ')') {
X#ifndef NDEBUG
X if (c == ',')
X debug("readnode: node too long (sym=%d)", sym);
X else
X debug("readnode: no ')' where expected (sym=%d)", sym);
X#endif /* NDEBUG */
X for (; nch > 0; --nch)
X noderelease(ch[nch-1]);
X return Nnil; /* Not terminated with ')' or too many children */
X }
X if (nch == 0)
X return gram(sym); /* Saves space for Optional/Hole nodes */
X return newnode(nch, sym, ch);
X
X case '\'':
X case '"':
X return (node) readtext(fp, c);
X
X default:
X#ifndef NDEBUG
X debug("readnode: bad initial character");
X#endif /* NDEBUG */
X return Nnil; /* Bad initial character */
X }
X}
X
X
X/*
X * Read a node written in a more or less internal format.
X */
X
XVisible value
Xeditqueue(filename)
X string filename;
X{
X register FILE *fp = fopen(filename, "r");
X auto queue q = Qnil;
X register node n;
X
X if (!fp)
X return Vnil;
X do {
X n = readnode(fp);
X if (!n)
X break; /* EOF or error */
X addtoqueue(&q, n);
X noderelease(n);
X } while (skipspace(fp) == '\n');
X fclose(fp);
X return (value)q;
X}
X
X#endif /* SAVEBUF */
END_OF_FILE
if test 7312 -ne `wc -c <'abc/bed/e1edit.c'`; then
echo shar: \"'abc/bed/e1edit.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1edit.c'
fi
if test -f 'abc/bed/e1goto.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1goto.c'\"
else
echo shar: Extracting \"'abc/bed/e1goto.c'\" \(5725 characters\)
sed "s/^X//" >'abc/bed/e1goto.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Random access focus positioning.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "feat.h"
X#include "bobj.h"
X#include "erro.h"
X#include "node.h"
X#include "gram.h"
X#include "supr.h"
X
Xextern int winheight;
Xextern int winstart;
X
X
X#define BEFORE (-1)
X#define INSIDE 0
X#define BEYOND 1
X
X
X#ifdef GOTOCURSOR
X
X/*
X * Random cursor positioning (e.g., with a mouse).
X */
X
Xextern bool nosense;
X
XVisible bool
Xgotocursor(ep)
X environ *ep;
X{
X int y;
X int x;
X
X if (nosense) {
X while (narrow(ep))
X ;
X if (ep->mode == ATEND)
X leftvhole(ep);
X y = lineno(ep);
X x = colno(ep);
X }
X else if (sense(&y, &x)) {
X#ifdef SCROLLBAR
X if (y == winheight)
X return gotoscrollbar(ep, x);
X#endif /* SCROLLBAR */
X if (!backtranslate(&y, &x))
X return No;
X }
X else { /* sense() of cursor or mouse failed */
X return No;
X }
X if (!gotoyx(ep, y, x))
X return No;
X gotofix(ep, y, x);
X return Yes;
X}
X
X#ifdef SCROLLBAR
X
X/*
X * Special case for goto: user pointed at some point in the scroll bar.
X * Go directly to the corresponding line.
X * (The scroll bar is only present when winstart == 0; it extends from
X * col 0 to winheight-1 inclusive.)
X */
X
XHidden bool
Xgotoscrollbar(ep, x)
X environ *ep;
X int x;
X{
X int w;
X
X if (winstart != 0 || x >= winheight) { /* Not within scroll bar */
X ederr(GOTO_OUT);
X return No;
X }
X top(&ep->focus);
X ep->mode = WHOLE;
X higher(ep);
X w = nodewidth(tree(ep->focus));
X if (w >= 0)
X w = 1;
X else
X w = 1-w;
X if (!gotoyx(ep, x * w / winheight, 0))
X return No;
X oneline(ep);
X return Yes;
X}
X
X#endif /* SCROLLBAR */
X
X#endif /* GOTOCURSOR */
X
X/*
X * Set the focus to the smallest node or subset surrounding
X * the position (y, x).
X */
X
XVisible bool
Xgotoyx(ep, y, x)
X register environ *ep;
X register int y;
X register int x;
X{
X register node n;
X register string *rp;
X register int i;
X register int pc;
X
X ep->mode = WHOLE;
X while ((pc = poscomp(ep->focus, y, x)) != INSIDE) {
X if (!up(&ep->focus)) {
X if (pc == BEFORE)
X ep->mode = ATBEGIN;
X else
X ep->mode = ATEND;
X higher(ep);
X return No;
X }
X }
X higher(ep);
X for (;;) {
X switch (poscomp(ep->focus, y, x)) {
X
X case BEFORE:
X i = ichild(ep->focus);
X n = tree(parent(ep->focus)); /* Parent's !!! */
X rp = noderepr(n);
X if (Fw_positive(rp[i-1])) {
X s_up(ep);
X ep->s1 = ep->s2 = 2*i - 1;
X ep->mode = SUBSET;
X }
X else if (left(&ep->focus))
X ep->mode = ATEND;
X else
X ep->mode = ATBEGIN;
X return Yes;
X
X case INSIDE:
X n = tree(ep->focus);
X if (nchildren(n) >= 1 && !Is_etext(firstchild(n))) {
X s_down(ep);
X continue;
X }
X ep->mode = WHOLE;
X return Yes;
X
X case BEYOND:
X if (rite(&ep->focus))
X continue;
X n = tree(parent(ep->focus)); /* Parent's !!! */
X rp = noderepr(n);
X i = ichild(ep->focus);
X if (Fw_positive(rp[i])) {
X s_up(ep);
X ep->s1 = ep->s2 = 2*i + 1;
X ep->mode = SUBSET;
X }
X else
X ep->mode = ATEND;
X return Yes;
X
X default:
X Abort();
X /* NOTREACHED */
X
X }
X }
X}
X
X
X/*
X * Deliver relative position of (y, x) with respect to focus p:
X * BEFORE: (y, x) precedes focus;
X * INSIDE: (y, x) contained in focus;
X * EAFTER: (y, x) follows focus.
X
X */
X
XHidden int
Xposcomp(p, y, x)
X register path p;
X register int y;
X register int x;
X{
X register int ly;
X register int lx;
X register int w;
X register string *rp;
X register node n;
X
X ly = Ycoord(p);
X lx = Xcoord(p);
X if (y < ly || y == ly && (lx < 0 || x < lx))
X return BEFORE;
X n = tree(p);
X w = nodewidth(n);
X if (w < 0) {
X if (y == ly) { /* Hack for position beyond end of previous line */
X rp = noderepr(n);
X if (Fw_negative(rp[0]))
X return BEFORE;
X }
X ly += -w;
X lx = -1;
X }
X else {
X if (lx >= 0)
X lx += w;
X }
X if (y < ly || y == ly && (lx < 0 || x < lx))
X return INSIDE;
X return BEYOND;
X}
X
X
X/*
X * Position focus exactly at character indicated by (y, x) if possible.
X * If this is the start of something larger, position focus at largest
X * object starting here.
X */
X
XVisible Procedure
Xgotofix(ep, y, x)
X environ *ep;
X int y;
X int x;
X{
X int fx;
X int fy;
X int len;
X string repr;
X
X switch (ep->mode) {
X
X case ATBEGIN:
X case ATEND:
X return; /* No change; the mouse pointed in the margin. */
X
X case SUBSET:
X if (ep->s1 > 1) {
X fx = Xcoord(ep->focus);
X fy = Ycoord(ep->focus);
X len = focoffset(ep);
X if (len < 0 || fy != y)
X return;
X if ((ep->s1&1) && fx + len >= x-1) {
X string *nr= noderepr(tree(ep->focus));
X repr = nr[ep->s1/2];
X if ((repr && repr[0] == ' ') != (fx + len == x))
X return;
X }
X else if (fx + len == x)
X return;
X }
X ep->mode = WHOLE;
X /* Fall through */
X case WHOLE:
X fx = Xcoord(ep->focus);
X fy = Ycoord(ep->focus);
X if (y != fy)
X return;
X if (x <= fx ) {
X for (;;) {
X if (ichild(ep->focus) > 1)
X break;
X if (!up(&ep->focus))
X break;
X repr = noderepr(tree(ep->focus))[0];
X if (!Fw_zero(repr)) {
X s_down(ep);
X break;
X }
X higher(ep);
X }
X if (issublist(symbol(tree(ep->focus))))
X fixsublist(ep);
X return;
X }
X fixfocus(ep, x - fx);
X ritevhole(ep);
X switch(ep->mode) {
X case VHOLE:
X len = nodewidth(tree(ep->focus));
X break;
X case FHOLE:
X {
X string *nr= noderepr(tree(ep->focus));
X len = fwidth(nr[ep->s1/2]);
X }
X break;
X default:
X return;
X }
X if (ep->s2 < len) {
X ep->mode = SUBRANGE;
X ep->s3 = ep->s2;
X }
X return;
X
X default:
X Abort();
X }
X}
X
X
X/*
X * Refinement for gotofix -- don't show right sublist of something.
X */
X
XHidden Procedure
Xfixsublist(ep)
X environ *ep;
X{
X path pa = parent(ep->focus);
X node n;
X
X if (!pa)
X return;
X n = tree(pa);
X if (nchildren(n) > ichild(ep->focus))
X return;
X if (samelevel(symbol(n), symbol(tree(ep->focus)))) {
X ep->mode = SUBLIST;
X ep->s3 = 1;
X }
X}
END_OF_FILE
if test 5725 -ne `wc -c <'abc/bed/e1goto.c'`; then
echo shar: \"'abc/bed/e1goto.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1goto.c'
fi
if test -f 'abc/bed/e1wide.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1wide.c'\"
else
echo shar: Extracting \"'abc/bed/e1wide.c'\" \(5769 characters\)
sed "s/^X//" >'abc/bed/e1wide.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Commands to make the focus larger and smaller in various ways.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "bobj.h"
X#include "node.h"
X#include "supr.h"
X#include "gram.h"
X#include "tabl.h"
X
X/*
X * Widen -- make the focus larger.
X */
X
XVisible bool
Xwiden(ep, deleting)
X register environ *ep;
X bool deleting;
X{
X register node n;
X register node nn;
X register int sym;
X register int ich;
X
X higher(ep);
X grow(ep, deleting);
X
X n = tree(ep->focus);
X sym = symbol(n);
X if (ep->mode == VHOLE && (ep->s1&1))
X ep->mode = FHOLE;
X
X switch (ep->mode) {
X
X case ATBEGIN:
X case ATEND:
X /* Shouldn't occur after grow(ep) */
X ep->mode = WHOLE;
X return Yes;
X
X case VHOLE:
X if (ep->s2 >= lenitem(ep))
X --ep->s2;
X ep->mode = SUBRANGE;
X ep->s3 = ep->s2;
X return Yes;
X
X case FHOLE:
X if (ep->s2 >= lenitem(ep)) {
X if (ep->s2 > 0)
X --ep->s2;
X else {
X leftvhole(ep);
X switch (ep->mode) {
X case ATBEGIN:
X case ATEND:
X ep->mode = WHOLE;
X return Yes;
X case VHOLE:
X case FHOLE:
X if (ep->s2 >= lenitem(ep)) {
X if (ep->s2 == 0) {
X#ifndef NDEBUG
X debug("[Desperate in widen]");
X#endif /* NDEBUG */
X ep->mode = SUBSET;
X ep->s2 = ep->s1;
X return widen(ep, deleting);
X }
X --ep->s2;
X }
X ep->mode = SUBRANGE;
X ep->s3 = ep->s2;
X return Yes;
X }
X Abort();
X }
X }
X ep->mode = SUBRANGE;
X ep->s3 = ep->s2;
X return Yes;
X
X case SUBRANGE:
X ep->mode = SUBSET;
X ep->s2 = ep->s1;
X return Yes;
X
X case SUBSET:
X if (!issublist(sym)) {
X ep->mode = WHOLE;
X return Yes;
X }
X nn= lastchild(n);
X if (nodewidth(nn) == 0) {
X ep->mode = WHOLE;
X return Yes;
X }
X if (ep->s2 < 2*nchildren(n)) {
X ep->mode = SUBLIST;
X ep->s3 = 1;
X return Yes;
X }
X /* Fall through */
X case SUBLIST:
X for (;;) {
X ich = ichild(ep->focus);
X if (!up(&ep->focus)) {
X ep->mode = WHOLE;
X return Yes;
X }
X higher(ep);
X n = tree(ep->focus);
X if (ich != nchildren(n) || !samelevel(sym, symbol(n))) {
X ep->mode = SUBSET;
X ep->s1 = ep->s2 = 2*ich;
X return Yes;
X }
X }
X /* Not reached */
X
X case WHOLE:
X ich = ichild(ep->focus);
X if (!up(&ep->focus))
X return No;
X n = tree(ep->focus);
X if (issublist(symbol(n)) && ich < nchildren(n)) {
X ep->mode = SUBLIST;
X ep->s3 = 1;
X }
X return Yes;
X
X default:
X Abort();
X /* NOTREACHED */
X }
X /* Not reached */
X}
X
X
X/*
X * Narrow -- make the focus smaller.
X */
X
XVisible bool
Xnarrow(ep)
X register environ *ep;
X{
X register node n;
X register int sym;
X register int nch;
X register string repr;
X
X higher(ep);
X
X shrink(ep);
X n = tree(ep->focus);
X sym = symbol(n);
X
X switch (ep->mode) {
X
X case ATBEGIN:
X case ATEND:
X case VHOLE:
X case FHOLE:
X return No;
X
X case SUBRANGE:
X if (ep->s3 > ep->s2)
X ep->s3 = ep->s2;
X else
X ep->mode = (ep->s1&1) ? FHOLE : VHOLE;
X return Yes;
X
X case SUBSET:
X if (ep->s1 <= 2) {
X nch = nchildren(n);
X if (ep->s2 >= 2*nch && issublist(symbol(n))) {
X if (ep->s1 <= 1) {
X ep->s2 = 2*nch - 1;
X return Yes;
X }
X repr = noderepr(n)[0];
X if (!Fw_positive(repr)) {
X ep->s2 = 2*nch - 1;
X return Yes;
X }
X }
X }
X ep->s2 = ep->s1;
X return Yes;
X
X case SUBLIST:
X Assert(ep->s3 > 1);
X ep->s3 = 1;
X return Yes;
X
X case WHOLE:
X Assert(sym == Hole || sym == Optional);
X return No;
X
X default:
X Abort();
X /* NOTREACHED */
X }
X}
X
X
XVisible bool
Xextend(ep)
X register environ *ep;
X{
X register node n;
X register int i;
X register int len;
X register int s1save;
X int sym;
X
X grow(ep, No);
X higher(ep);
X switch (ep->mode) {
X
X case VHOLE:
X case FHOLE:
X case ATBEGIN:
X case ATEND:
X return widen(ep, No);
X
X case SUBRANGE:
X len = lenitem(ep);
X if (ep->s3 < len-1)
X ++ep->s3;
X else if (ep->s2 > 0)
X --ep->s2;
X else {
X ep->mode = SUBSET;
X ep->s2 = ep->s1;
X return extend(ep); /* Recursion! */
X }
X return Yes;
X
X case SUBSET:
X s1save = ep->s1;
X ep->s1 = ep->s2;
X if (nextnnitem(ep)) {
X ep->s2 = ep->s1;
X ep->s1 = s1save;
X }
X else {
X ep->s1 = s1save;
X if (!prevnnitem(ep)) Abort();
X }
X if (ep->s1 == 1
X && ((sym= symbol(n= tree(ep->focus))) == Test_suite
X || sym == Refinement)
X && ep->s2 == 3)
X {
X oneline(ep);
X }
X
X return Yes;
X
X case WHOLE:
X return up(&ep->focus);
X
X case SUBLIST:
X n = tree(ep->focus);
X for (i = ep->s3; i > 1; --i)
X n = lastchild(n);
X if (samelevel(symbol(n), symbol(lastchild(n)))) {
X ++ep->s3;
X return Yes;
X }
X ep->mode = WHOLE;
X if (symbol(lastchild(n)) != Optional)
X return Yes;
X return extend(ep); /* Recursion! */
X
X default:
X Abort();
X /* NOTREACHED */
X }
X}
X
X
X/*
X * Right-Narrow -- make the focus smaller, going to the last item of a list.
X */
X
XVisible bool
Xrnarrow(ep)
X register environ *ep;
X{
X register node n;
X register node nn;
X register int i;
X register int sym;
X
X higher(ep);
X
X shrink(ep);
X n = tree(ep->focus);
X sym = symbol(n);
X if (sym == Optional || sym == Hole)
X return No;
X
X switch (ep->mode) {
X
X case ATBEGIN:
X case ATEND:
X case VHOLE:
X case FHOLE:
X return No;
X
X case SUBRANGE:
X if (ep->s3 > ep->s2)
X ep->s2 = ep->s3;
X else {
X ++ep->s2;
X ep->mode = (ep->s1&1) ? FHOLE : VHOLE;
X }
X return Yes;
X
X case SUBSET:
X if (issublist(sym) && ep->s2 >= 2*nchildren(n)) {
X do {
X sym = symbol(n);
X s_downrite(ep);
X n = tree(ep->focus);
X } while (samelevel(sym, symbol(n))
X && (nn = lastchild(n), nodewidth(nn) != 0));
X ep->mode = WHOLE;
X return Yes;
X }
X ep->s1 = ep->s2;
X return Yes;
X
X case SUBLIST:
X Assert(ep->s3 > 1);
X for (i = ep->s3; i > 1; --i)
X s_downi(ep, nchildren(tree(ep->focus)));
X ep->s3 = 1;
X return Yes;
X
X case WHOLE:
X Assert(sym == Hole || sym == Optional);
X return No;
X
X default:
X Abort();
X /* NOTREACHED */
X }
X}
END_OF_FILE
if test 5769 -ne `wc -c <'abc/bed/e1wide.c'`; then
echo shar: \"'abc/bed/e1wide.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1wide.c'
fi
if test -f 'abc/bint2/i2dis.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint2/i2dis.c'\"
else
echo shar: Extracting \"'abc/bint2/i2dis.c'\" \(7205 characters\)
sed "s/^X//" >'abc/bint2/i2dis.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "b0lan.h"
X#include "i2par.h"
X#include "i2nod.h"
X
XFILE *d_file;
X
XHidden intlet ilevel= 0;
X
XHidden Procedure set_ilevel() {
X intlet i;
X for (i= 0; i<ilevel; i++) putstr(d_file, Indent);
X}
X
XHidden bool new_line= Yes, in_comment= No;
X
XHidden Procedure d_string(s) string s; {
X if (new_line && !in_comment) set_ilevel();
X putstr(d_file, s);
X new_line= No;
X}
X
XHidden Procedure d_char(c) char c; {
X if (new_line && !in_comment) set_ilevel();
X putchr(d_file, c);
X new_line= No;
X}
X
XHidden Procedure d_newline() {
X putnewline(d_file);
X new_line= Yes;
X}
X
X#define d_space() d_char(' ')
X
X/* ******************************************************************** */
X
XHidden bool displ_one_line, stop_displ;
X
XVisible Procedure display(f, v, one_line) FILE *f; parsetree v; bool one_line; {
X d_file= f;
X ilevel= 0;
X displ_one_line= one_line;
X stop_displ= No;
X new_line= !one_line;
X displ(v);
X if (!new_line) d_newline();
X}
X
X/* ******************************************************************** */
X
Xchar *text[NTYPES] = {
X /* HOW_TO */ "HOW TO #h1:#c2#b34",
X /* YIELD */ "HOW TO RETURN 2:#c3#b45",
X /* TEST */ "HOW TO REPORT 2:#c3#b45",
X /* REFINEMENT */ "0:#c1#b23",
X /* SUITE */ "1#c23",
X
X /* PUT */ "PUT 0 IN 1",
X /* INSERT */ "INSERT 0 IN 1",
X /* REMOVE */ "REMOVE 0 FROM 1",
X /* SET_RANDOM */ "SET RANDOM 0",
X /* DELETE */ "DELETE 0",
X /* CHECK */ "CHECK 0",
X /* SHARE */ "SHARE 0",
X /* PASS */ "PASS",
X
X /* WRITE */ "WRITE #j",
X /* WRITE1 */ "WRITE #j",
X /* READ */ "READ 0 EG 1",
X /* READ_RAW */ "READ 0 RAW",
X
X /* IF */ "IF 0:#c1#b2",
X /* WHILE */ "WHILE 1:#c2#b3",
X /* FOR */ "FOR 0 IN 1:#c2#b3",
X
X /* SELECT */ "SELECT:#c0#b1",
X /* TEST_SUITE */ "1#d:#c2#b34",
X /* ELSE */ "ELSE:#c1#b2",
X
X /* QUIT */ "QUIT",
X /* RETURN */ "RETURN 0",
X /* REPORT */ "REPORT 0",
X /* SUCCEED */ "SUCCEED",
X /* FAIL */ "FAIL",
X
X /* USER_COMMAND */ "#h1",
X /* EXTENDED_COMMAND */ "0 ...",
X
X /* TAG */ "0",
X /* COMPOUND */ "(0)",
X /* COLLATERAL */ "#a0",
X /* SELECTION */ "0[1]",
X /* BEHEAD */ "0 at 1",
X /* CURTAIL */ "0|1",
X /* UNPARSED */ "1",
X /* MONF */ "#l",
X /* DYAF */ "#k",
X /* NUMBER */ "1",
X /* TEXT_DIS */ "#e",
X /* TEXT_LIT */ "#f",
X /* TEXT_CONV */ "`0`1",
X /* ELT_DIS */ "{}",
X /* LIST_DIS */ "{#i0}",
X /* RANGE_BNDS */ "0..1",
X /* TAB_DIS */ "{#g0}",
X /* AND */ "0 AND 1",
X /* OR */ "0 OR 1",
X /* NOT */ "NOT 0",
X /* SOME_IN */ "SOME 0 IN 1 HAS 2",
X /* EACH_IN */ "EACH 0 IN 1 HAS 2",
X /* NO_IN */ "NO 0 IN 1 HAS 2",
X /* MONPRD */ "0 1",
X /* DYAPRD */ "0 1 2",
X /* LESS_THAN */ "0 < 1",
X /* AT_MOST */ "0 <= 1",
X /* GREATER_THAN */ "0 > 1",
X /* AT_LEAST */ "0 >= 1",
X /* EQUAL */ "0 = 1",
X /* UNEQUAL */ "0 <> 1",
X /* Nonode */ "",
X
X /* TAGformal */ "0",
X /* TAGlocal */ "0",
X /* TAGglobal */ "0",
X /* TAGrefinement */ "0",
X /* TAGzerfun */ "0",
X /* TAGzerprd */ "0",
X
X /* ACTUAL */ "",
X /* FORMAL */ "",
X
X#ifdef GFX
X /* SPACE */ "SPACE FROM a TO b",
X /* LINE */ "LINE FROM a TO b",
X /* CLEAR */ "CLEAR SCREEN",
X#endif
X /* COLON_NODE */ "0"
X
X};
X
X#define Is_digit(d) ((d) >= '0' && (d) <= '9')
X#define Fld(v, t) *Branch(v, (*(t) - '0') + First_fieldnr)
X
XHidden Procedure displ(v) value v; {
X string t;
X
X if (!Valid(v)) return;
X else if (Is_text(v)) d_string(strval(v));
X else if (Is_parsetree(v)) {
X t= text[nodetype(v)];
X while (*t) {
X if (Is_digit(*t)) displ(Fld(v, t));
X else if (*t == '#') {
X special(v, &t);
X if (stop_displ) return;
X } else d_char(*t);
X t++;
X }
X }
X}
X
XHidden Procedure special(v, t) parsetree v; string *t; {
X (*t)++;
X switch (**t) {
X case 'a': d_collateral(Fld(v, ++*t)); break;
X case 'b': indent(Fld(v, ++*t)); break;
X case 'c': d_comment(Fld(v, ++*t)); break;
X case 'd': /* test suite */
X (*t)++;
X if (!new_line) /* there was a command */
X d_char(**t);
X break;
X case 'e': d_textdis(v); break;
X case 'f': d_textlit(v); break;
X case 'g': d_tabdis(Fld(v, ++*t)); break;
X case 'h': d_actfor_compound(Fld(v, ++*t)); break;
X case 'i': d_listdis(Fld(v, ++*t)); break;
X case 'j': d_write(v); break;
X case 'k': d_dyaf(v); break;
X case 'l': d_monf(v); break;
X }
X}
X
XHidden Procedure indent(v) parsetree v; {
X if (displ_one_line) { stop_displ= Yes; return; }
X ilevel++;
X displ(v);
X ilevel--;
X}
X
XHidden bool no_space_before_comment(v) value v; {
X return ncharval(1, v) == '\\';
X}
X
X
XHidden Procedure d_comment(v) value v; {
X if ( v != Vnil) {
X in_comment= Yes;
X if (!new_line && no_space_before_comment(v)) d_space();
X displ(v);
X in_comment= No;
X }
X if (!new_line) d_newline();
X}
X
XHidden value quote= Vnil;
X
XHidden Procedure d_textdis(v) parsetree v; {
X value s_quote= quote;
X quote= *Branch(v, XDIS_QUOTE);
X displ(quote);
X displ(*Branch(v, XDIS_NEXT));
X displ(quote);
X quote= s_quote;
X}
X
XHidden Procedure d_textlit(v) parsetree v; {
X value w;
X displ(w= *Branch(v, XLIT_TEXT));
X if (Valid(w) && character(w)) {
X value c= mk_text("`");
X if (compare(quote, w) == 0 || compare(c, w) == 0) displ(w);
X release(c);
X }
X displ(*Branch(v, XLIT_NEXT));
X}
X
XHidden Procedure d_tabdis(v) value v; {
X intlet k, len= Nfields(v);
X for (k= 0; k < len; k++) {
X if (k>0) d_string("; ");
X d_string("[");
X displ(*Field(v, k));
X d_string("]: ");
X displ(*Field(v, ++k));
X }
X}
X
XHidden Procedure d_collateral(v) value v; {
X intlet k, len= Nfields(v);
X for (k= 0; k < len; k++) {
X if (k>0) d_string(", ");
X displ(*Field(v, k));
X }
X}
X
XHidden Procedure d_listdis(v) value v; {
X intlet k, len= Nfields(v);
X for (k= 0; k < len; k++) {
X if (k>0) d_string("; ");
X displ(*Field(v, k));
X }
X}
X
XHidden Procedure d_actfor_compound(v) value v; {
X while (v != Vnil) {
X displ(*Branch(v, ACT_KEYW));
X if (*Branch(v, ACT_EXPR) != Vnil) {
X d_space();
X displ(*Branch(v, ACT_EXPR));
X }
X v= *Branch(v, ACT_NEXT);
X if (v != Vnil) d_space();
X }
X}
X
XHidden Procedure d_write(v) parsetree v; {
X value l_lines, w, r_lines;
X l_lines= *Branch(v, WRT_L_LINES);
X w= *Branch(v, WRT_EXPR);
X r_lines= *Branch(v, WRT_R_LINES);
X displ(l_lines);
X if (w != NilTree) {
X value n= size(l_lines);
X if (intval(n) > 0) d_space();
X release(n);
X displ(w);
X n= size(r_lines);
X if (intval(n) > 0) d_space();
X release(n);
X }
X displ(r_lines);
X}
X
X#define is_b_tag(v) (Valid(v) && Letter(ncharval(1, v)))
X
XHidden Procedure d_dyaf(v) parsetree v; {
X parsetree l, r; value name;
X l= *Branch(v, DYA_LEFT);
X r= *Branch(v, DYA_RIGHT);
X name= *Branch(v, DYA_NAME);
X displ(l);
X if (is_b_tag(name) || nodetype(r) == MONF) {
X d_space();
X displ(name);
X d_space();
X }
X else displ(name);
X displ(r);
X}
X
XHidden Procedure d_monf(v) parsetree v; {
X parsetree r; value name;
X name= *Branch(v, MON_NAME);
X r= *Branch(v, MON_RIGHT);
X displ(name);
X if (is_b_tag(name)) {
X switch (nodetype(r)) {
X case MONF:
X name= *Branch(r, MON_NAME);
X if (!is_b_tag(name))
X break;
X case SELECTION:
X case BEHEAD:
X case CURTAIL:
X case TAG:
X case TAGformal:
X case TAGlocal:
X case TAGglobal:
X case TAGrefinement:
X case TAGzerfun:
X case TAGzerprd:
X case NUMBER:
X case TEXT_DIS:
X d_space();
X break;
X default:
X break;
X }
X }
X displ(r);
X}
END_OF_FILE
if test 7205 -ne `wc -c <'abc/bint2/i2dis.c'`; then
echo shar: \"'abc/bint2/i2dis.c'\" unpacked with wrong size!
fi
# end of 'abc/bint2/i2dis.c'
fi
if test -f 'abc/bint3/i3typ.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3typ.c'\"
else
echo shar: Extracting \"'abc/bint3/i3typ.c'\" \(2726 characters\)
sed "s/^X//" >'abc/bint3/i3typ.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Type matching */
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i3env.h"
X#include "i3typ.h"
X
X#define Tnil ((btype) Vnil)
X
X/* All the routines in this file are temporary */
X/* Thus length() has been put here too */
X
XVisible int length(v) value v; {
X value s= size(v);
X int len= intval(s);
X release(s);
X return len;
X}
X
XVisible btype loctype(l) loc l; {
X value *ll;
X if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X if (!in_env(sl->e->tab, sl->i, &ll)) return Tnil;
X return valtype(*ll);
X } else if (Is_tbseloc(l)) {
X tbseloc *tl= Tbseloc(l);
X btype tt= loctype(tl->R), ass;
X if (tt == Tnil) return Tnil;
X if (!empty(tt)) ass= item(tt, one);
X else ass= Tnil;
X release(tt);
X return ass;
X } else if (Is_trimloc(l)) {
X return mk_text("");
X } else if (Is_compound(l)) {
X btype ct= mk_compound(Nfields(l)); intlet k, len= Nfields(l);
X k_Overfields { *Field(ct, k)= loctype(*Field(l, k)); }
X return ct;
X } else {
X syserr(MESS(4200, "loctype asked of non-location"));
X return Tnil;
X }
X}
X
XVisible btype valtype(v) value v; {
X if (Is_number(v)) return mk_integer(0);
X else if (Is_text(v)) return mk_text("");
X else if (Is_compound(v)) {
X btype ct= mk_compound(Nfields(v)); intlet k, len= Nfields(v);
X k_Overfields { *Field(ct, k)= valtype(*Field(v, k)); }
X return ct;
X } else if (Is_ELT(v)) {
X return mk_elt();
X } else if (Is_list(v)) {
X btype tt= mk_elt(), vt, ve;
X if (!empty(v)) {
X insert(vt= valtype(ve= min1(v)), &tt);
X release(vt); release(ve);
X }
X return tt;
X } else if (Is_table(v)) {
X btype tt= mk_elt(), vk, va;
X if (!empty(v)) {
X vk= valtype(*key(v, 0));
X va= valtype(*assoc(v, 0));
X replace(va, &tt, vk);
X release(vk); release(va);
X }
X return tt;
X } else {
X syserr(MESS(4201, "valtype called with unknown type"));
X return Tnil;
X }
X}
X
XVisible Procedure must_agree(t, u, m) btype t, u; int m; {
X intlet k, len;
X value vt, vu;
X if (t == Tnil || u == Tnil || t == u) return;
X if (Is_number(t) && Is_number(u)) return;
X if (Is_text(t) && Is_text(u)) return;
X if (Is_ELT(u) && (Is_ELT(t) || Is_list(t) || Is_table(t))) return;
X if (Is_ELT(t) && ( Is_list(u) || Is_table(u))) return;
X if (Is_compound(t) && Is_compound(u)) {
X if ((len= Nfields(t)) != Nfields(u)) interr(m);
X else k_Overfields { must_agree(*Field(t,k), *Field(u,k), m); }
X } else {
X if (Is_list(t) && Is_list(u)) {
X if (!empty(t) && !empty(u)) {
X must_agree(vt= min1(t), vu= min1(u), m);
X release(vt); release(vu);
X }
X } else if (Is_table(t) && Is_table(u)) {
X if (!empty(t) && !empty(u)) {
X must_agree(*key(t, 0), *key(u, 0), m);
X must_agree(*assoc(t, 0), *assoc(u, 0), m);
X }
X } else interr(m);
X }
X}
END_OF_FILE
if test 2726 -ne `wc -c <'abc/bint3/i3typ.c'`; then
echo shar: \"'abc/bint3/i3typ.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3typ.c'
fi
if test -f 'abc/bio/i4rec.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bio/i4rec.c'\"
else
echo shar: Extracting \"'abc/bio/i4rec.c'\" \(5720 characters\)
sed "s/^X//" >'abc/bio/i4rec.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */
X
X#include "b.h"
X#include "feat.h"
X#include "bint.h"
X#include "bfil.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "i2nod.h"
X#include "i2par.h"
X#include "i3scr.h"
X#include "i3sou.h"
X#include "i4bio.h"
X
X/*
X * Code to recover the contents of an ABC workspace.
X *
X * It constructs two completely new files:
X * perm.abc for the permanent environment, and
X * suggest.abc for the user suggestions.
X * Files with an extension of ".cts" or ".CTS" are taken to be targets;
X * all others are assumed to contain units (if they contain garbage,
X * they are ignored).
X * For units, the name, type and adicity are extracted from the source;
X * for targets, the target name is either taken from the old perm.abc or
X * taken to be the file name with all illegal characters converted to double
X * quote (") and uppercase to lowercase.
X *
X * BUGS:
X * - target names can get truncated when the original target name was longer
X * than what fits in a legal file name.
X */
X
XVisible bool ws_recovered= No;
XHidden bool rec_ok= Yes;
X
XHidden value old_perm;
XHidden value permtab;
XHidden value sugglis;
X
XVisible Procedure rec_workspace() {
X value lis, fname;
X value k, len, m;
X value old_ulast, old_tlast;
X
X ws_recovered= No;
X rec_ok= Yes;
X
X old_perm= copy(b_perm);
X old_ulast= copy(last_unit);
X old_tlast= copy(last_target);
X endworkspace();
X
X permtab= mk_elt();
X sugglis= mk_elt();
X
X lis= get_names(curdir(), abcfile);
X k= one; len= size(lis);
X while (numcomp(k, len) <= 0) {
X fname= item(lis, k);
X if (targetfile(fname))
X rec_target(fname);
X else if (unitfile(fname))
X rec_unit(fname);
X release(fname);
X k= sum(m= k, one);
X release(m);
X }
X release(k); release(len);
X release(lis);
X
X rec_current(old_ulast);
X rec_current(old_tlast);
X
X recperm();
X recsugg();
X recpos();
X#ifdef TYPE_CHECK
X rectypes();
X#endif
X
X release(permtab);
X release(sugglis);
X release(old_perm);
X
X initworkspace();
X if (!still_ok)
X return;
X
X ws_recovered= Yes;
X}
X
XHidden Procedure rec_target(fname) value fname; {
X value pname;
X value name;
X intlet k, len;
X
X /* try to find a name via the old perm table */
X name= Vnil;
X len= Valid(old_perm) ? length(old_perm) : 0;
X for (k= 0; k<len; ++k) {
X if (compare(*assoc(old_perm, k), fname) == 0) {
X name= Permname(*key(old_perm, k));
X if (is_abcname(name))
X break;
X release(name); name= Vnil;
X }
X }
X if (!Valid(name)) { /* make a new name */
X char *base= base_fname(fname);
X name= mkabcname(base);
X freestr(base);
X }
X if (!is_abcname(name)) {
X recerrV(R_TNAME, fname);
X release(name);
X return;
X }
X pname= permkey(name, Tar);
X mk_permentry(pname, fname);
X release(pname);
X release(name);
X}
X
XHidden Procedure rec_unit(fname) value fname; {
X FILE *fp;
X char *line;
X value pname;
X parsetree u;
X
X fp= fopen(strval(fname), "r");
X if (fp == NULL) {
X recerrV(R_FREAD, fname);
X return;
X }
X line= f_getline(fp);
X fclose(fp);
X if (line == NULL) {
X recerrV(R_UNAME, fname);
X return;
X }
X tx= line;
X findceol();
X
X mess_ok= No; /* do it silently */
X u= unit(Yes, No);
X still_ok= Yes;
X mess_ok= Yes;
X
X pname= u == NilTree ? Vnil : get_pname(u);
X if (Valid(pname)) {
X mk_permentry(pname, fname);
X mk_suggitem(u);
X }
X else recerrV(R_UNAME, fname);
X freestr(line);
X release(pname);
X release((value) u);
X}
X
XHidden Procedure mk_permentry(pname, fname) value pname, fname; {
X value fn;
X
X if (in_keys(pname, permtab)) {
X recerrV(R_EXIST, fname);
X return;
X }
X if (!typeclash(pname, fname))
X fn= copy(fname);
X else {
X value name= Permname(pname);
X literal type= Permtype(pname);
X
X fn= new_fname(name, type);
X if (Valid(fn))
X f_rename(fname, fn);
X else
X recerrV(R_RENAME, fname);
X release(name);
X
X }
X if (Valid(fn))
X replace(fn, &permtab, pname);
X release(fn);
X}
X
XHidden Procedure mk_suggitem(u) parsetree u; {
X value formals, k, t, next, v;
X value sugg, sp_hole, sp;
X
X switch (Nodetype(u)) {
X case HOW_TO:
X sugg= mk_text("");
X sp_hole= mk_text(" ?");
X sp= mk_text(" ");
X formals= *Branch(u, HOW_FORMALS);
X while (Valid(formals)) {
X k= *Branch(formals, FML_KEYW);
X t= *Branch(formals, FML_TAG);
X next= *Branch(formals, FML_NEXT);
X sugg= concat(v= sugg, k);
X release(v);
X if (Valid(t)) {
X sugg= concat(v= sugg, sp_hole);
X release(v);
X }
X if (Valid(next)) {
X sugg= concat(v= sugg, sp);
X release(v);
X }
X formals= next;
X }
X release(sp_hole);
X release(sp);
X break;
X case YIELD:
X case TEST:
X sugg= copy(*Branch(u, UNIT_NAME));
X break;
X default:
X return;
X }
X insert(sugg, &sugglis);
X release(sugg);
X}
X
XHidden Procedure rec_current(curr) value curr; {
X value *pn;
X
X if (in_keys(curr, old_perm)
X && Valid(*(pn= adrassoc(old_perm, curr)))
X && in_keys(*pn, permtab))
X {
X replace(*pn, &permtab, curr);
X }
X}
X
XHidden Procedure recperm() {
X permchanges= Yes;
X put_perm(permtab);
X}
X
XHidden Procedure recsugg() {
X FILE *fp;
X value k, len, m;
X value sugg;
X
X len= size(sugglis);
X if (numcomp(len, zero) <= 0) {
X unlink(suggfile);
X release(len);
X return;
X }
X fp= fopen(suggfile, "w");
X if (fp == NULL) {
X cantwrite(suggfile);
X release(len);
X return;
X }
X k= one;
X while (numcomp(k, len) <= 0) {
X sugg= item(sugglis, k);
X fprintf(fp, "%s\n", strval(sugg));
X release(sugg);
X k= sum(m= k, one);
X release(m);
X }
X fclose(fp);
X release(k); release(len);
X}
X
XHidden Procedure recpos() {
X /* to be done */
X /* since the number of filenames remembered is limited
X * any filenames disappeared in recovering will
X * eventually disappear, however.
X */
X}
X
X
XHidden Procedure recerrV(m, v) int m; value v; {
X if (rec_ok) {
X bioerr(R_ERROR);
X rec_ok= No;
X }
X bioerrV(m, v);
X}
X
XHidden Procedure cantwrite(file) string file; {
X value fn= mk_text(file);
X bioerrV(R_FWRITE, fn);
X release(fn);
X}
END_OF_FILE
if test 5720 -ne `wc -c <'abc/bio/i4rec.c'`; then
echo shar: \"'abc/bio/i4rec.c'\" unpacked with wrong size!
fi
# end of 'abc/bio/i4rec.c'
fi
if test -f 'abc/btr/i1btr.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/btr/i1btr.h'\"
else
echo shar: Extracting \"'abc/btr/i1btr.h'\" \(7434 characters\)
sed "s/^X//" >'abc/btr/i1btr.h' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Private definitions for the b-tree module */
X
X#define EQ ==
X#define NE !=
X
Xextern bool comp_ok;
X#define reqerr(s) interr(s)
X
X/*********************************************************************/
X/* items */
X/*********************************************************************/
X
Xtypedef char texitem;
Xtypedef value lisitem;
Xtypedef struct pair {value k, a;} tabitem;
Xtypedef struct onpair {value ka, u;} keysitem;
Xtypedef union itm {
X texitem c;
X lisitem l;
X tabitem t;
X} btritem, *itemarray, *itemptr;
X
X#define Charval(pitm) ((pitm)->c)
X#define Keyval(pitm) ((pitm)->l)
X#define Ascval(pitm) ((pitm)->t.a)
X
X/* Xt = itemtype, do not change these, their order is used */
X#define Ct (0)
X#define Lt (1)
X#define Tt (2)
X#define Kt (3)
X
X/* Itemwidth, used for offset in btreenodes */
Xtypedef char width;
X#define Itemwidth(it) (itemwidth[it])
Xextern char itemwidth[]; /* uses: */
X#define Cw (sizeof(texitem))
X#define Lw (sizeof(lisitem))
X#define Tw (sizeof(tabitem))
X#define Kw (sizeof(keysitem))
X
X/*********************************************************************/
X/* sizes of btrees */
X/*********************************************************************/
X
X#define Bigsize (-1)
X#define Stail(r,s) ((r) > Maxint - (s) ? Bigsize : (r)+(s))
X#define Ssum(r,s) ((r) EQ Bigsize || (s) EQ Bigsize ? Bigsize : Stail(r,s))
X#define Sincr(r) ((r) EQ Bigsize ? Bigsize : Stail(r,1))
X#define Sadd2(r) ((r) EQ Bigsize ? Bigsize : Stail(r,2))
X#define Sdiff(r,s) ((r) EQ Bigsize || (s) EQ Bigsize ? Bigsize : (r)-(s))
X#define Sdecr(r) ((r) EQ Bigsize ? Bigsize : (r)-(1))
Xvalue treesize(); /* btreeptr pnode */
X
X/*********************************************************************/
X/* (A,B)-btrees */
X/*********************************************************************/
X
X/* innernodes: using A=6 B=12 */
X#define Mininner 5 /* A - 1 */
X#define Maxinner 11 /* B - 1 */
X/* bottomnodes */
X#define Minbottom 11
X#define Maxbottom 22
X/* rangenodes */
X#define Biglim (Maxbottom+1)
X
Xtypedef struct btrnode {
X HEADER; int size;
X char **g;
X}
Xbtreenode, *btreeptr;
X
Xtypedef struct innernode {
X HEADER; int size;
X btreeptr pnptr[Maxinner+1]; itemarray iitm;
X}
Xinnernode, *innerptr;
X
Xtypedef struct itexnode {
X HEADER; int size;
X btreeptr pnptr[Maxinner+1]; texitem icitm[Maxinner];
X}
Xitexnode, *itexptr;
X
Xtypedef struct ilisnode {
X HEADER; int size;
X btreeptr pnptr[Maxinner+1]; lisitem ilitm[Maxinner];
X}
Xilisnode, *ilisptr;
X
Xtypedef struct itabnode {
X HEADER; int size;
X btreeptr pnptr[Maxinner+1]; tabitem ititm[Maxinner];
X}
Xitabnode, *itabptr;
X
Xtypedef struct bottomnode {
X HEADER; int size;
X itemarray bitm;
X}
Xbottomnode, *bottomptr;
X
Xtypedef struct btexnode {
X HEADER; int size;
X texitem bcitm[Maxbottom];
X}
Xbtexnode, *btexptr;
X
Xtypedef struct blisnode {
X HEADER; int size;
X lisitem blitm[Maxbottom];
X}
Xblisnode, *blisptr;
X
Xtypedef struct btabnode {
X HEADER; int size;
X tabitem btitm[Maxbottom];
X}
Xbtabnode, *btabptr;
X
Xtypedef struct rangenode {
X HEADER; int size;
X lisitem lwb, upb;
X}
Xrangenode, *rangeptr;
X
X#define Bnil ((btreeptr) 0)
X
X#define Flag(pnode) ((pnode)->type)
X#define Inner 'i'
X#define Bottom 'b'
X#define Irange '.'
X#define Crange '\''
X
X#define Lim(pnode) ((pnode)->len)
X#define Minlim(pnode) (Flag(pnode) EQ Inner ? Mininner : Minbottom)
X#define Maxlim(pnode) (Flag(pnode) EQ Inner ? Maxinner : Maxbottom)
X#define SetRangeLim(pnode) (Size(pnode) EQ Bigsize || Size(pnode) > Maxbottom\
X ? Biglim : Size(pnode))
X
X#define Size(pnode) ((pnode)->size)
X
X#define Ptr(pnode,l) (((innerptr) (pnode))->pnptr[l])
X/* pointer to item in innernode: */
X#define Piitm(pnode,l,w) ((itemptr) (((char*)&(((innerptr) (pnode))->iitm)) + ((l)*(w))))
X/* pointer to item in bottomnode: */
X#define Pbitm(pnode,l,w) ((itemptr) (((char*)&(((bottomptr) (pnode))->bitm)) + ((l)*(w))))
X#define Ichar(pnode,l) (((itexptr) (pnode))->icitm[l])
X#define Bchar(pnode,l) (((btexptr) (pnode))->bcitm[l])
X
X#define Lwbval(pnode) (((rangeptr) (pnode))->lwb)
X#define Upbval(pnode) (((rangeptr) (pnode))->upb)
X#define Lwbchar(pnode) (Bchar(Root(Lwbval(pnode)), 0))
X#define Upbchar(pnode) (Bchar(Root(Upbval(pnode)), 0))
X
X#define Maxheight 20 /* should be some function of B */
X
X/* Procedure merge(); */
X /* btreeptr pleft; itemptr pitm; btreeptr pright; literal it; */
Xbool rebalance();
X /* btreeptr *pptr1; itemptr pitm; btreeptr pptr2;
X intlet minlim, maxlim; literal it; */
X/* Procedure restore_child(); */
X /* btreeptr pparent; intlet ichild, minl, maxl; literal it; */
Xbool inodeinsert();
X /* btreeptr pnode, *pptr; itemptr pitm; intlet at; literal it; */
Xbool bnodeinsert();
X /* btreeptr pnode, *pptr; itemptr pitm; intlet at; literal it; */
Xbool i_search();
X /* btreeptr pnode; value key; intlet *pl; width iw; */
Xbool b_search();
X /* btreeptr pnode; value key; intlet *pl; width iw; */
X
X/*********************************************************************/
X/* texts only (mbte.c) */
X/*********************************************************************/
X
Xbtreeptr trimbtextnode(); /* btreeptr pnode, intlet from,to */
Xbtreeptr trimitextnode(); /* btreeptr pnode, intlet from,to */
Xbool join_itm();
X /* btreeptr pnode, *pptr; itemptr pitm; bool after */
X
X/*********************************************************************/
X/* lists only (mbli.c) */
X/*********************************************************************/
X
Xbtreeptr spawncrangenode(); /* value lwb, upb */
X/* Procedure set_size_and_lim(); */ /* btreeptr pnode */
X/* PRrocedure ir_to_bottomnode(); */ /* btreeptr *pptr; */
Xbool ins_itm();
X /* btreeptr *pptr1; itemptr pitm; btreeptr *pptr2; literal it; */
X/* Procedure rem_greatest(); */
X /* btreeptr *pptr; itemptr prepl_itm; literal it; */
Xbool rem_itm();
X /* btreeptr *pptr1; itemptr pitm;
X itemptr p_insitm; btreeptr *pptr2; bool *psplit;
X literal it; */
X
X/*********************************************************************/
X/* tables only (mbla.c) */
X/*********************************************************************/
X
Xbool rpl_itm();
X /* btreeptr *pptr1, *pptr2; itemptr pitm; bool *p_added */
Xbool del_itm();
X /* btreeptr *pptr1; itemptr pitm */
Xvalue assocval(); /* btreeptr pnode; value key; */
Xbool assocloc();
X /* value **ploc; btreeptr pnode; value key; */
Xbool u_assoc(); /* btreeptr pnode; value key; */
X
X/***************** Texts, lists and tables ********************/
X/* Procedure move_itm(); */ /* itemptr pdes, psrc; literal it; */
Xbool get_th_item(); /* itemptr pitm; value num, v; */
X
X/* Private definitions for grabbing and ref count scheme */
X
Xbtreeptr grabbtreenode(); /* literal flag, it */
Xbtreeptr copybtree(); /* btreeptr pnode */
X/* Procedure uniqlbtreenode(); */ /* btreeptr *pptr; literal it */
Xbtreeptr ccopybtreenode(); /* btreeptr pnode; literal it */
Xbtreeptr mknewroot();
X /* btreeptr ptr0, itemptr pitm0, btreeptr ptr1, literal it */
X/* Procedure relbtree(); */ /* btreeptr pnode; literal it */
X/* Procedure freebtreenode(); */ /* btreeptr pnode; */
END_OF_FILE
if test 7434 -ne `wc -c <'abc/btr/i1btr.h'`; then
echo shar: \"'abc/btr/i1btr.h'\" unpacked with wrong size!
fi
# end of 'abc/btr/i1btr.h'
fi
if test -f 'abc/tc/termcap.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/tc/termcap.c'\"
else
echo shar: Extracting \"'abc/tc/termcap.c'\" \(6705 characters\)
sed "s/^X//" >'abc/tc/termcap.c' <<'END_OF_FILE'
X#define BUFSIZ 1024
X#define MAXHOP 32 /* max number of tc= indirections */
X#define E_TERMCAP "/etc/termcap"
X
X#include <ctype.h>
X/*
X * termcap - routines for dealing with the terminal capability data base
X *
X * BUG: Should use a "last" pointer in tbuf, so that searching
X * for capabilities alphabetically would not be a n**2/2
X * process when large numbers of capabilities are given.
X * Note: If we add a last pointer now we will screw up the
X * tc capability. We really should compile termcap.
X *
X * Essentially all the work here is scanning and decoding escapes
X * in string capabilities. We don't use stdio because the editor
X * doesn't, and because living w/o it is not hard.
X */
X
Xstatic char *tbuf;
Xstatic int hopcount; /* detect infinite loops in termcap, init 0 */
Xchar *tskip();
Xchar *tgetstr();
Xchar *tdecode();
Xchar *getenv();
X
X/*
X * Get an entry for terminal name in buffer bp,
X * from the termcap file. Parse is very rudimentary;
X * we just notice escaped newlines.
X */
Xtgetent(bp, name)
X char *bp, *name;
X{
X register char *cp;
X register int c;
X register int i = 0, cnt = 0;
X char ibuf[BUFSIZ];
X char *cp2;
X int tf;
X
X tbuf = bp;
X tf = 0;
X#ifndef V6
X cp = getenv("TERMCAP");
X /*
X * TERMCAP can have one of two things in it. It can be the
X * name of a file to use instead of /etc/termcap. In this
X * case it better start with a "/". Or it can be an entry to
X * use so we don't have to read the file. In this case it
X * has to already have the newlines crunched out.
X */
X if (cp && *cp) {
X if (*cp!='/') {
X cp2 = getenv("TERM");
X if (cp2==(char *) 0 || strcmp(name,cp2)==0) {
X strcpy(bp,cp);
X return(tnchktc());
X } else {
X tf = open(E_TERMCAP, 0);
X }
X } else
X tf = open(cp, 0);
X }
X if (tf==0)
X tf = open(E_TERMCAP, 0);
X#else
X tf = open(E_TERMCAP, 0);
X#endif
X if (tf < 0)
X return (-1);
X for (;;) {
X cp = bp;
X for (;;) {
X if (i == cnt) {
X cnt = read(tf, ibuf, BUFSIZ);
X if (cnt <= 0) {
X close(tf);
X return (0);
X }
X i = 0;
X }
X c = ibuf[i++];
X if (c == '\n') {
X if (cp > bp && cp[-1] == '\\'){
X cp--;
X continue;
X }
X break;
X }
X if (cp >= bp+BUFSIZ) {
X write(2,"Termcap entry too long\n", 23);
X break;
X } else
X *cp++ = c;
X }
X *cp = 0;
X
X /*
X * The real work for the match.
X */
X if (tnamatch(name)) {
X close(tf);
X return(tnchktc());
X }
X }
X}
X
X/*
X * tnchktc: check the last entry, see if it's tc=xxx. If so,
X * recursively find xxx and append that entry (minus the names)
X * to take the place of the tc=xxx entry. This allows termcap
X * entries to say "like an HP2621 but doesn't turn on the labels".
X * Note that this works because of the left to right scan.
X */
Xtnchktc()
X{
X register char *p, *q;
X char tcname[16]; /* name of similar terminal */
X char tcbuf[BUFSIZ];
X char *holdtbuf = tbuf;
X int l;
X
X p = tbuf + strlen(tbuf) - 2; /* before the last colon */
X while (*--p != ':')
X if (p<tbuf) {
X write(2, "Bad termcap entry\n", 18);
X return (0);
X }
X p++;
X /* p now points to beginning of last field */
X if (p[0] != 't' || p[1] != 'c')
X return(1);
X strcpy(tcname,p+3);
X q = tcname;
X while (q && *q != ':')
X q++;
X *q = 0;
X if (++hopcount > MAXHOP) {
X write(2, "Infinite tc= loop\n", 18);
X return (0);
X }
X if (tgetent(tcbuf, tcname) != 1)
X return(0);
X for (q=tcbuf; *q != ':'; q++)
X ;
X l = p - holdtbuf + strlen(q);
X if (l > BUFSIZ) {
X write(2, "Termcap entry too long\n", 23);
X q[BUFSIZ - (p-tbuf)] = 0;
X }
X strcpy(p, q+1);
X tbuf = holdtbuf;
X return(1);
X}
X
X/*
X * Tnamatch deals with name matching. The first field of the termcap
X * entry is a sequence of names separated by |'s, so we compare
X * against each such name. The normal : terminator after the last
X * name (before the first field) stops us.
X */
Xtnamatch(np)
X char *np;
X{
X register char *Np, *Bp;
X
X Bp = tbuf;
X if (*Bp == '#')
X return(0);
X for (;;) {
X for (Np = np; *Np && *Bp == *Np; Bp++, Np++)
X continue;
X if (*Np == 0 && (*Bp == '|' || *Bp == ':' || *Bp == 0))
X return (1);
X while (*Bp && *Bp != ':' && *Bp != '|')
X Bp++;
X if (*Bp == 0 || *Bp == ':')
X return (0);
X Bp++;
X }
X}
X
X/*
X * Skip to the next field. Notice that this is very dumb, not
X * knowing about \: escapes or any such. If necessary, :'s can be put
X * into the termcap file in octal.
X */
Xstatic char *
Xtskip(bp)
X register char *bp;
X{
X
X while (*bp && *bp != ':')
X bp++;
X if (*bp == ':')
X bp++;
X return (bp);
X}
X
X/*
X * Return the (numeric) option id.
X * Numeric options look like
X * li#80
X * i.e. the option string is separated from the numeric value by
X * a # character. If the option is not found we return -1.
X * Note that we handle octal numbers beginning with 0.
X */
Xtgetnum(id)
X char *id;
X{
X register int i, base;
X register char *bp = tbuf;
X
X for (;;) {
X bp = tskip(bp);
X if (*bp == 0)
X return (-1);
X if (*bp++ != id[0] || *bp == 0 || *bp++ != id[1])
X continue;
X if (*bp == '@')
X return(-1);
X if (*bp != '#')
X continue;
X bp++;
X base = 10;
X if (*bp == '0')
X base = 8;
X i = 0;
X while (isdigit(*bp))
X i *= base, i += *bp++ - '0';
X return (i);
X }
X}
X
X/*
X * Handle a flag option.
X * Flag options are given "naked", i.e. followed by a : or the end
X * of the buffer. Return 1 if we find the option, or 0 if it is
X * not given.
X */
Xtgetflag(id)
X char *id;
X{
X register char *bp = tbuf;
X
X for (;;) {
X bp = tskip(bp);
X if (!*bp)
X return (0);
X if (*bp++ == id[0] && *bp != 0 && *bp++ == id[1]) {
X if (!*bp || *bp == ':')
X return (1);
X else if (*bp == '@')
X return(0);
X }
X }
X}
X
X/*
X * Get a string valued option.
X * These are given as
X * cl=^Z
X * Much decoding is done on the strings, and the strings are
X * placed in area, which is a ref parameter which is updated.
X * No checking on area overflow.
X */
Xchar *
Xtgetstr(id, area)
X char *id, **area;
X{
X register char *bp = tbuf;
X
X for (;;) {
X bp = tskip(bp);
X if (!*bp)
X return (0);
X if (*bp++ != id[0] || *bp == 0 || *bp++ != id[1])
X continue;
X if (*bp == '@')
X return(0);
X if (*bp != '=')
X continue;
X bp++;
X return (tdecode(bp, area));
X }
X}
X
X/*
X * Tdecode does the grung work to decode the
X * string capability escapes.
X */
Xstatic char *
Xtdecode(str, area)
X register char *str;
X char **area;
X{
X register char *cp;
X register int c;
X register char *dp;
X int i;
X
X cp = *area;
X while ((c = *str++) && c != ':') {
X switch (c) {
X
X case '^':
X c = *str++ & 037;
X break;
X
X case '\\':
X dp = "E\033^^\\\\::n\nr\rt\tb\bf\f";
X c = *str++;
Xnextc:
X if (*dp++ == c) {
X c = *dp++;
X break;
X }
X dp++;
X if (*dp)
X goto nextc;
X if (isdigit(c)) {
X c -= '0', i = 2;
X do
X c <<= 3, c |= *str++ - '0';
X while (--i && isdigit(*str));
X }
X break;
X }
X *cp++ = c;
X }
X *cp++ = 0;
X str = *area;
X *area = cp;
X return (str);
X}
END_OF_FILE
if test 6705 -ne `wc -c <'abc/tc/termcap.c'`; then
echo shar: \"'abc/tc/termcap.c'\" unpacked with wrong size!
fi
# end of 'abc/tc/termcap.c'
fi
echo shar: End of archive 19 \(of 25\).
cp /dev/null ark19isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 25 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still must unpack the following archives:
echo " " ${MISSING}
fi
exit 0 # Just in case...
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list