rsalz@bbn.com (Rich Salz) (12/20/90)
Submitted-by: Steven Pemberton <steven@cwi.nl> Posting-number: Volume 23, Issue 97 Archive-name: abc/part18 #! /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@uunet.uu.net if you want that tool. # Contents: abc/bed/e1cell.c abc/bed/e1gram.c abc/bed/e1ins2.c # abc/bint1/i1nug.c abc/bint3/i3fpr.c abc/ihdrs/i2nod.h # abc/stc/i2tcp.c # Wrapped by rsalz@litchi.bbn.com on Mon Dec 17 13:28:14 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 18 (of 25)."' if test -f 'abc/bed/e1cell.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1cell.c'\" else echo shar: Extracting \"'abc/bed/e1cell.c'\" \(7336 characters\) sed "s/^X//" >'abc/bed/e1cell.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* X * B editor -- Screen management package, cell list manipulation routines. X */ X X#include "b.h" X#include "b0lan.h" X#include "bedi.h" X#include "bmem.h" X#include "bobj.h" X#include "node.h" X#include "cell.h" X#include "args.h" X Xextern bool noscroll; X X/* X * Definitions for internals of cell manipulations. X */ X XHidden cell *freelist; X X#define CELLSIZE (sizeof(cell)) X X#ifndef PAGESIZE /* 4.2 BSD freaks compile with -DPAGESIZE='getpagesize()' */ X#define PAGESIZE 1024 X#endif X X#ifndef MALLOCLOSS X#define MALLOCLOSS (sizeof(char*)) X /* number of bytes taken by malloc administration per block */ X#endif X X X/* X * Replace `oldlcnt' cells from `tops', starting at the one numbered `oldlno', X * by the list `rep'. X * Returns a pointer to the deleted chain (with a Nil end pointer). X */ X XVisible cell * Xreplist(tops, rep, oldlno, oldlcnt) X cell *tops; X cell *rep; X int oldlno; X register int oldlcnt; X{ X cell head; X register cell *p; X register cell *q; X register cell *old; X register cell *end; X register int diff; X int i; X int replcnt; X X if (!tops) /* Start with empty list */ X return rep; X head.c_link = tops; X p = &head; X for (diff = oldlno; diff > 0; --diff) { X p = p->c_link; X Assert(p); X } X q = p; X for (i = oldlcnt; i > 0 && p; --i) X p = p->c_link; X if (i > 0) { X#ifndef NDEBUG X if (dflag) X debug("[replist jackpot]"); X#endif /* NDEBUG */ X oldlcnt -= i; X } X old = q->c_link; X q->c_link = rep; X if (p) { X end = p->c_link; X p->c_link = Cnil; X } X for (replcnt = 0; q->c_link; ++replcnt, q = q->c_link) X ; X dupmatch(old, rep, oldlcnt, replcnt); X discard(old); X if (p) X q->c_link = end; X return head.c_link; X} X X X/* X * Allocate a new cell. X */ X XHidden cell * Xnewcell() X{ X register cell *p; X X if (!freelist) X feedfreelist(); X p = freelist; X freelist = p->c_link; X p->c_link = Cnil; X return p; X} X X X/* X * Feed the free list with a block of new entries. X * We try to keep them together on a page X * to keep consecutive accesses fast. X */ X XHidden Procedure Xfeedfreelist() X{ X register int n = (PAGESIZE-MALLOCLOSS) / CELLSIZE; X register cell *p = (cell*) getmem((unsigned)(n*CELLSIZE)); X#ifdef MEMTRACE X fixmem((ptr) p); X#endif X Assert(n > 0); X freelist = p; X for (; n > 1; --n, ++p) X p->c_link = p+1; X p->c_link = Cnil; X} X X X/* X * Discard all entries of a list of cells. X */ X XVisible Procedure Xdiscard(p) X register cell *p; X{ X register cell *savefreelist; X X if (!p) X return; X savefreelist = p; X for (;;) { X noderelease(p->c_data); X p->c_data = Nnil; X if (!p->c_link) X break; X p = p->c_link; X } X p->c_link = freelist; X freelist = savefreelist; X} X X X/* X * Replace the `onscreen' fields in the replacement chain by those X * in the old chain, if they match. X */ X XHidden Procedure Xdupmatch(old, rep, oldcnt, repcnt) X register cell *old; X register cell *rep; X int oldcnt; X int repcnt; X{ X register int diff = repcnt - oldcnt; X X#ifndef NDEBUG X if (dflag) X debug("[dupmatch(oldcnt=%d, newcnt=%d)]", oldcnt, repcnt); X#endif /* NDEBUG */ X while (rep && old) { X if (old->c_length == rep->c_length X && eqlines(old->c_data, rep->c_data)) { X if (old->c_onscreen != Nowhere) { X rep->c_onscreen = old->c_onscreen; X rep->c_oldindent = old->c_oldindent; X rep->c_oldvhole = old->c_oldvhole; X rep->c_oldfocus = old->c_oldfocus; X } X rep = rep->c_link; X old = old->c_link; X } X else { X if (diff >= 0) { X --diff; X rep = rep->c_link; X } X if (diff < 0) { X ++diff; X old = old->c_link; X } X } X } X} X X X/* X * Build a list of cells consisting of the first `lcnt' lines of the tree. X */ X XVisible cell * Xbuild(p, lcnt) X /*auto*/ path p; X register int lcnt; X{ X cell head; X register cell *q = &head; X X p = pathcopy(p); X for (;;) { X q = q->c_link = newcell(); X q->c_onscreen = Nowhere; X q->c_data = nodecopy(tree(p)); X q->c_length = linelen(q->c_data); X q->c_newindent = Level(p) * INDENTSIZE; X q->c_oldindent = 0; X q->c_oldvhole = q->c_newvhole = q->c_oldfocus = q->c_newfocus = No; X --lcnt; X if (lcnt <= 0) X break; X if (!nextline(&p)) Abort(); X } X q->c_link = Cnil; X pathrelease(p); X return head.c_link; X} X X X/* X * Decide which line is to be on top of the screen. X * We slide a window through the list of lines, recognizing X * lines of the focus and lines already on the screen, X * and stop as soon as we find a reasonable focus position. X * X * - The focus must always be on the screen completely; X * if it is larger than the screen, its first line must be X * on top of the screen. X * - When old lines can be retained, at least one line above X * and below the focus must be shown; the retained lines X * should be moved as little as possible. X * - As little as possible blank space should be shown at the X * bottom, even if the focus is at the end of the unit. X * - If no rule applies, try to center the focus on the screen. X * - If noscroll is Yes (the terminal can't scroll), and the top X * line can't be retained, also try to center the focus on the X * screen. X */ X XVisible cell * Xgettop(tops) X cell *tops; X{ X register cell *pfwa = tops; /* First line of sliding window */ X register cell *plwa = tops; /* Last+1 line of sliding window */ X register cell *pffocus = Cnil; /* First line of focus */ X cell *pscreen = Cnil; /* First line still on screen */ X register int nfwa = 0; /* Corresponding line numbers in parse tree */ X register int nlwa = 0; X register int nffocus; X int nlfocus; X int nscreen; X int size; X X for (;;) { /* plwa is the current candidate for top line. */ X if (!pfwa) { X#ifndef NDEBUG X debug("[Lost the focus!]"); X#endif /* NDEBUG */ X return tops; /* To show *something*... */ X } X while (plwa && nlwa < nfwa+winheight) { X /* Find first line *not* in window */ X size = Space(plwa); X if (plwa->c_newfocus) { /* Hit a focus line */ X if (!pffocus) { /* Note first focus line */ X pffocus = plwa; X nffocus = nlwa; X } X nlfocus = nlwa + size; X } X if (plwa->c_onscreen != Nowhere) { /* Hello old chap */ X if (!pscreen) { /* Note first line on screen */ X pscreen = plwa; X nscreen = nlwa; X } X } X nlwa += size; X plwa = plwa->c_link; X } X if (pffocus) { X /* Focus in sight; stop at first reasonable opportunity */ X if (pffocus == pfwa) X break; /* Grab last chance! */ X if (!noscroll && nlwa - nfwa <= winheight - winheight/3) X break; /* Don't show too much white space at bottom */ X if (pffocus == pfwa->c_link && nlfocus < nfwa+winheight) X break; /* Near top line */ X if (pscreen && (!noscroll || nffocus > nscreen)) { X /* Conservatism may succeed */ X if (pscreen->c_onscreen >= nscreen - nfwa X && (nlfocus < nfwa+winheight X || !plwa && nlfocus == nfwa+winheight)) X break; /* focus entirely on screen */ X } X else { /* No comrades seen */ X if (nffocus - nfwa <= nfwa+winheight - nlfocus X || !plwa && nlwa <= nfwa+winheight) X break; /* Nicely centered focus or end of unit */ X } X } X if (pfwa == pscreen) { /* Say farewell to oldest comrade */ X pscreen->c_onscreen = Nowhere; X do { /* Find next in age */ X nscreen += Space(pscreen); X pscreen = pscreen->c_link; X if (pscreen == plwa) { X pscreen = Cnil; X break; X } X } while (pscreen->c_onscreen == Nowhere); X } X nfwa += Space(pfwa); X pfwa = pfwa->c_link; /* Pass the buck */ X } X return pfwa; /* This is what all those breaks aim at */ X} END_OF_FILE if test 7336 -ne `wc -c <'abc/bed/e1cell.c'`; then echo shar: \"'abc/bed/e1cell.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1cell.c' fi if test -f 'abc/bed/e1gram.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1gram.c'\" else echo shar: Extracting \"'abc/bed/e1gram.c'\" \(7451 characters\) sed "s/^X//" >'abc/bed/e1gram.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* X * B editor -- All routines referencing the grammar table are in this file. X */ X X#include "b.h" X#include "bedi.h" X#include "etex.h" X#include "bmem.h" X#include "feat.h" X#include "bobj.h" X#include "node.h" X#include "gram.h" X#include "supr.h" X#include "tabl.h" X#include "code.h" /* not strictly necessary, only for initcodes() */ X#include "args.h" X X/* X * Test whether sym is in the given class. X */ X XVisible bool Xisinclass(sym, ci) X register int sym; X struct classinfo *ci; X{ X register classptr cp; X X Assert(ci && ci->c_class); X if (sym == Hole) X return !isinclass(Optional, ci); X for (cp = ci->c_class; *cp; ++cp) X if (sym == *cp) X return Yes; X return No; X} X X X/* X * Deliver the representation array for the given node. X * If the node is actually just a "text" value, construct X * one in static storage -- which is overwritten at each call. X * In this case there are two deficiencies: the next call to X * noderepr which uses the same feature overwrites the reply X * value of the previous call, AND if the text value itself X * is changed, the representation may change, too. X * In practical use this is no problem at all, however. X */ X XVisible string * Xnoderepr(n) X register node n; X{ X register int sym; X X if (n && Is_etext(n)) { X static string buf[2]; X if (buf[0]) e_fstrval(buf[0]); X buf[0] = e_sstrval((value)n); X return buf; X } X sym = symbol(n); X return table[sym].r_repr; X} X X#ifdef MEMTRACE XVisible Procedure endnoderepr() { /* hack to free noderepr static store */ X value v= mk_etext("dummy"); X string *s= noderepr((node)v); X freemem((ptr) s[0]); X release(v); X} X#endif X X/* X * Deliver the prototype node for the given symbol. X */ X XVisible node Xgram(sym) X register int sym; X{ X Assert(0 <= sym && sym < TABLEN); X return table[sym].r_node; X} X X#ifdef SAVEBUF X X/* X * Deliver the name of a symbol. X */ X XVisible string Xsymname(sym) X int sym; X{ X static char buf[20]; X X if (sym >= 0 && sym < TABLEN && table[sym].r_name) X return table[sym].r_name; X sprintf(buf, "%d", sym); X return buf; X} X X X/* X * Find the symbol corresponding to a given name. X * Return -1 if not found. X */ X XVisible int Xnametosym(str) X register string str; X{ X register int sym; X register string name; X X for (sym = 0; sym < TABLEN; ++sym) { X name = table[sym].r_name; X if (name && !strcmp(name, str)) X return sym; X } X return -1; X} X X#endif /* SAVEBUF */ X X/* X * Test whether `sym' may replace the node in the path `p'. X */ X XVisible bool Xallowed(p, sym) X register path p; X register int sym; X{ X register path pa = parent(p); X register int ich = ichild(p); X register int sympa = pa ? symbol(tree(pa)) : Rootsymbol; X X Assert(sympa >= 0 && sympa < TABLEN && ich > 0 && ich <= MAXCHILD); X return isinclass(sym, table[sympa].r_class[ich-1]); X} X X X/* X * Initialize (and verify) the grammar table. X * (sets refcnt to infinity) X */ X XVisible Procedure Xinitgram() X{ X register int sym; X register int nch; X register struct classinfo **cp; X register struct classinfo *sp; X node ch[MAXCHILD]; X X#ifndef NDEBUG X if (dflag) X putstr(DEBUGFILE, "*** initgram();\n"); X#endif /* NDEBUG */ X /* Set the node pointers in the table and check the representations. X The code assumes Optional and Hole are the last X symbols in the table, i.e. the first processed by the loop. */ X X for (sym = TABLEN-1; sym >= 0; --sym) { X cp = table[sym].r_class; X for (nch = 0; nch < MAXCHILD && (sp = cp[nch]); ++nch) X ch[nch] = X table[sp->c_class[0] == Optional ? X Optional : Hole].r_node; X table[sym].r_node = newnode(nch, sym, ch); X fix_refcnt(table[sym].r_node); X } X initcodes(); X} X X/* X * Set a node's refcnt to infinity, so it will never be released. X */ X XHidden Procedure Xfix_refcnt(n) X register node n; X{ X Assert(n->refcnt > 0); X n->refcnt = Maxrefcnt; X#ifdef MEMTRACE X fixmem((ptr) n); X#endif X} X X/* X * Add built-in commands to the suggestion tables. X */ X XVisible Procedure Xinitclasses() X{ X#ifdef USERSUGG X register struct table *tp; X X tp= &table[Rootsymbol]; X Assert(isinclass(Suggestion, tp->r_class[0])); X makesugg(tp->r_class[0]->c_class); X#endif /* USERSUGG */ X} X X#ifdef USERSUGG X X/* X * Extract suggestions from class list. X */ X XHidden Procedure Xmakesugg(cp) X classptr cp; X{ X struct table *tp; X string *rp; X char buffer[1000]; X string bp; X string sp; X int i; X int nch; X X for (; *cp; ++cp) { X if (*cp >= TABLEN) X continue; X Assert(*cp > 0); X tp = &table[*cp]; X rp = tp->r_repr; X if (rp[0] && isupper(rp[0][0])) { X bp = buffer; X nch = nchildren(tp->r_node); X for (i = 0; i <= nch; ++i) { X if (rp[i]) { X for (sp = rp[i]; *sp >= ' '; ++sp) X *bp++ = *sp; X } X if (i < nch && !isinclass(Optional, tp->r_class[i])) X *bp++ = '?'; X } X if (bp > buffer) { X *bp = 0; X addsugg(buffer, (int) *cp); X } X } X } X} X X#endif /* USERSUGG */ X X/* X * Set the root of the grammar to the given symbol. It must exist. X */ X XVisible Procedure Xsetroot(isym) int isym; { /* symbols defined in tabl.h */ X register int ich; X X table[Rootsymbol].r_name = table[isym].r_name; X for (ich = 0; ich < MAXCHILD; ++ich) { X table[Rootsymbol].r_repr[ich] = table[isym].r_repr[ich]; X table[Rootsymbol].r_class[ich] = table[isym].r_class[ich]; X } X table[Rootsymbol].r_repr[ich] = table[isym].r_repr[ich]; X table[Rootsymbol].r_node = table[isym].r_node; X} X X/* X * The remainder of this file is specific for the currently used grammar. X */ X X/* X * Table indicating which symbols are used to form lists of items. X * Consulted via predicate 'issublist'. X */ X XHidden classelem Asublists[] = { X Exp_plus, Formal_naming_plus, X And, And_kw, Or, Or_kw, X 0 X}; X XHidden struct classinfo sublists[] = {Asublists}; X X X/* X * Predicate telling whether two symbols can form lists together. X * This is important for list whose elements must alternate in some X * way, as is the case for [KEYWORD [expression] ]*. X * X * This code must be in this file, otherwise the names and values X * of the symbols would have to be made public. X */ X XVisible bool Xsamelevel(sym, sym1) X register int sym; X register int sym1; X{ X register int zzz; X X if (sym1 == sym) X return Yes; X if (sym1 < sym) X zzz = sym, sym = sym1, sym1 = zzz; /* Ensure sym <= sym1 */ X /* Now always sym < sym1 */ X return sym == Kw_plus && sym1 == Exp_plus X || sym == Formal_kw_plus && sym1 == Formal_naming_plus X || sym == And && sym1 == And_kw X || sym == Or && sym1 == Or_kw; X} X X X/* X * Predicate to tell whether a symbol can form chained lists. X * By definition, all right-recursive symbols can do so; X * in addition, those listed in the class 'sublists' can do X * it, too (this is used for lists formed of alternating members X * such as KW expr KW ...). X */ X XVisible bool Xissublist(sym) X register int sym; X{ X register int i; X register string repr; X X Assert(sym < TABLEN); X if (isinclass(sym, sublists)) X return Yes; X repr = table[sym].r_repr[0]; X if (Fw_positive(repr)) X return No; X for (i = 0; i < MAXCHILD && table[sym].r_class[i]; ++i) X ; X if (i <= 0) X return No; X repr = table[sym].r_repr[i]; X if (!Fw_zero(repr)) X return No; X return isinclass(sym, table[sym].r_class[i-1]); X} X X/* true iff parent allows a command with a colon (a control-command); X * this is false for grammar constructs allowing simple-commands X * following a colon. X * sym == symbol(tree(parent(ep->focus))) X */ XVisible bool allows_colon(sym) int sym; { X switch (sym) { X case Short_comp: X case Test_suite: X case Short_unit: X case Refinement: X return No; X default: X return Yes; X } X /*NOTREACHED*/ X} END_OF_FILE if test 7451 -ne `wc -c <'abc/bed/e1gram.c'`; then echo shar: \"'abc/bed/e1gram.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1gram.c' fi if test -f 'abc/bed/e1ins2.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1ins2.c'\" else echo shar: Extracting \"'abc/bed/e1ins2.c'\" \(7384 characters\) sed "s/^X//" >'abc/bed/e1ins2.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* X * B editor -- Insert characters from keyboard. 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 "queu.h" X#include "gram.h" X#include "tabl.h" X X/* X * Insert a character. X */ X Xextern bool justgoon; X XHidden bool quot_in_tag(c, ep) int c; environ *ep; { X /* hack to not surround part of name or keyword; X * fixes bug 890417 X */ X int sym= symbol(tree(ep->focus)); X X return (ep->s2 > 0 && X ((char)c == '\'' || (char)c == '\"') X && X (sym == Name || sym == Keyword)); X} X XVisible bool Xins_char(ep, c, alt_c) X register environ *ep; X int c; X int alt_c; X{ X auto queue q = Qnil; X auto queue qf = Qnil; X value copyout(); X auto string str; X char buf[2]; X int where; X bool spwhere; X X if (!justgoon) { X higher(ep); X shrink(ep); X if (strchr("({[`'\"", (char)c) X && !ishole(ep) X && !quot_in_tag(c, ep)) { X /* Surround something. Wonder what will happen! */ X qf = (queue) copyout(ep); X if (!delbody(ep)) { X qrelease(qf); X return No; X } X } X fixit(ep); X } X ep->changed = Yes; X buf[0] = c; X buf[1] = 0; X if (!ins_string(ep, buf, &q, alt_c)) X return No; X if (!emptyqueue(q) || !emptyqueue(qf)) { X /* Slight variation on app_queue */ X if (!emptyqueue(qf) && emptyqueue(q)) X ritevhole(ep); /* Wizardry. Why does this work? */ X spwhere = ep->spflag; X ep->spflag = No; X where = focoffset(ep); X markpath(&ep->focus, 1); X ep->spflag = spwhere; X if (ep->mode == FHOLE && ep->s2 > 0) { X /* If we just caused a suggestion, insert the remains X after the suggested text, not after its first character. */ X str = ""; X if (!soften(ep, &str, 0)) { X ep->mode = ATEND; X leftvhole(ep); X if (symbol(tree(ep->focus)) == Hole) { X ep->mode = ATBEGIN; X leftvhole(ep); X } X } X } X if (!emptyqueue(q)) { /* Re-insert stuff queued by ins_string */ X if (!ins_queue(ep, &q, &q)) X return No; X where += spwhere; X spwhere = No; X } X if (!emptyqueue(qf)) { /* Re-insert deleted old focus */ X if (!firstmarked(&ep->focus, 1)) Abort(); X fixfocus(ep, where); X if (!ins_queue(ep, &qf, &qf)) X return No; X } X if (!firstmarked(&ep->focus, 1)) Abort(); X unmkpath(&ep->focus, 1); X ep->spflag = No; X fixfocus(ep, where + spwhere); X } X return Yes; X} X X X/* X * Insert a newline. X */ X XVisible bool Xins_newline(ep) X register environ *ep; X{ X register node n; X register int sym; X auto bool mayindent; X X ep->changed = Yes; X if (!fiddle(ep, &mayindent)) X return No; X for (;;) { X switch (ep->mode) { X X case VHOLE: X ep->mode = ATEND; X continue; X X case FHOLE: X ep->s2 = lenitem(ep); X if (!fix_move(ep)) X return No; X continue; X X case ATEND: X if (!joinstring(&ep->focus, "\n", No, 0, mayindent)) { X if (!move_on(ep)) X return No; X continue; X } X s_downi(ep, 2); X s_downi(ep, 1); X ep->mode = WHOLE; X Assert((sym = symbol(tree(ep->focus))) == Hole || sym == Optional); X return Yes; X X case ATBEGIN: X n = tree(ep->focus); X if (Is_etext(n)) { X ep->mode = ATEND; X continue; X } X sym = symbol(n); X if (sym == Hole || sym == Optional) { X ep->mode = WHOLE; X continue; X } X n = nodecopy(n); X if (!fitstring(&ep->focus, "\n", 0)) { X if (!down(&ep->focus)) X ep->mode = ATEND; X noderelease(n); X continue; X } X s_downrite(ep); X if (fitnode(&ep->focus, n)) { X noderelease(n); X s_up(ep); X s_down(ep); X ep->mode = WHOLE; X return Yes; X } X s_up(ep); X s_down(ep); X if (!fitnode(&ep->focus, n)) { X noderelease(n); X#ifndef NDEBUG X debug("[Sorry, I don't see how to insert a newline here]"); X#endif /* NDEBUG */ X return No; X } X noderelease(n); X ep->mode = ATBEGIN; X return Yes; X X case WHOLE: X Assert((sym = symbol(tree(ep->focus))) == Hole || sym == Optional); X if (!fitstring(&ep->focus, "\n", 0)) { X ep->mode = ATEND; X continue; X } X s_downi(ep, 1); X Assert((sym = symbol(tree(ep->focus))) == Hole || sym == Optional); X ep->mode = WHOLE; X return Yes; X X default: X Abort(); X X } X } X} X X X/* X * Refinement for ins_newline() to do the initial processing. X */ X XHidden bool Xfiddle(ep, pmayindent) X register environ *ep; X bool *pmayindent; X{ X register int level; X auto string str = ""; X X higher(ep); X while (rnarrow(ep)) X ; X fixit(ep); X VOID soften(ep, &str, 0); X higher(ep); X *pmayindent = Yes; X if (atdedent(ep)) { X *pmayindent = No; X s_up(ep); X level = Level(ep->focus); X delfocus(&ep->focus); X if (symbol(tree(ep->focus)) == Hole) { X if (hackhack(ep)) X return Yes; X } X while (Level(ep->focus) >= level) { X if (!nexthole(ep)) { X ep->mode = ATEND; X break; X } X } X if (ep->mode == ATEND) { X leftvhole(ep); X ep->mode = ATEND; X while (Level(ep->focus) >= level) { X if (!up(&ep->focus)) X return No; X } X } X return Yes; X } X else if (atrealhole(ep)) X return No; X return Yes; X} X X X/* X * "Hier komen de houthakkers." X * X * Incredibly ugly hack to delete a join whose second child begins with \n, X * such as a suite after an IF, FOR or WHILE or unit heading. X * Inspects the parent node. X * If this has rp[0] ands rp[1] both empty, replace it by its first child. X * (caller assures this makes sense). X * Return Yes if this happened AND rp[1] contained a \t. X */ X XHidden Procedure Xhackhack(ep) X environ *ep; X{ X node n; X int ich = ichild(ep->focus); X string *rp; X X if (!up(&ep->focus)) X return No; X higher(ep); X rp = noderepr(tree(ep->focus)); X if (!Fw_zero(rp[0]) || !Fw_zero(rp[1])) { X s_downi(ep, ich); X return No; X } X n = nodecopy(firstchild(tree(ep->focus))); X delfocus(&ep->focus); X treereplace(&ep->focus, n); X ep->mode = ATEND; X return rp[1] && rp[1][0] == '\t'; X} X X X/* X * Refinement for fiddle() to find out whether we are at a possible X * decrease-indentation position. X */ X XHidden bool Xatdedent(ep) X register environ *ep; X{ X register path pa; X register node npa; X register int i; X register int sym = symbol(tree(ep->focus)); X X if (sym != Hole && sym != Optional) X return No; X if (ichild(ep->focus) != 1) X return No; X switch (ep->mode) { X case FHOLE: X if (ep->s1 != 1 || ep->s2 != 0) X return No; X break; X case ATBEGIN: X case WHOLE: X case SUBSET: X break; X default: X return No; X } X pa = parent(ep->focus); X if (!pa) X return No; X npa = tree(pa); X if (fwidth(noderepr(npa)[0]) >= 0) X return No; X for (i = nchildren(npa); i > 1; --i) { X sym = symbol(child(npa, i)); X if (sym != Hole && sym != Optional) X return No; X } X return Yes; /* Sigh! */ X} X X/* X * Refinement for ins_node() and fiddle() to find the next hole, X * skipping blank space only. X */ X XHidden bool Xnexthole(ep) X register environ *ep; X{ X register node n; X register int ich; X register string repr; X X do { X ich = ichild(ep->focus); X if (!up(&ep->focus)) X return No; X higher(ep); X n = tree(ep->focus); X repr = noderepr(n)[ich]; X if (!Fw_zero(repr) && !allspaces(repr)) X return No; X } while (ich >= nchildren(n)); X s_downi(ep, ich+1); X return Yes; X} X XHidden int atrealhole(ep) environ *ep; { X node n; X int i; X X n= tree(ep->focus); X X if (symbol(n) == Hole) X return Yes; X if (ep->mode == FHOLE X && strlen(noderepr(n)[i= ep->s1/2]) <= ep->s2) { X if (i < nchildren(n)) { X n= child(n, i+1); X if (Is_etext(n)) X return No; X if (symbol(n) == Hole X || symbol(n) == Exp_plus X && symbol(child(n, 1)) == Hole X ) X return Yes; X } X } X return No; X} END_OF_FILE if test 7384 -ne `wc -c <'abc/bed/e1ins2.c'`; then echo shar: \"'abc/bed/e1ins2.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1ins2.c' fi if test -f 'abc/bint1/i1nug.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bint1/i1nug.c'\" else echo shar: Extracting \"'abc/bint1/i1nug.c'\" \(4268 characters\) sed "s/^X//" >'abc/bint1/i1nug.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */ X X#include "b.h" X#include "feat.h" /* for EXT_RANGE */ X#include "bobj.h" X#include "i1num.h" X X X/* X * Routines for greatest common divisor calculation X * "Binary gcd algorithm" X * X * Assumptions about built-in arithmetic: X * x>>1 == x/2 (if x >= 0) X * 1<<k == 2**k (if it fits in a word) X */ X X/* Single-precision gcd for integers > 0 */ X XHidden digit dig_gcd(u, v) register digit u, v; { X register digit temp; X register int k = 0; X X if (u <= 0 || v <= 0) syserr(MESS(900, "dig_gcd of number(s) <= 0")); X X while (Even(u) && Even(v)) ++k, u >>= 1, v >>= 1; X X /* u or v is odd */ X X while (Even(u)) u >>= 1; X X while (v) { X /* u is odd */ X X while (Even(v)) v >>= 1; X X /* u and v odd */ X X if (u > v) { temp = v; v = u - v; u = temp; } X else v = v - u; X X /* u is odd and v even */ X } X X return u * (1<<k); X} X XVisible integer int_half(v) integer v; { X register int i; X register long carry; X X if (IsSmallInt(v)) X return (integer) MkSmallInt(SmallIntVal(v) / 2); X X if (Msd(v) < 0) { X i = Length(v)-2; X if (i < 0) { X Release(v); X return int_0; X } X carry = BASE; X } X else { X carry = 0; X i = Length(v)-1; X } X X if (Refcnt(v) > 1) uniql((value *) &v); X X for (; i >= 0; --i) { X carry += Digit(v,i); X Digit(v,i) = carry/2; X carry = carry&1 ? BASE : 0; X } X X return int_canon(v); X} X X/* X * u or v is a smallint X * call int_mod() to make the other smallint too X * call dig_gcd() X * multiply with twopow X */ X XHidden integer gcd_small(u, v, twopow) integer u, v, twopow; { X integer g; X X if (!IsSmallInt(u) && !IsSmallInt(v)) X syserr(MESS(901, "gcd_small of numbers > smallint")); X X if (!IsSmallInt(v)) X { g = u; u = v; v = g; } X if (v == int_0) X g = (integer) Copy(u); X else if (v == int_1) X g = int_1; X else { X u= IsSmallInt(u) ? (integer) Copy(u) : int_mod(u, v); X if (u == int_0) X g = (integer) Copy(v); X else if (u == int_1) X g = int_1; X else g= (integer) MkSmallInt( X dig_gcd(SmallIntVal(u), SmallIntVal(v))); X Release(u); X } X X g = int_prod(u= g, twopow); X Release(u); X X if (interrupted && g == int_0) X { Release(g); g = int_1; } X return g; X} X XHidden int lwb_lendiff = (3 / tenlogBASE) + 1; X X#define Modgcd(u, v) (Length(u) - Length(v) > lwb_lendiff) X X/* Multi-precision gcd of integers > 0 */ X XVisible integer int_gcd(u1, v1) integer u1, v1; { X integer t, u, v; X integer twopow= int_1; X long k = 0; X X if (Msd(u1) <= 0 || Msd(v1) <= 0) X syserr(MESS(902, "gcd of number(s) <= 0")); X X if (IsSmallInt(u1) || IsSmallInt(v1)) X return gcd_small(u1, v1, int_1); X X u = (integer) Copy(u1); X v = (integer) Copy(v1); X X if (int_comp(u, v) < 0) X { t = u; u = v; v = t; } X X while (Modgcd(u, v)) { X t = int_mod(u, v); /* u > v > t >= 0 */ X Release(u); X u = v; X v = t; X if (IsSmallInt(v)) X goto smallint; X } X X X while (Even(Lsd(u)) && Even(Lsd(v))) { X u = int_half(u); X v = int_half(v); X if (++k < 0) { X /*It's a number we can't cope with, X with too many common factors 2. X Though the user can't help it, X the least we can do is to allow X continuation of the session. X */ X interr(MESS(903, "exceptionally large rational number")); X k = 0; X } X } X X t= mk_int((double) k); X twopow= (integer) power((value) int_2, (value) t); X Release(t); X X if (IsSmallInt(v)) X goto smallint; X X while (Even(Lsd(u))) X u = int_half(u); X X if (IsSmallInt(u)) X goto smallint; X X /* u is odd */ X X while (v != int_0) { X X while (Even(Lsd(v))) X v = int_half(v); X X if (IsSmallInt(v)) X goto smallint; X X /* u and v are odd */ X X if (int_comp(u, v) > 0) { X if (Modgcd(u, v)) X t = int_mod(u, v); /* u>v>t>=0 */ X /* t can be odd */ X else X t = int_diff(u, v); X /* t is even */ X Release(u); X u = v; X v = t; X } X else { X if (Modgcd(v, u)) X t = int_mod(v, u); /* v>u>t>=0 */ X /* t can be odd */ X else X t = int_diff(v, u); X /* t is even */ X Release(v); X v = t; X } X /* u is odd X * v can be odd too, but in that case is the new value X * smaller than the old one X */ X } X X Release(v); X X u = int_prod(v = u, twopow); X Release(v); Release(twopow); X X if (interrupted && u == int_0) X { Release(u); u = int_1; } X return u; X Xsmallint: X t = gcd_small(u, v, twopow); X Release(u); Release(v); Release(twopow); X X return t; X} END_OF_FILE if test 4268 -ne `wc -c <'abc/bint1/i1nug.c'`; then echo shar: \"'abc/bint1/i1nug.c'\" unpacked with wrong size! fi # end of 'abc/bint1/i1nug.c' fi if test -f 'abc/bint3/i3fpr.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bint3/i3fpr.c'\" else echo shar: Extracting \"'abc/bint3/i3fpr.c'\" \(7591 characters\) sed "s/^X//" >'abc/bint3/i3fpr.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* B formula/predicate invocation */ X#include "b.h" X#include "bint.h" X#include "feat.h" X#include "bobj.h" X#include "i0err.h" X#include "b0lan.h" X#include "i1num.h" X#include "i2par.h" X#include "i3sou.h" X X#define Other 0 X#define Nume 1 /* e.g. number1 + number2 */ X#define Adjust 5 /* e.g. v >< number2 */ X#define Numpair 2 /* e.g. angle(x,y) has numeric pair */ X#define Nonzero 3 /* e.g. 0 sin x undefined */ X#define Textual 4 /* e.g. stripped t */ X X#define Xact 0 X#define In 1 X#define Not_in 2 X X/* X * Table defining all predefined functions (but not propositions). X */ X Xstruct funtab { X string f_name; literal f_adic, f_kind; X value (*f_fun)(); X char /* bool */ f_extended; X} funtab[] = { X {S_ABOUT, Mfd, Nume, approximate}, X {S_PLUS, Mfd, Nume, copy}, X {S_PLUS, Dfd, Nume, sum}, X {S_MINUS, Mfd, Nume, negated}, X {S_MINUS, Dfd, Nume, diff}, X {S_NUMERATOR, Mfd, Nume, numerator}, X {S_DENOMINATOR, Mfd, Nume, denominator}, X X {S_TIMES, Dfd, Nume, prod}, X {S_OVER, Dfd, Nume, quot}, X {S_POWER, Dfd, Nume, power}, X X {S_BEHEAD, Dfd, Other, behead}, X {S_CURTAIL, Dfd, Other, curtail}, X {S_JOIN, Dfd, Other, concat}, X {S_REPEAT, Dfd, Other, repeat}, X {S_LEFT_ADJUST, Dfd, Adjust, adjleft}, X {S_CENTER, Dfd, Adjust, centre}, X {S_RIGHT_ADJUST, Dfd, Adjust, adjright}, X X {S_NUMBER, Mfd, Other, size}, X {S_NUMBER, Dfd, Other, size2}, X X {F_pi, Zfd, Other, pi}, X {F_e, Zfd, Other, e}, X {F_now, Zfd, Other, nowisthetime}, X X {F_abs, Mfd, Nume, absval}, X {F_sign, Mfd, Nume, signum}, X {F_floor, Mfd, Nume, floorf}, X {F_ceiling, Mfd, Nume, ceilf}, X {F_round, Mfd, Nume, round1}, X {F_round, Dfd, Nume, round2}, X {F_mod, Dfd, Nume, mod}, X {F_root, Mfd, Nume, root1}, X {F_root, Dfd, Nume, root2}, X {F_random, Zfd, Nume, random}, X X {F_exactly, Mfd, Nume, exactly}, X X {F_sin, Mfd, Nume, sin1}, X {F_cos, Mfd, Nume, cos1}, X {F_tan, Mfd, Nume, tan1}, X {F_arctan, Mfd, Nume, arctan1}, X {F_angle, Mfd, Numpair, angle1}, X {F_radius, Mfd, Numpair, radius}, X X {F_sin, Dfd, Nonzero, sin2}, X {F_cos, Dfd, Nonzero, cos2}, X {F_tan, Dfd, Nonzero, tan2}, X {F_arctan, Dfd, Nume, arctan2}, X {F_angle, Dfd, Numpair, angle2}, X X {F_exp, Mfd, Nume, exp1}, X {F_log, Mfd, Nume, log1}, X {F_log, Dfd, Nume, log2}, X X {F_stripped, Mfd, Textual, stripped}, X {F_split, Mfd, Textual, split}, X {F_upper, Mfd, Textual, upper}, X {F_lower, Mfd, Textual, lower}, X X {F_keys, Mfd, Other, keys}, X#ifdef B_COMPAT X {F_thof, Dfd, Other, th_of}, X#endif X {F_item, Dfd, Other, item}, X {F_min, Mfd, Other, min1}, X {F_min, Dfd, Other, min2}, X {F_max, Mfd, Other, max1}, X {F_max, Dfd, Other, max2}, X {F_choice, Mfd, Other, choice}, X {"", Dfd, Other, NULL} /*sentinel*/ X}; X XVisible Procedure initfpr() { X struct funtab *fp; value r, f, pname; X X for (fp= funtab; *(fp->f_name) != '\0'; ++fp) { X /* Define function */ X r= mk_text(fp->f_name); X f= mk_fun(fp->f_adic, (intlet) (fp-funtab), NilTree, Yes); X pname= permkey(r, fp->f_adic); X def_unit(pname, f); X release(f); release(r); release(pname); X } X X defprd(P_exact, Mpd, Xact); X defprd(P_in, Dpd, In); X defprd(P_notin, Dpd, Not_in); X} X XHidden Procedure defprd(repr, adic, pre) string repr; literal adic; intlet pre; { X value r= mk_text(repr), p= mk_prd(adic, pre, NilTree, Yes), pname; X pname= permkey(r, adic); X def_unit(pname, p); X release(p); release(r); release(pname); X} X X/* returns if a given test/yield exists *without faults* */ XHidden bool is_funprd(t, f, adicity, func) value t, *f; literal adicity; bool func; { X value *aa; X *f= Vnil; X if (!Valid(t) || !Is_text(t)) X return No; X if (!is_unit(t, adicity, &aa)) return No; X if (still_ok) { X if (func) { X if (!Is_function(*aa)) return No; X } else { X if (!Is_predicate(*aa)) return No; X } X *f= *aa; return Yes; X } else return No; X} X XVisible bool is_zerfun(t, f) value t, *f; { X return is_funprd(t, f, Zfd, Yes); X} X XVisible bool is_monfun(t, f) value t, *f; { X return is_funprd(t, f, Mfd, Yes); X} X XVisible bool is_dyafun(t, f) value t, *f; { X return is_funprd(t, f, Dfd, Yes); X} X XVisible bool is_zerprd(t, p) value t, *p; { X return is_funprd(t, p, Zpd, No); X} X XVisible bool is_monprd(t, p) value t, *p; { X return is_funprd(t, p, Mpd, No); X} X XVisible bool is_dyaprd(t, p) value t, *p; { X return is_funprd(t, p, Dpd, No); X} X X/* the following is a boolean function or predicate for the static type check, X * telling whether a certain name was overwritten by a how-to X * definition of the user. X * unlike the above one's this one doesn't load the definition if it X * is not in memory. X */ X XVisible bool is_udfpr(name, type) value name; literal type; { X value pname; X bool res; X value *aa; X X pname= permkey(name, type); X res= p_exists(pname, &aa); X release(pname); X return res; X} X X#define Is_numpair(v) (Is_compound(v) && Nfields(v) == 2 && \ X Is_number(*Field(v, 0)) && Is_number(*Field(v, 1))) X XVisible value pre_fun(nd1, pre, nd2) value nd1, nd2; intlet pre; { X struct funtab *fp= &funtab[pre]; X literal adic= fp->f_adic, kind= fp->f_kind; X value name= mk_text(fp->f_name); X switch (adic) { X case Dfd: X if ((kind==Nume||kind==Numpair||kind==Nonzero) && !Is_number(nd1)) { X interrV(MESS(3200, "in x %s y, x is not a number"), name); X release(name); X return Vnil; X } X else if ((kind==Nume||kind==Nonzero||kind==Adjust) X && !Is_number(nd2)) { X interrV(MESS(3201, "in x %s y, y is not a number"), name); X release(name); X return Vnil; X } X else if (kind==Numpair && !Is_numpair(nd2)) { X interrV(MESS(3202, "in x %s y, y is not a compound of two numbers"), name); X release(name); X return Vnil; X } else if (kind==Nonzero && numcomp(nd1, zero)==0) { X interrV(MESS(3203,"in c %s x, c is zero"), name); X release(name); X return Vnil; X } X break; X case Mfd: X switch (kind) { X case Nume: X if (!Is_number(nd2)) { X interrV(MESS(3204, "in %s x, x is not a number"), name); X release(name); X return Vnil; X } X break; X case Numpair: X if (!Is_numpair(nd2)) { X interrV(MESS(3205, "in %s y, y is not a compound of two numbers"), name); X release(name); X return Vnil; X } X break; X case Textual: X if (!Is_text(nd2)) { X interrV(MESS(3206, "in %s t, t is not a text"), name); X release(name); X return Vnil; X } X break; X } X break; X } X release(name); X X switch (adic) { X case Zfd: return((*fp->f_fun)()); X case Mfd: X if (fp->f_kind == Numpair) X return((*fp->f_fun)(*Field(nd2,0), *Field(nd2,1))); X else X return((*fp->f_fun)(nd2)); X case Dfd: X if (fp->f_kind == Numpair) X return((*fp->f_fun)(nd1, *Field(nd2,0), *Field(nd2,1))); X else X return((*fp->f_fun)(nd1, nd2)); X default: syserr(MESS(3207, "pre-defined fpr wrong")); X /*NOTREACHED*/ X } X} X XVisible bool pre_prop(nd1, pre, nd2) value nd1, nd2; intlet pre; { X switch (pre) { X case Xact: X if (!Is_number(nd2)) { X interr(MESS(3208, "in the test exact x, x is not a number")); X return No; X } X return exact(nd2); X case In: X if (!Is_tlt(nd2)) { Xinterr(MESS(3209, "in the test e in t, t is not a text list or table")); X return No; X } X if (Is_text(nd2) && (!character(nd1))) { X interr( XMESS(3210, "in the test e in t, t is a text, but e is not a character") X ); X return No; X } X return in(nd1, nd2); X case Not_in: X if (!Is_tlt(nd2)) { X interr( XMESS(3211, "in the test e not.in t, t is not a text list or table")); X return No; X } X if (Is_text(nd2) && (!character(nd1))) { X interr( XMESS(3212, "in the test e not.in t, t is a text, but e isn't a character") X ); X return No; X } X return !in(nd1, nd2); X default: X syserr(MESS(3213, "predicate not covered by proposition")); X /*NOTREACHED*/ X } X} END_OF_FILE if test 7591 -ne `wc -c <'abc/bint3/i3fpr.c'`; then echo shar: \"'abc/bint3/i3fpr.c'\" unpacked with wrong size! fi # end of 'abc/bint3/i3fpr.c' fi if test -f 'abc/ihdrs/i2nod.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/ihdrs/i2nod.h'\" else echo shar: Extracting \"'abc/ihdrs/i2nod.h'\" \(7578 characters\) sed "s/^X//" >'abc/ihdrs/i2nod.h' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* Units */ X Xtypedef intlet typenode; X X#define _Nodetype(len) ((len) & 0377) X#define _Nbranches(len) ((len) >> 8) X#define Nodetype(v) _Nodetype((v)->len) X#define Nbranches(v) _Nbranches((v)->len) X#define Branch(v, n) ((Ats(v)+(n))) X X#define Unit(n) (n>=HOW_TO && n<=REFINEMENT) X#ifndef GFX X#define Command(n) (n>=SUITE && n<=EXTENDED_COMMAND) X#else X#define Command(n) (n>=SUITE && n<=EXTENDED_COMMAND || \ X n>=GFX_first && n<=GFX_last) X#endif X#define Expression(n) ((n>=TAG && n<=TAB_DIS)||(n>=TAGformal && n<=TAGzerprd)) X#define Comparison(n) (n>=LESS_THAN && n<=UNEQUAL) X X#define HOW_TO 0 X#define YIELD 1 X#define TEST 2 X#define REFINEMENT 3 X X/* Commands */ X X#define SUITE 4 X#define PUT 5 X#define INSERT 6 X#define REMOVE 7 X#define SET_RANDOM 8 X#define DELETE 9 X#define CHECK 10 X#define SHARE 11 X#define PASS 12 X X#define WRITE 13 /* collateral expression */ X#define WRITE1 14 /* single expression */ X#define READ 15 X#define READ_RAW 16 X X#define IF 17 X#define WHILE 18 X#define FOR 19 X X#define SELECT 20 X#define TEST_SUITE 21 X#define ELSE 22 X X#define QUIT 23 X#define RETURN 24 X#define REPORT 25 X#define SUCCEED 26 X#define FAIL 27 X X#define USER_COMMAND 28 X#define EXTENDED_COMMAND 29 X X/* Expressions, targets, tests */ X X#define TAG 30 X#define COMPOUND 31 X X/* Expressions, targets */ X X#define COLLATERAL 32 X#define SELECTION 33 X#define BEHEAD 34 X#define CURTAIL 35 X X/* Expressions, tests */ X X#define UNPARSED 36 X X/* Expressions */ X X#define MONF 37 X#define DYAF 38 X#define NUMBER 39 X#define TEXT_DIS 40 X#define TEXT_LIT 41 X#define TEXT_CONV 42 X#define ELT_DIS 43 X#define LIST_DIS 44 X#define RANGE_BNDS 45 X#define TAB_DIS 46 X X/* Tests */ X X#define AND 47 X#define OR 48 X#define NOT 49 X#define SOME_IN 50 X#define EACH_IN 51 X#define NO_IN 52 X#define MONPRD 53 X#define DYAPRD 54 X#define LESS_THAN 55 X#define AT_MOST 56 X#define GREATER_THAN 57 X#define AT_LEAST 58 X#define EQUAL 59 X#define UNEQUAL 60 X#define Nonode 61 X X#define TAGformal 62 X#define TAGlocal 63 X#define TAGglobal 64 X#define TAGrefinement 65 X#define TAGzerfun 66 X#define TAGzerprd 67 X X#define ACTUAL 68 X#define FORMAL 69 X X#ifndef GFX X X#define COLON_NODE 70 X /* special node on top of suite inside WHILE or TEST_SUITE */ X#define NTYPES 71 X /* number of nodetypes */ X X#else /* GFX */ X X#define SPACE 70 X#define LINE 71 X#define CLEAR 72 X#define GFX_first SPACE X#define GFX_last CLEAR X X#define COLON_NODE 73 X#define NTYPES 74 X X#endif /* GFX */ X Xvalue node1(); Xvalue node2(); Xvalue node3(); Xvalue node4(); Xvalue node5(); Xvalue node6(); Xvalue node8(); Xvalue node9(); Xtypenode nodetype(); X/* Procedure display(); */ X/* Procedure fix_nodes(); */ X X#define First_fieldnr 0 X X#define UNIT_NAME First_fieldnr X#define HOW_FORMALS First_fieldnr + 1 /* HOW'TO */ X#define HOW_COMMENT First_fieldnr + 2 X#define HOW_SUITE First_fieldnr + 3 X#define HOW_REFINEMENT First_fieldnr + 4 X#define HOW_R_NAMES First_fieldnr + 5 X#define HOW_NLOCALS First_fieldnr + 6 X#define FPR_ADICITY First_fieldnr + 1 /* YIELD, TEST */ X#define FPR_FORMALS First_fieldnr + 2 X#define FPR_COMMENT First_fieldnr + 3 X#define FPR_SUITE First_fieldnr + 4 X#define FPR_REFINEMENT First_fieldnr + 5 X#define FPR_R_NAMES First_fieldnr + 6 X#define FPR_NLOCALS First_fieldnr + 7 X X#define FML_KEYW First_fieldnr /* FORMALS HOW'TO */ X#define FML_TAG First_fieldnr + 1 X#define FML_NEXT First_fieldnr + 2 X X#define SUI_LINO First_fieldnr /* SUITE */ X#define SUI_CMD First_fieldnr + 1 X#define SUI_COMMENT First_fieldnr + 2 X#define SUI_NEXT First_fieldnr + 3 X#define REF_NAME First_fieldnr /* REFINEMENT */ X#define REF_COMMENT First_fieldnr + 1 X#define REF_SUITE First_fieldnr + 2 X#define REF_NEXT First_fieldnr + 3 X#define REF_START First_fieldnr + 4 X X#define PUT_EXPR First_fieldnr /* PUT */ X#define PUT_TARGET First_fieldnr + 1 X#define INS_EXPR First_fieldnr /* INSERT */ X#define INS_TARGET First_fieldnr + 1 X#define RMV_EXPR First_fieldnr /* REMOVE */ X#define RMV_TARGET First_fieldnr + 1 X#define SET_EXPR First_fieldnr /* SET'RANDOM */ X#define DEL_TARGET First_fieldnr /* DELETE */ X#define CHK_TEST First_fieldnr /* CHECK */ X#define SHR_TARGET First_fieldnr /* SHARE */ X X#define WRT_L_LINES First_fieldnr /* WRITE */ X#define WRT_EXPR First_fieldnr + 1 X#define WRT_R_LINES First_fieldnr + 2 X#define RD_TARGET First_fieldnr /* READ */ X#define RD_EXPR First_fieldnr + 1 X#define RDW_TARGET First_fieldnr /* READ'RAW */ X X#define IF_TEST First_fieldnr /* IF */ X#define IF_COMMENT First_fieldnr + 1 X#define IF_SUITE First_fieldnr + 2 X#define WHL_LINO First_fieldnr /* WHILE */ X#define WHL_TEST First_fieldnr + 1 X#define WHL_COMMENT First_fieldnr + 2 X#define WHL_SUITE First_fieldnr + 3 X#define FOR_TARGET First_fieldnr /* FOR */ X#define FOR_EXPR First_fieldnr + 1 X#define FOR_COMMENT First_fieldnr + 2 X#define FOR_SUITE First_fieldnr + 3 X X#define SLT_COMMENT First_fieldnr /* SELECT */ X#define SLT_TSUITE First_fieldnr + 1 X#define TSUI_LINO First_fieldnr /* TEST SUITE */ X#define TSUI_TEST First_fieldnr + 1 X#define TSUI_COMMENT First_fieldnr + 2 X#define TSUI_SUITE First_fieldnr + 3 X#define TSUI_NEXT First_fieldnr + 4 X#define ELSE_LINO First_fieldnr /* ELSE */ X#define ELSE_COMMENT First_fieldnr + 1 X#define ELSE_SUITE First_fieldnr + 2 X X#define RTN_EXPR First_fieldnr /* RETURN */ X#define RPT_TEST First_fieldnr /* REPORT */ X X#define UCMD_NAME First_fieldnr /* USER COMMAND */ X#define UCMD_ACTUALS First_fieldnr + 1 X#define UCMD_DEF First_fieldnr + 2 X#define ACT_KEYW First_fieldnr /* ACTUALS USER COMMAND */ X#define ACT_EXPR First_fieldnr + 1 X#define ACT_NEXT First_fieldnr + 2 X X#define ECMD_NAME First_fieldnr /* EXTENDED COMMAND */ X#define ECMD_ACTUALS First_fieldnr + 1 X X#define COMP_FIELD First_fieldnr /* COMPOUND */ X#define COLL_SEQ First_fieldnr /* COLLATERAL */ X#define MON_NAME First_fieldnr /* MONADIC FUNCTION */ X#define MON_RIGHT First_fieldnr + 1 X#define MON_FCT First_fieldnr + 2 X#define DYA_NAME First_fieldnr + 1 /* DYADIC FUNCTION */ X#define DYA_LEFT First_fieldnr X#define DYA_RIGHT First_fieldnr + 2 X#define DYA_FCT First_fieldnr + 3 X#define TAG_NAME First_fieldnr /* TAG */ X#define TAG_ID First_fieldnr + 1 X#define NUM_VALUE First_fieldnr /* NUMBER */ X#define NUM_TEXT First_fieldnr + 1 X#define XDIS_QUOTE First_fieldnr /* TEXT DIS */ X#define XDIS_NEXT First_fieldnr + 1 X#define XLIT_TEXT First_fieldnr /* TEXT LIT */ X#define XLIT_NEXT First_fieldnr + 1 X#define XCON_EXPR First_fieldnr /* TEXT CONV */ X#define XCON_NEXT First_fieldnr + 1 X#define LDIS_SEQ First_fieldnr /* LIST DIS */ X#define TDIS_SEQ First_fieldnr /* TAB_DIS */ X#define SEL_TABLE First_fieldnr /* SELECTION */ X#define SEL_KEY First_fieldnr + 1 X#define TRIM_LEFT First_fieldnr /* BEHEAD, CURTAIL */ X#define TRIM_RIGHT First_fieldnr + 1 X#define UNP_SEQ First_fieldnr /* UNPARSED */ X#define UNP_TEXT First_fieldnr + 1 X X#define AND_LEFT First_fieldnr /* AND */ X#define AND_RIGHT First_fieldnr + 1 X#define OR_LEFT First_fieldnr /* OR */ X#define OR_RIGHT First_fieldnr + 1 X#define NOT_RIGHT First_fieldnr /* NOT */ X#define QUA_TARGET First_fieldnr /* QUANTIFICATION */ X#define QUA_EXPR First_fieldnr + 1 X#define QUA_TEST First_fieldnr + 2 X#define REL_LEFT First_fieldnr /* ORDER TEST */ X#define REL_RIGHT First_fieldnr + 1 X X#ifdef GFX X#define SPACE_FROM First_fieldnr X#define SPACE_TO First_fieldnr + 1 X#define LINE_FROM First_fieldnr X#define LINE_TO First_fieldnr + 1 X#endif X X#define COLON_SUITE First_fieldnr /* COLON_NODE */ X END_OF_FILE if test 7578 -ne `wc -c <'abc/ihdrs/i2nod.h'`; then echo shar: \"'abc/ihdrs/i2nod.h'\" unpacked with wrong size! fi # end of 'abc/ihdrs/i2nod.h' fi if test -f 'abc/stc/i2tcp.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/stc/i2tcp.c'\" else echo shar: Extracting \"'abc/stc/i2tcp.c'\" \(7399 characters\) sed "s/^X//" >'abc/stc/i2tcp.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* polytype representation */ X X#include "b.h" X#include "bobj.h" X#include "i2stc.h" X X/* A polytype is a compound with two fields. X * The first field is a B text, and holds the typekind. X * If the typekind is 'Variable', the second field is X * a B text, holding the identifier of the variable; X * otherwise, the second field is a compound of sub(poly)types, X * indexed from 0 to one less then the number of subtypes. X */ X X#define Kin 0 X#define Sub 1 X#define Id Sub X#define Asc 0 X#define Key 1 X X#define Kind(u) ((typekind) *Field((value) (u), Kin)) X#define Psubtypes(u) (Field((value) (u), Sub)) X#define Ident(u) (*Field((value) (u), Id)) X Xtypekind var_kind; Xtypekind num_kind; Xtypekind tex_kind; Xtypekind lis_kind; Xtypekind tab_kind; Xtypekind com_kind; Xtypekind t_n_kind; Xtypekind l_t_kind; Xtypekind tlt_kind; Xtypekind err_kind; Xtypekind ext_kind; X Xpolytype num_type; Xpolytype tex_type; Xpolytype err_type; Xpolytype t_n_type; X X/* Making, setting and accessing (the fields of) polytypes */ X XVisible polytype mkt_polytype(k, nsub) typekind k; intlet nsub; { X value u; X X u = mk_compound(2); X *Field(u, Kin)= copy((value) k); X *Field(u, Sub)= mk_compound(nsub); X return (polytype) u; X} X XProcedure putsubtype(sub, u, isub) polytype sub, u; intlet isub; { X *Field(*Psubtypes(u), isub)= (value) sub; X} X Xtypekind kind(u) polytype u; { X return Kind(u); X} X Xintlet nsubtypes(u) polytype u; { X return Nfields(*Psubtypes(u)); X} X Xpolytype subtype(u, i) polytype u; intlet i; { X return (polytype) *Field(*Psubtypes(u), i); X} X Xpolytype asctype(u) polytype u; { X return subtype(u, Asc); X} X Xpolytype keytype(u) polytype u; { X return subtype(u, Key); X} X Xvalue ident(u) polytype u; { X return Ident(u); X} X X/* making new polytypes */ X Xpolytype mkt_number() { X return p_copy(num_type); X} X Xpolytype mkt_text() { X return p_copy(tex_type); X} X Xpolytype mkt_tn() { X return p_copy(t_n_type); X} X Xpolytype mkt_error() { X return p_copy(err_type); X} X Xpolytype mkt_list(s) polytype s; { X polytype u; X X u = mkt_polytype(lis_kind, 1); X putsubtype(s, u, Asc); X return u; X} X Xpolytype mkt_table(k, a) polytype k, a; { X polytype u; X X u = mkt_polytype(tab_kind, 2); X putsubtype(a, u, Asc); X putsubtype(k, u, Key); X return u; X} X Xpolytype mkt_lt(s) polytype s; { X polytype u; X X u = mkt_polytype(l_t_kind, 1); X putsubtype(s, u, Asc); X return u; X} X Xpolytype mkt_tlt(s) polytype s; { X polytype u; X X u = mkt_polytype(tlt_kind, 1); X putsubtype(s, u, Asc); X return u; X} X Xpolytype mkt_compound(nsub) intlet nsub; { X return mkt_polytype(com_kind, nsub); X} X Xpolytype mkt_var(id) value id; { X polytype u; X X u = mk_compound(2); X *Field(u, Kin)= copy((value) var_kind); X *Field(u, Id)= id; X return u; X} X XHidden value nnewvar; X Xpolytype mkt_newvar() { X value v; X v = sum(nnewvar, one); X release(nnewvar); X nnewvar = v; X return mkt_var(convert(nnewvar, No, No)); X} X XHidden value n_external; /* external variable types used by how-to's */ X XVisible Procedure new_externals() { X n_external= zero; X} X XVisible polytype mkt_ext() { X polytype u; X value v; X X v = sum(n_external, one); X release(n_external); X n_external = v; X X u= mk_compound(2); X *Field(u, Kin)= copy((value) ext_kind); X *Field(u, Id)= convert(n_external, No, No); X X return u; X} X Xpolytype p_copy(u) polytype u; { X return (polytype) copy((polytype) u); X} X XProcedure p_release(u) polytype u; { X release((polytype) u); X} X X/* predicates */ X Xbool are_same_types(u, v) polytype u, v; { X if (compare((value) Kind(u), (value) Kind(v)) != 0) X return No; X else if (t_is_var(Kind(u))) X return (compare(Ident(u), Ident(v)) == 0); X else X return ( X (nsubtypes(u) == nsubtypes(v)) X && X (compare(*Psubtypes(u), *Psubtypes(v)) == 0) X ); X} X Xbool have_same_structure(u, v) polytype u, v; { X return( X (compare((value) Kind(u), (value) Kind(v)) == 0) X && X nsubtypes(u) == nsubtypes(v) X ); X} X Xbool t_is_number(kind) typekind kind; { X return (compare((value) kind, (value) num_kind) == 0 ? Yes : No); X} X Xbool t_is_text(kind) typekind kind; { X return (compare((value) kind, (value) tex_kind) == 0 ? Yes : No); X} X Xbool t_is_tn(kind) typekind kind; { X return (compare((value) kind, (value) t_n_kind) == 0 ? Yes : No); X} X Xbool t_is_error(kind) typekind kind; { X return (compare((value) kind, (value) err_kind) == 0 ? Yes : No); X} X Xbool t_is_list(kind) typekind kind; { X return (compare((value) kind, (value) lis_kind) == 0 ? Yes : No); X} X Xbool t_is_table(kind) typekind kind; { X return (compare((value) kind, (value) tab_kind) == 0 ? Yes : No); X} X Xbool t_is_lt(kind) typekind kind; { X return (compare((value) kind, (value) l_t_kind) == 0 ? Yes : No); X} X Xbool t_is_tlt(kind) typekind kind; { X return (compare((value) kind, (value) tlt_kind) == 0 ? Yes : No); X} X Xbool t_is_compound(kind) typekind kind; { X return (compare((value) kind, (value) com_kind) == 0 ? Yes : No); X} X Xbool t_is_var(kind) typekind kind; { X return (compare((value) kind, (value) var_kind) == 0 ? Yes : No); X} X Xbool t_is_ext(kind) typekind kind; { X return (compare((value) kind, (value) ext_kind) == 0 ? Yes : No); X} X Xbool has_number(kind) typekind kind; { X if (compare(kind, num_kind) == 0 || compare(kind, t_n_kind) == 0) X return Yes; X else X return No; X} X Xbool has_text(kind) typekind kind; { X if (compare(kind, tex_kind) == 0 || compare(kind, t_n_kind) == 0) X return Yes; X else X return No; X} X Xbool has_lt(kind) typekind kind; { X if (compare(kind, l_t_kind) == 0 || compare(kind, tlt_kind) == 0) X return Yes; X else X return No; X} X X/* The table "ptype_of" maps the identifiers of the variables (B texts) X * to polytypes. X */ X Xvalue ptype_of; X XProcedure repl_type_of(u, p) polytype u, p; { X replace((value) p, &ptype_of, Ident(u)); X} X Xbool table_has_type_of(u) polytype u; { X return in_keys(Ident(u), ptype_of); X} X X#define Table_type_of(u) ((polytype) *adrassoc(ptype_of, Ident(u))) X XVisible polytype bottomtype(u) polytype u; { X while (t_is_var(Kind(u)) && table_has_type_of(u)) { X u = Table_type_of(u); X } X return u; X} X Xpolytype bottomvar(u) polytype u; { X polytype b; X X if (!t_is_var(Kind(u))) X return u; X /* Kind(u) == Variable */ X while (table_has_type_of(u)) { X b = Table_type_of(u); X if (t_is_var(Kind(b))) X u = b; X else X break; X } X /* Kind(u) == Variable && X !(table_has_type_of(u) && Kind(Table_type_of(u)) == Variable) */ X return u; X} X XVisible Procedure usetypetable(t) value t; { X ptype_of = t; X} X XVisible Procedure deltypetable() { X release(ptype_of); X} X X/* init */ X XVisible Procedure initpol() { X num_kind = mk_text("Number"); X num_type = mkt_polytype(num_kind, 0); X tex_kind = mk_text("Text"); X tex_type = mkt_polytype(tex_kind, 0); X t_n_kind = mk_text("TN"); X t_n_type = mkt_polytype(t_n_kind, 0); X err_kind = mk_text("Error"); X err_type = mkt_polytype(err_kind, 0); X X lis_kind = mk_text("List"); X tab_kind = mk_text("Table"); X com_kind = mk_text("Compound"); X l_t_kind = mk_text("LT"); X tlt_kind = mk_text("TLT"); X var_kind = mk_text("Variable"); X ext_kind = mk_text("External"); X X nnewvar = zero; X} X XVisible Procedure endpol() { X release((value) num_kind); X release((value) num_type); X release((value) tex_kind); X release((value) tex_type); X release((value) t_n_kind); X release((value) t_n_type); X release((value) err_kind); X release((value) err_type); X release((value) lis_kind); X release((value) tab_kind); X release((value) com_kind); X release((value) l_t_kind); X release((value) tlt_kind); X release((value) var_kind); X} END_OF_FILE if test 7399 -ne `wc -c <'abc/stc/i2tcp.c'`; then echo shar: \"'abc/stc/i2tcp.c'\" unpacked with wrong size! fi # end of 'abc/stc/i2tcp.c' fi echo shar: End of archive 18 \(of 25\). cp /dev/null ark18isdone 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@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.