v23i097: ABC interactive programming environment, Part18/25
Rich Salz
rsalz at bbn.com
Thu Dec 20 04:54:22 AEST 1990
Submitted-by: Steven Pemberton <steven at 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 at 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 at 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 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