v23i096: ABC interactive programming environment, Part17/25
Rich Salz
rsalz at bbn.com
Thu Dec 20 04:54:06 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 96
Archive-name: abc/part17
#! /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/e1inse.c abc/bed/e1move.c abc/bed/e1outp.c
# abc/bint1/i1nui.c abc/bint3/i3gfx.c abc/lin/i1tlt.h
# abc/stc/i2tce.c
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:28:12 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 17 (of 25)."'
if test -f 'abc/bed/e1inse.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1inse.c'\"
else
echo shar: Extracting \"'abc/bed/e1inse.c'\" \(7653 characters\)
sed "s/^X//" >'abc/bed/e1inse.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * Subroutines (refinements) for ins_string() (see que2.c).
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.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"
X
X
X/*
X * Try to insert the character c in the focus *pp.
X */
X
XVisible bool
Xinsguess(pp, c, ep)
X path *pp;
X char c;
X environ *ep;
X{
X path pa = parent(*pp);
X node n;
X int sympa = pa ? symbol(tree(pa)) : Rootsymbol;
X int ich = ichild(*pp);
X struct classinfo *ci = table[sympa].r_class[ich-1];
X classptr cp;
X string *rp;
X int code = Code(c);
X int sym;
X char buf[2];
X
X#ifdef USERSUGG
X if (isascii(c) && isinclass(Suggestion, ci)
X && (isalpha(c) || (c == ':' && sympa == Rootsymbol)))
X {
X if (setsugg(pp, c, ep, allows_colon(sympa)))
X return Yes;
X }
X#endif /* USERSUGG */
X for (cp = ci->c_insert; *cp; cp += 2) {
X if (cp[0] == code)
X break;
X }
X if (!*cp)
X return No;
X sym = cp[1];
X if (sym >= LEXICAL) {
X buf[0] = c;
X buf[1] = 0;
X treereplace(pp, (node) mk_etext(buf));
X ep->mode = VHOLE;
X ep->s1 = 2*ich;
X ep->s2 = 1;
X return Yes;
X }
X Assert(sym < TABLEN);
X rp = table[sym].r_repr;
X n = table[sym].r_node;
X if (Fw_zero(rp[0])) {
X buf[0] = c;
X buf[1] = 0;
X setchild(&n, 1, (node) mk_etext(buf));
X treereplace(pp, n);
X ep->mode = VHOLE;
X ep->s1 = 2;
X ep->s2 = 1;
X return Yes;
X }
X treereplace(pp, n);
X if (c == '\n' || c == '\r') {
X ep->mode = SUBSET;
X ep->s1 = ep->s2 = 2;
X }
X else {
X ep->mode = FHOLE;
X ep->s1 = 1;
X ep->s2 = 1;
X }
X return Yes;
X}
X
X
X/*
X * Test whether character `c' may be inserted in position `s2' in
X * child `ich' of node `n'; that child must be a Text.
X */
X
XVisible bool
Xmayinsert(n, ich, s2, c)
X node n;
X int ich;
X int s2;
X register char c;
X{
X int sympa = symbol(n);
X struct classinfo *ci;
X register classptr cp;
X register value v = (value) child(n, ich);
X register char c1;
X bool maycontinue();
X bool maystart();
X register bool (*fun1)() = s2 > 0 ? /*&*/maystart : /*&*/maycontinue;
X register bool (*fun2)() = s2 > 0 ? /*&*/maycontinue : /*&*/maystart;
X
X Assert(v && v->type == Etex);
X Assert(sympa > 0 && sympa < TABLEN);
X ci = table[sympa].r_class[ich-1];
X Assert(ci && ci->c_class);
X /* c1 = strval(v)[0]; */
X c1= e_ncharval(1, v);
X for (cp = ci->c_class; *cp; ++cp) {
X if (*cp >= LEXICAL && (*fun1)(c1, *cp)) {
X if ((*fun2)(c, *cp))
X return Yes;
X }
X }
X return No;
X}
X
X
X/*
X * Change a Fixed into a Variable node, given a string pointer variable
X * which contains the next characters to be inserted.
X * If the change is not appropriate, No is returned.
X * Otherwise, as many (though maybe zero) characters from the string
X * as possible will have been incorporated in the string node.
X */
X
XVisible bool
Xsoften(ep, pstr, alt_c)
X environ *ep;
X string *pstr;
X int alt_c;
X{
X path pa = parent(ep->focus);
X node n;
X int sympa = pa ? symbol(tree(pa)) : Rootsymbol;
X struct classinfo *ci;
X register classptr cp;
X register int code;
X string repr;
X register struct table *tp;
X char buf[1024];
X
X if (ep->mode == VHOLE && (ep->s1&1))
X ep->mode = FHOLE;
X if (ep->mode != FHOLE || ep->s1 != 1 || ep->s2 <= 0 || !issuggestion(ep))
X return No;
X n = tree(ep->focus);
X repr = noderepr(n)[0];
X if (!repr || !isupper(repr[0]))
X return No;
X if (symbol(n) == Select && repr[ep->s2-1] == ':')
X return No;
X if (symbol(n) == Head)
X return No;
X code = Code(repr[0]);
X ci = table[sympa].r_class[ichild(ep->focus) - 1];
X n = Nnil;
X for (cp = ci->c_insert; *cp; cp += 2) {
X if (cp[0] != code)
X continue;
X if (cp[1] >= TABLEN)
X continue;
X tp = &table[cp[1]];
X if (Fw_zero(tp->r_repr[0])) {
X Assert(tp->r_class[0]->c_class[0] >= LEXICAL);
X n = tp->r_node;
X break;
X }
X }
X if (!n)
X return No;
X strncpy(buf, repr, ep->s2);
X buf[ep->s2] = 0;
X setchild(&n, 1, (node) mk_etext(buf));
X if (!mayinsert(n, 1, ep->s2, repr[ep->s2])) {
X if (!**pstr || !mayinsert(n, 1, ep->s2, **pstr)
X && (!alt_c || !mayinsert(n, 1, ep->s2, alt_c))) {
X noderelease(n); /* Don't forget! */
X return No;
X }
X }
X if (!ep->spflag && **pstr && mayinsert(n, 1, ep->s2, **pstr)) {
X do {
X buf[ep->s2] = **pstr;
X ++*pstr;
X ++ep->s2;
X } while (ep->s2 < sizeof buf - 1 && **pstr
X && mayinsert(n, 1, ep->s2, **pstr));
X buf[ep->s2] = 0;
X setchild(&n, 1, (node) mk_etext(buf));
X }
X treereplace(&ep->focus, n);
X ep->mode = VHOLE;
X ep->s1 = 2;
X return Yes;
X}
X
X
X/*
X * Renew suggestion, or advance in old suggestion.
X * Return Yes if *pstr has been advanced.
X */
X
XVisible bool
Xresuggest(ep, pstr, alt_c)
X environ *ep;
X string *pstr;
X int alt_c;
X{
X struct table *tp;
X struct classinfo *ci;
X classptr cp;
X path pa;
X node nn;
X node n = tree(ep->focus);
X register string *oldrp = noderepr(n);
X register int ich = ep->s1/2;
X register string str = oldrp[ich];
X int oldsym = symbol(n);
X int childsym[MAXCHILD];
X string *newrp;
X int sympa;
X register int sym;
X int symfound = -1;
X register int i;
X int code;
X char buf[15]; /* Should be sufficient for all fixed texts */
X bool ok;
X bool anyok = No;
X
X if (!str || !**pstr || !issuggestion(ep))
X return No;
X /***** Change this if commands can be prefixes of others! *****/
X /***** Well, they can!
X if (!c)
X return No;
X *****/
X
X if (ich > 0 && ifmatch(ep, pstr, str, alt_c))
X /* Shortcut: sec. keyword, exact match will do just fine */
X return Yes;
X if (ep->s2 <= 0 || Fw_zero(oldrp[0]))
X return No;
X if (**pstr != ' ' && !isupper(**pstr)
X && !alt_c && **pstr != '"' && **pstr != '\'' && **pstr != '.')
X /* Shortcut: not a keyword, must match exactly */
X return ifmatch(ep, pstr, str, alt_c);
X for (i = 0; i < ich; ++i) { /* Preset some stuff for main loop */
X if (!oldrp[i])
X oldrp[i] = "";
X childsym[i] = symbol(child(n, i+1));
X }
X Assert(ep->s2 + 1 < sizeof buf);
X strcpy(buf, oldrp[ich]);
X buf[ep->s2] = alt_c ? alt_c : **pstr;
X buf[ep->s2 + 1] = 0;
X pa = parent(ep->focus);
X sympa = pa ? symbol(tree(pa)) : Rootsymbol;
X ci = table[sympa].r_class[ichild(ep->focus) - 1];
X code = Code(oldrp[0][0]);
X
X for (cp = ci->c_insert; *cp; cp += 2) {
X if (cp[0] != code)
X continue;
X sym = cp[1];
X if (sym >= TABLEN)
X continue;
X if (sym == oldsym) {
X anyok = Yes;
X continue;
X }
X tp = &table[sym];
X newrp = tp->r_repr;
X ok = Yes;
X for (i = 0; i < ich; ++i) {
X str = newrp[i];
X if (!str)
X str = "";
X if (strcmp(str, oldrp[i])
X || childsym[i] != Optional && childsym[i] != Hole
X && !isinclass(childsym[i], tp->r_class[i])) {
X ok = No;
X break;
X }
X }
X if (!ok)
X continue;
X str = newrp[i];
X if (!str || strncmp(str, buf, ep->s2+1))
X continue;
X if (anyok) {
X if (!strcmp(str, oldrp[ich]))
X continue; /* Same as it was: no new suggestion */
X symfound = sym;
X break;
X }
X else if (symfound < 0 && strcmp(str, oldrp[ich]))
X symfound = sym;
X }
X
X if (symfound < 0) {
X return ifmatch(ep, pstr, oldrp[ich], alt_c);
X }
X nn = table[symfound].r_node;
X for (i = 1; i <= ich; ++i) { /* Copy children to the left of the focus */
X sym = symbol(child(n, i));
X if (sym == Optional || sym == Hole)
X continue;
X setchild(&nn, i, nodecopy(child(n, i)));
X }
X treereplace(&ep->focus, nn);
X str = newrp[ich];
X do { /* Find easy continuation */
X ++ep->s2;
X ++*pstr;
X } while (**pstr && **pstr == str[ep->s2]);
X
X return Yes;
X}
X
X
X/*
X * Refinement for resuggest(): see if there is a match, and if so, find
X * longest match.
X */
X
XHidden bool
Xifmatch(ep, pstr, str, alt_c)
X register environ *ep;
X register string *pstr;
X register string str;
X register int alt_c;
X{
X register int c = str[ep->s2];
X
X if (c != **pstr && (!alt_c || c != alt_c))
X return No;
X do {
X ++ep->s2;
X ++*pstr;
X } while (**pstr && **pstr == str[ep->s2]);
X
X return Yes;
X}
END_OF_FILE
if test 7653 -ne `wc -c <'abc/bed/e1inse.c'`; then
echo shar: \"'abc/bed/e1inse.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1inse.c'
fi
if test -f 'abc/bed/e1move.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1move.c'\"
else
echo shar: Extracting \"'abc/bed/e1move.c'\" \(7754 characters\)
sed "s/^X//" >'abc/bed/e1move.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Process arrow keys in four directions, plus TAB.
X */
X
X#include "b.h"
X#include "feat.h"
X#include "bedi.h"
X#include "etex.h"
X#include "bobj.h"
X#include "node.h"
X#include "supr.h"
X#include "gram.h"
X#include "tabl.h"
X
X#define Left (-1)
X#define Rite 1
X
X
X/*
X * Common code for PREVIOUS and NEXT commands.
X */
X
XHidden bool
Xprevnext(ep, direction)
X environ *ep;
X{
X node n;
X node n1;
X int nch;
X int i;
X int len;
X int sym;
X string *rp;
X
X higher(ep);
X switch (ep->mode) {
X case VHOLE:
X case FHOLE:
X case ATBEGIN:
X case ATEND:
X if (direction == Left)
X leftvhole(ep);
X else
X ritevhole(ep);
X }
X
X for (;;) {
X n = tree(ep->focus);
X nch = nchildren(n);
X rp = noderepr(n);
X
X switch (ep->mode) {
X
X case ATBEGIN:
X case ATEND:
X ep->mode = WHOLE;
X continue;
X
X case VHOLE:
X case FHOLE:
X if (direction == Rite) {
X if (ep->s1&1)
X len = Fwidth(rp[ep->s1/2]);
X else {
X n1 = child(n, ep->s1/2);
X len = nodewidth(n1);
X }
X }
X if (direction == Rite ? ep->s2 >= len : ep->s2 <= 0) {
X ep->mode = SUBSET;
X ep->s2 = ep->s1;
X return nextchar(ep, direction);
X }
X ep->s2 += direction;
X return Yes;
X
X case SUBRANGE:
X if (direction == Rite) {
X if (ep->s1&1)
X len = Fwidth(rp[ep->s1/2]);
X else {
X n1 = child(n, ep->s1/2);
X len = nodewidth(n1);
X }
X }
X if (direction == Left ? ep->s2 <= 0 : ep->s3 >= len-1) {
X ep->mode = SUBSET;
X ep->s2 = ep->s1;
X return nextchar(ep, direction);
X }
X if (direction == Rite)
X ep->s2 = ++ep->s3;
X else
X ep->s3 = --ep->s2;
X return Yes;
X
X case SUBSET:
X if (direction == Rite ? ep->s2 > 2*nch : ep->s1 <= 1) {
X ep->mode = WHOLE;
X continue;
X }
X if (direction == Rite)
X ep->s1 = ++ep->s2;
X else
X ep->s2 = --ep->s1;
X if (ep->s1&1) {
X if (!Fw_positive(rp[ep->s1/2]) || allspaces(rp[ep->s1/2]))
X continue;
X }
X else {
X sym = symbol(n);
X if (downi(&ep->focus, ep->s1/2)) {
X n = tree(ep->focus);
X if (((value)n)->type == Etex)
X s_up(ep);
X else {
X if (ep->s1 == 2*nch && direction == Rite
X && issublist(sym) && samelevel(sym, symbol(n))) {
X ep->mode = SUBLIST;
X ep->s3 = 1;
X return Yes;
X }
X ep->mode = WHOLE;
X if (nodewidth(n) == 0)
X continue;
X }
X }
X }
X return Yes;
X
X case SUBLIST:
X sym = symbol(n);
X if (direction == Left) {
X i = ichild(ep->focus);
X if (!up(&ep->focus))
X return No;
X higher(ep);
X n = tree(ep->focus);
X if (i == nchildren(n) && samelevel(sym, symbol(n))) {
X ep->s3 = 1;
X return Yes;
X }
X ep->mode = SUBSET;
X ep->s1 = ep->s2 = 2*i;
X continue;
X }
X for (i = ep->s3; i > 0; --i)
X if (!downrite(&ep->focus))
X return No; /* Sorry... */
X if (samelevel(sym, symbol(tree(ep->focus))))
X ep->s3 = 1;
X else
X ep->mode = WHOLE;
X return Yes;
X
X case WHOLE:
X i = ichild(ep->focus);
X if (!up(&ep->focus))
X return No;
X higher(ep);
X ep->mode = SUBSET;
X ep->s1 = ep->s2 = 2*i;
X continue;
X
X default:
X Abort();
X }
X }
X /* Not reached */
X}
X
X
XVisible bool
Xprevious(ep)
X environ *ep;
X{
X if (!prevnext(ep, Left))
X return No;
X return Yes;
X}
X
X
XVisible bool
Xnextarrow(ep)
X environ *ep;
X{
X if (!prevnext(ep, Rite))
X return No;
X return Yes;
X}
X
XVisible bool
Xleftarrow(ep)
X environ *ep;
X{
X int w;
X bool hole;
X
X if (narrow(ep)) {
X while (narrow(ep))
X ;
X return Yes;
X }
X hole= ep->mode == WHOLE;
X if (!previous(ep))
X return No;
X if (hole) {
X for (;;) {
X w= focwidth(ep);
X if (w >= 0 && w <= 1)
X break;
X if (!rnarrow(ep))
X return No;
X }
X VOID narrow(ep);
X }
X else {
X while (rnarrow(ep))
X ;
X }
X return Yes;
X}
X
XVisible bool
Xritearrow(ep)
X environ *ep;
X{
X while (narrow(ep))
X ;
X if (!nextarrow(ep))
X return No;
X while (narrow(ep))
X ;
X return Yes;
X}
X
X/*
X * Position focus at next or previous char relative to current position.
X * Assume current position given as SUBSET.
X */
X
XHidden bool
Xnextchar(ep, direction)
X register environ *ep;
X register int direction;
X{
X register int ich;
X register int nch;
X register node n;
X node n1;
X register int len;
X string *rp;
X
X Assert(ep->mode == SUBSET);
X for (;;) {
X n = tree(ep->focus);
X rp = noderepr(n);
X nch = nchildren(n);
X if (direction == Left)
X ep->s2 = --ep->s1;
X else
X ep->s1 = ++ep->s2;
X if (direction == Left ? ep->s1 < 1 : ep->s2 > 2*nch+1) {
X ich = ichild(ep->focus);
X if (!up(&ep->focus))
X return No; /* *ep is garbage now! */
X higher(ep);
X ep->s1 = ep->s2 = 2*ich;
X continue;
X }
X if (ep->s1&1) {
X len = Fwidth(rp[ep->s1/2]);
X if (len > 0) {
X ep->mode = SUBRANGE;
X ep->s2 = ep->s3 = direction == Left ? len-1 : 0;
X return Yes;
X }
X continue;
X }
X n1 = child(n, ep->s1/2);
X len = nodewidth(n1);
X if (len == 0)
X continue;
X if (!downi(&ep->focus, ep->s1/2))
X return No; /* Sorry... */
X n = tree(ep->focus);
X if (((value)n)->type == Etex) {
X s_up(ep);
X ep->mode = SUBRANGE;
X ep->s2 = ep->s3 = direction == Left ? len-1 : 0;
X return Yes;
X }
X if (direction == Left) {
X nch = nchildren(n);
X ep->s1 = ep->s2 = 2*(nch+1);
X }
X else
X ep->s1 = ep->s2 = 0;
X }
X /* Not reached */
X}
X
X
X/*
X * Up and down arrows.
X */
X
XHidden bool
Xupdownarrow(ep, yincr)
X environ *ep;
X int yincr;
X{
X int y, x;
X
X while (narrow(ep))
X ;
X y= lineno(ep) + yincr;
X x= colno(ep);
X if (!gotoyx(ep, y, x))
X return No;
X gotofix(ep, y, x);
X while (narrow(ep))
X ;
X return Yes;
X}
X
XVisible bool
Xuparrow(ep)
X environ *ep;
X{
X return updownarrow(ep, -1);
X}
X
XVisible bool
Xdownarrow(ep)
X environ *ep;
X{
X return updownarrow(ep, 1);
X}
X
XVisible bool
Xupline(ep)
X register environ *ep;
X{
X register int y;
X
X y = lineno(ep);
X if (y <= 0)
X return No;
X if (!gotoyx(ep, y-1, 0))
X return No;
X oneline(ep);
X return Yes;
X}
X
XVisible bool
Xdownline(ep)
X register environ *ep;
X{
X register int w;
X
X if (!parent(ep->focus) && ep->mode == ATEND)
X return No; /* Superfluous? */
X w = -focwidth(ep);
X if (w <= 0)
X w = 1;
X if (!gotoyx(ep, lineno(ep) + w, 0))
X return No;
X oneline(ep);
X return Yes;
X}
X
X
X/*
X * ACCEPT command
X * move to next Hole hole or to end of suggestion or to end of line.
X */
X
X
XVisible bool
Xaccept(ep)
X environ *ep;
X{
X int i;
X string repr;
X
X shrink(ep);
X switch (ep->mode) {
X case ATBEGIN:
X case ATEND:
X case FHOLE:
X case VHOLE:
X ritevhole(ep);
X }
X#ifdef USERSUGG
X if (symbol(tree(ep->focus)) == Sugghowname)
X ackhowsugg(ep);
X#endif
X if (symbol(tree(ep->focus)) == Hole) {
X ep->mode = WHOLE;
X return No;
X }
X switch (ep->mode) {
X case ATBEGIN:
X case SUBLIST:
X case WHOLE:
X i = 1;
X break;
X case ATEND:
X i = 2*nchildren(tree(ep->focus)) + 2;
X break;
X case SUBRANGE:
X case VHOLE:
X case FHOLE:
X i = ep->s1;
X if (ep->s2 > 0 && i > 2*nchildren(tree(ep->focus)))
X ++i; /* Kludge so after E?LSE: the focus moves to ELSE: ? */
X break;
X case SUBSET:
X i = ep->s1 - 1;
X break;
X default:
X Abort();
X }
X ep->mode = WHOLE;
X for (;;) {
X if (i/2 == nchildren(tree(ep->focus))) {
X repr = noderepr(tree(ep->focus))[i/2];
X if (Fw_positive(repr))
X break;
X }
X if (tabstop(ep, i + 1))
X return Yes;
X i = 2*ichild(ep->focus) + 1;
X if (!up(&ep->focus))
X break;
X higher(ep);
X }
X ep->mode = ATEND;
X return Yes;
X}
X
X
X/*
X * Find suitable tab stops for accept.
X */
X
XHidden bool
Xtabstop(ep, i)
X environ *ep;
X int i;
X{
X node n = tree(ep->focus);
X int nch;
X string repr;
X
X if (Is_etext(n))
X return No;
X nch = nchildren(n);
X if (i/2 > nch)
X return No;
X if (symbol(n) == Hole) {
X ep->mode = WHOLE;
X return Yes;
X }
X if (i < 2) {
X i = 2;
X if (nodewidth(n) < 0) {
X repr = noderepr(n)[0];
X if (Fw_negative(repr)) {
X ep->mode = ATBEGIN;
X leftvhole(ep);
X return Yes;
X }
X }
X }
X for (i /= 2; i <= nch; ++i) {
X s_downi(ep, i);
X if (tabstop(ep, 1))
X return Yes;
X s_up(ep);
X }
X return No;
X}
END_OF_FILE
if test 7754 -ne `wc -c <'abc/bed/e1move.c'`; then
echo shar: \"'abc/bed/e1move.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1move.c'
fi
if test -f 'abc/bed/e1outp.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1outp.c'\"
else
echo shar: Extracting \"'abc/bed/e1outp.c'\" \(7976 characters\)
sed "s/^X//" >'abc/bed/e1outp.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Screen management package, lower level output part.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "bobj.h"
X#include "bmem.h"
X#include "node.h"
X#include "supr.h"
X#include "gram.h"
X#include "cell.h"
X#include "tabl.h"
X
X#define SOBIT 0200
X#define CHAR 0177
X
X/*
X * Variables used for communication with outfocus.
X */
X
XHidden node thefocus;
XHidden environ wherebuf;
XHidden environ *where = &wherebuf;
XHidden bool realvhole;
XHidden int multiline; /* Height of focus */
XHidden int yfocus;
X
XVisible int focy; /* Where the cursor must go */
XVisible int focx;
X
X
X/*
X * Save position of the focus for use by outnode/outfocus.
X */
X
XVisible Procedure
Xsavefocus(ep)
X register environ *ep;
X{
X register int sym;
X register int w;
X
X realvhole = No;
X thefocus = Nnil;
X multiline = 0;
X yfocus = Ycoord(ep->focus);
X w = focoffset(ep);
X if (w < 0)
X yfocus += -w;
X w = focwidth(ep);
X if (w < 0) {
X multiline = -w;
X if (focchar(ep) == '\n')
X ++yfocus;
X else
X ++multiline;
X return;
X }
X if (ep->mode == WHOLE) {
X sym = symbol(tree(ep->focus));
X if (sym == Optional)
X ep->mode = ATBEGIN;
X }
X switch(ep->mode) {
X case VHOLE:
X if (ep->s1&1)
X ep->mode = FHOLE;
X case ATBEGIN:
X case ATEND:
X case FHOLE:
X ritevhole(ep);
X switch (ep->mode) {
X case ATBEGIN:
X case FHOLE:
X sym = symbol(tree(ep->focus));
X if (sym == Hole && (ep->mode == ATBEGIN || ep->s2 == 0)) {
X ep->mode = WHOLE;
X break;
X }
X /* Fall through */
X case VHOLE:
X case ATEND:
X leftvhole(ep);
X realvhole = 1 + ep->spflag;
X }
X }
X touchpath(&ep->focus); /* Make sure it is a unique pointer */
X thefocus = tree(ep->focus); /* No copy; used for comparison only! */
X where->mode = ep->mode;
X where->s1 = ep->s1;
X where->s2 = ep->s2;
X where->s3 = ep->s3;
X where->spflag = ep->spflag;
X}
X
X
X/*
X * Incorporate the information saved about the focus.
X */
X
XVisible Procedure
Xsetfocus(tops)
X register cell *tops;
X{
X register cell *p;
X register int i;
X
X for (p = tops, i = 0; i < yfocus; ++i, p = p->c_link) {
X if (!p) {
X#ifndef NDEBUG
X debug("[Focus lost (setfocus)]");
X#endif /* NDEBUG */
X return;
X }
X }
X p->c_newvhole = realvhole;
X i = multiline;
X do {
X p->c_newfocus = Yes;
X p = p->c_link;
X } while (--i > 0);
X}
X
X
X/*
X * Signal that actual updata is started.
X */
X
XVisible Procedure
Xstartactupdate(nofocus)
X bool nofocus;
X{
X if (nofocus) {
X multiline = 0;
X thefocus = Nnil;
X }
X}
X
X
X/*
X * Signal the end of the actual update.
X */
X
XVisible Procedure
Xendactupdate()
X{
X}
X
X
X/*
X * Output a line of text.
X */
X
XVisible Procedure
Xoutline(p, lineno)
X register cell *p;
X register int lineno;
X{
X register node n = p->c_data;
X register int w = nodewidth(n);
X register int len= p->c_newindent + 4 + (w < 0 ? linelen(n) : w);
X /* some 4 extra for spflag and vhole */
X register string buf;
X auto string bp;
X register int i;
X register int endarea = lineno+Space(p)-1;
X
X buf= (string) getmem((unsigned) len);
X bp= buf;
X if (endarea >= winheight)
X endarea = winheight-1;
X for (i = p->c_newindent; i-- > 0; )
X *bp++ = ' ';
X if (!p->c_newfocus) {
X smash(&bp, n, 0);
X *bp = 0;
X Assert(bp-buf < len);
X }
X else {
X if (multiline)
X smash(&bp, n, SOBIT);
X else if (n == thefocus)
X focsmash(&bp, n);
X else
X smash(&bp, n, 0);
X *bp = 0;
X Assert(bp-buf < len);
X for (bp = buf; *bp && !(*bp&SOBIT); ++bp)
X ;
X if (*bp&SOBIT) {
X if (focy == Nowhere) {
X focx = indent + bp-buf;
X focy = lineno + focx/llength;
X focx %= llength;
X }
X if (multiline <= 1 && !(bp[1]&SOBIT))
X *bp &= ~SOBIT; /* Clear mask if just one char in focus */
X }
X }
X trmputdata(lineno, endarea, indent, buf);
X freemem((ptr) buf);
X}
X
X
X/*
X * Smash -- produce a linear version of a node in a buffer (which had
X * better be long enough!). The buffer pointer is moved to the end of
X * the resulting string.
X * Care is taken to represent the focus.
X * Characters in the focus have their upper bit set.
X */
X
X#define Outvhole() \
X (where->spflag && strsmash(pbuf, " ", 0), strsmash(pbuf, "?", SOBIT))
X
XHidden Procedure
Xfocsmash(pbuf, n)
X string *pbuf;
X node n;
X{
X value v;
X string str;
X register string *rp;
X register int maxs2;
X register int i;
X register bool ok;
X register int j;
X register int mask;
X
X switch (where->mode) {
X
X case WHOLE:
X smash(pbuf, n, SOBIT);
X break;
X
X case ATBEGIN:
X Outvhole();
X smash(pbuf, n, 0);
X break;
X
X case ATEND:
X smash(pbuf, n, 0);
X Outvhole();
X break;
X
X case VHOLE:
X if (!(where->s1&1)) {
X v = (value) child(n, where->s1/2);
X Assert(Is_etext(v));
X str= e_sstrval(v);
X subsmash(pbuf, str, where->s2, 0);
X Outvhole();
X j= symbol(n);
X i= str[where->s2] == '?' &&
X (j == Suggestion || j == Sugghowname);
X strsmash(pbuf, str + where->s2 + i, 0);
X e_fstrval(str);
X break;
X }
X /* Else, fall through */
X case FHOLE:
X rp = noderepr(n);
X maxs2 = 2*nchildren(n) + 1;
X for (ok = Yes, i = 1; ok && i <= maxs2; ++i) {
X if (i&1) {
X if (i == where->s1) {
X subsmash(pbuf, rp[i/2], where->s2, 0);
X Outvhole();
X if (rp[i/2])
X strsmash(pbuf, rp[i/2] + where->s2, 0);
X }
X else
X strsmash(pbuf, rp[i/2], 0);
X }
X else
X ok = chismash(pbuf, n, i/2, 0);
X }
X break;
X
X case SUBRANGE:
X rp = noderepr(n);
X maxs2 = 2*nchildren(n) + 1;
X for (ok = Yes, i = 1; ok && i <= maxs2; ++i) {
X if (i&1) {
X if (i == where->s1) {
X subsmash(pbuf, rp[i/2], where->s2,0);
X if (rp[i/2])
X subsmash(pbuf, rp[i/2] + where->s2,
X where->s3 - where->s2 + 1, SOBIT);
X if (rp[i/2])
X strsmash(pbuf, rp[i/2] + where->s3 + 1, 0);
X }
X else
X strsmash(pbuf, rp[i/2], 0);
X }
X else if (i == where->s1) {
X v = (value)child(n, i/2);
X Assert(Is_etext(v));
X str = e_sstrval(v);
X subsmash(pbuf, str, where->s2, 0);
X subsmash(pbuf, str + where->s2, where->s3 - where->s2 + 1,
X SOBIT);
X strsmash(pbuf, str + where->s3 + 1, 0);
X e_fstrval(str);
X }
X else
X ok = chismash(pbuf, n, i/2, 0);
X }
X break;
X
X case SUBLIST:
X for (ok = Yes, j = where->s3; j > 0; --j) {
X rp = noderepr(n);
X maxs2 = 2*nchildren(n) - 1;
X for (i = 1; ok && i <= maxs2; ++i) {
X if (i&1)
X strsmash(pbuf, rp[i/2], SOBIT);
X else
X ok = chismash(pbuf, n, i/2, SOBIT);
X }
X if (ok)
X n = lastchild(n);
X }
X if (ok)
X smash(pbuf, n, 0);
X break;
X
X case SUBSET:
X rp = noderepr(n);
X maxs2 = 2*nchildren(n) + 1;
X mask = 0;
X for (ok = Yes, i = 1; ok && i <= maxs2; ++i) {
X if (i == where->s1)
X mask = SOBIT;
X if (i&1)
X strsmash(pbuf, rp[i/2], mask);
X else
X ok = chismash(pbuf, n, i/2, mask);
X if (i == where->s2)
X mask = 0;
X }
X break;
X
X default:
X Abort();
X }
X}
X
XHidden Procedure
Xsmash(pbuf, n, mask)
X register string *pbuf;
X register node n;
X register int mask;
X{
X register string *rp;
X register int i;
X register int nch;
X
X rp = noderepr(n);
X strsmash(pbuf, rp[0], mask);
X nch = nchildren(n);
X for (i = 1; i <= nch; ++i) {
X if (!chismash(pbuf, n, i, mask))
X break;
X strsmash(pbuf, rp[i], mask);
X }
X}
X
XHidden Procedure
Xstrsmash(pbuf, str, mask)
X register string *pbuf;
X register string str;
X register int mask;
X{
X if (!str)
X return;
X for (; *str; ++str) {
X if (isprint(*str) || *str == ' ')
X **pbuf = *str|mask, ++*pbuf;
X }
X}
X
XHidden Procedure
Xsubsmash(pbuf, str, len, mask)
X register string *pbuf;
X register string str;
X register int len;
X register int mask;
X{
X if (!str)
X return;
X for (; len > 0 && *str; --len, ++str) {
X if (isprint(*str) || *str == ' ')
X **pbuf = *str|mask, ++*pbuf;
X }
X}
X
X
X/*
X * Smash a node's child.
X * Return No if it contained a newline (to stop the parent).
X */
X
XHidden bool
Xchismash(pbuf, n, i, mask)
X register string *pbuf;
X register node n;
X register int i;
X{
X register node nn = child(n, i);
X register int w;
X
X if (Is_etext(nn)) {
X strsmash(pbuf, e_strval((value)nn), mask);
X return Yes;
X }
X w = nodewidth(nn);
X if (w < 0 && Fw_negative(noderepr(nn)[0]))
X return No;
X if (nn == thefocus)
X focsmash(pbuf, nn);
X else
X smash(pbuf, nn, mask);
X return w >= 0;
X}
END_OF_FILE
if test 7976 -ne `wc -c <'abc/bed/e1outp.c'`; then
echo shar: \"'abc/bed/e1outp.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1outp.c'
fi
if test -f 'abc/bint1/i1nui.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint1/i1nui.c'\"
else
echo shar: Extracting \"'abc/bint1/i1nui.c'\" \(8077 characters\)
sed "s/^X//" >'abc/bint1/i1nui.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Multi-precision integer arithmetic */
X
X#include "b.h"
X#include "feat.h" /* for EXT_RANGE */
X#include "bobj.h"
X#include "i1num.h"
X
X/*
X * Number representation:
X * ======================
X *
X * (Think of BASE = 10 for ordinary decimal notation.)
X * A number is a sequence of N "digits" b1, b2, ..., bN
X * where each bi is in {0..BASE-1}, except for negative numbers,
X * where bN = -1.
X * The number represented by b1, ..., bN is
X * b1*BASE**(N-1) + b2*BASE**(N-2) + ... + bN .
X * The base BASE is chosen so that multiplication of two positive
X * integers up to BASE-1 can be multiplied exactly using double
X * precision floating point arithmetic.
X * Also it must be possible to add two long integers between
X * -BASE and +BASE (exclusive), giving a result between -2BASE and
X * +2BASE.
X * BASE must be even (so we can easily decide whether the whole
X * number is even), and positive (to avoid all kinds of other trouble).
X * Presently, it is restricted to a power of 10 by the I/O-conversion
X * routines (file "i1nuc.c").
X *
X * Canonical representation:
X * bN is never zero (for the number zero itself, N is zero).
X * If bN is -1, b[N-1] is never BASE-1 .
X * All operands are assumed to be in canonical representation.
X * Routine "int_canon" brings a number in canonical representation.
X *
X * Mapping to C objects:
X * A "digit" is an integer of type "digit", probably an "int".
X * A number is represented as a "B-integer", i.e. something
X * of type "integer" (which is actually a pointer to some struct).
X * The number of digits N is extracted through the macro Length(v).
X * The i-th digit is extracted through the macro Digit(v,N-i).
X * (So in C, we count in a backwards direction from 0 ... n-1 !)
X * A number is created through a call to grab_num(N), which sets
X * N zero digits (thus not in canonical form!).
X */
X
X
X/*
X * Bring an integer into canonical form.
X * Make a SmallInt if at all possible.
X */
X
XVisible integer int_canon(v) integer v; {
X register int i;
X
X if (IsSmallInt(v)) return v;
X
X for (i = Length(v) - 1; i >= 0 && Digit(v,i) == 0; --i)
X ;
X
X if (i < 0) {
X Release(v);
X return int_0;
X }
X
X if (i == 0) {
X digit dig = Digit(v,0);
X Release(v);
X return (integer) MkSmallInt(dig);
X }
X
X /* i > 0 */
X if (Digit(v,i) == -1) {
X while (i > 0 && Digit(v, i-1) == BASE-1) --i;
X if (i == 0) {
X Release(v);
X return int_min1;
X }
X if (i == 1) {
X digit dig = Digit(v,0) - BASE;
X Release(v);
X return (integer) MkSmallInt(dig);
X }
X Digit(v,i) = -1;
X }
X else if (Digit(v, i) < -1) {
X /* e.g. after -100 * 10**7, with BASE == 10**4 */
X ++i;
X if (i+1 != Length(v))
X v = (integer) regrab_num((value) v, i+1);
X Digit(v, i) = -1;
X Digit(v, i-1) += BASE;
X /* note: i>=2 && Digit(v, i-1) != BASE-1 */
X }
X
X if (i+1 < Length(v)) return (integer) regrab_num((value) v, i+1);
X
X return v;
X}
X
X
X/* General add/subtract subroutine */
X
XHidden twodigit fmodulo(x) twodigit x; {
X /* RETURN x - (BASE * floor(x/BASE)) */
X twodigit d= x/BASE;
X /* next one remedies if negative x/BASE rounds towards 0 */
X if (x < 0 && d*BASE > x) --d;
X return x - BASE*d;
X}
X
XHidden Procedure dig_gadd(to, nto, from, nfrom, ffactor)
X digit *to, *from; intlet nto, nfrom; digit ffactor; {
X twodigit carry= 0;
X twodigit factor= ffactor;
X digit save;
X
X nto -= nfrom;
X if (nto < 0)
X syserr(MESS(1000, "dig_gadd: nto < nfrom"));
X for (; nfrom > 0; ++to, ++from, --nfrom) {
X carry += *to + *from * factor;
X *to= save= fmodulo(carry);
X carry= (carry-save) / BASE;
X }
X for (; nto > 0; ++to, --nto) {
X if (carry == 0)
X return;
X carry += *to;
X *to= save= fmodulo(carry);
X carry= (carry-save) / BASE;
X }
X if (carry != 0)
X to[-1] += carry*BASE;
X /* Mostly -1, but it can be <-1,
X * e.g. after -100*10**7 with BASE == 10**4
X */
X}
X
X
X/* Sum or difference of two integers */
X/* Should have its own version of dig-gadd without double precision */
X
XVisible integer int_gadd(v, w, factor) integer v, w; intlet factor; {
X struct integer vv, ww;
X integer s;
X int len, lenv, i;
X
X FreezeSmallInt(v, vv);
X FreezeSmallInt(w, ww);
X lenv= len= Length(v);
X if (Length(w) > len)
X len= Length(w);
X ++len;
X s= (integer) grab_num(len);
X for (i= 0; i < lenv; ++i)
X Digit(s, i)= Digit(v, i);
X for (; i < len; ++i)
X Digit(s, i)= 0;
X dig_gadd(&Digit(s, 0), len, &Digit(w, 0), Length(w), (digit)factor);
X return int_canon(s);
X}
X
X/* Sum of two integers */
X
XVisible integer int_sum(v, w) integer v, w; {
X if (IsSmallInt(v) && IsSmallInt(w))
X return mk_int((double)SmallIntVal(v) + (double)SmallIntVal(w));
X return int_gadd(v, w, 1);
X}
X
X/* Difference of two integers */
X
XVisible integer int_diff(v, w) integer v, w; {
X if (IsSmallInt(v) && IsSmallInt(w))
X return mk_int((double)SmallIntVal(v) - (double)SmallIntVal(w));
X return int_gadd(v, w, -1);
X}
X
X/* Product of two integers */
X
XVisible integer int_prod(v, w) integer v, w; {
X int i;
X integer a;
X struct integer vv, ww;
X
X if (v == int_0 || w == int_0) return int_0;
X if (v == int_1) return (integer) Copy(w);
X if (w == int_1) return (integer) Copy(v);
X
X if (IsSmallInt(v) && IsSmallInt(w))
X return mk_int((double)SmallIntVal(v) * (double)SmallIntVal(w));
X FreezeSmallInt(v, vv);
X FreezeSmallInt(w, ww);
X
X a = (integer) grab_num(Length(v) + Length(w));
X
X for (i= Length(a)-1; i >= 0; --i)
X Digit(a, i)= 0;
X for (i = 0; i < Length(v) && !Interrupted(); ++i)
X dig_gadd(&Digit(a, i), Length(w)+1, &Digit(w, 0), Length(w),
X Digit(v, i));
X return int_canon(a);
X}
X
XVisible integer int_neg(u) integer u; {
X if (IsSmallInt(u))
X return mk_int((double) (-SmallIntVal(u)));
X return int_gadd(int_0, u, -1);
X}
X
X/* Compare two integers */
X
XVisible relation int_comp(v, w) integer v, w; {
X int sv, sw;
X register int i;
X struct integer vv, ww;
X
X /* 1. Compare pointers and equal SmallInts */
X if (v == w) return 0;
X
X /* 1a. Handle SmallInts */
X if (IsSmallInt(v) && IsSmallInt(w))
X return SmallIntVal(v) - SmallIntVal(w);
X FreezeSmallInt(v, vv);
X FreezeSmallInt(w, ww);
X
X /* 2. Extract signs */
X sv = Length(v)==0 ? 0 : Digit(v,Length(v)-1)<0 ? -1 : 1;
X sw = Length(w)==0 ? 0 : Digit(w,Length(w)-1)<0 ? -1 : 1;
X
X /* 3. Compare signs */
X if (sv != sw) return (sv>sw) - (sv<sw);
X
X /* 4. Compare sizes */
X if (Length(v) != Length(w))
X return sv * ( (Length(v)>Length(w)) - (Length(v)<Length(w)) );
X
X /* 5. Compare individual digits */
X for (i = Length(v)-1; i >= 0 && Digit(v,i) == Digit(w,i); --i)
X ;
X
X /* 6. All digits equal? */
X if (i < 0) return 0; /* Yes */
X
X /* 7. Compare leftmost different digits */
X if (Digit(v,i) < Digit(w,i)) return -1;
X
X return 1;
X}
X
X
X/* Construct an integer out of a floating point number */
X
X#define GRAN 8 /* Granularity used when requesting more storage */
X /* MOVE TO MEM! */
XVisible integer mk_int(x) double x; {
X register integer a;
X integer b;
X register int i, j;
X int negate;
X
X if (MinSmallInt <= x && x <= MaxSmallInt)
X return (integer) MkSmallInt((int)x);
X
X a = (integer) grab_num(1);
X negate = x < 0 ? 1 : 0;
X if (negate) x = -x;
X
X for (i = 0; x != 0; ++i) {
X double z = floor(x/BASE);
X double y = z*BASE;
X digit save = Modulo((int)(x-y), BASE);
X if (i >= Length(a)) {
X a = (integer) regrab_num((value) a, Length(a)+GRAN);
X for (j = Length(a)-1; j > i; --j)
X Digit(a,j) = 0; /* clear higher digits */
X }
X Digit(a,i) = save;
X x = floor((x-save)/BASE);
X }
X
X if (negate) {
X b = int_neg(a);
X Release(a);
X return b;
X }
X
X return int_canon(a);
X}
X
X/* Construct an integer out of a C int. Like mk_int, but optimized. */
X
XVisible value mk_integer(x) int x; {
X if (MinSmallInt <= x && x <= MaxSmallInt) return MkSmallInt(x);
X return (value) mk_int((double)x);
X}
X
X
X/* Efficiently compute 10**n as a B integer, where n is a C int >= 0 */
X
XVisible integer int_tento(n) int n; {
X integer i;
X digit msd = 1;
X if (n < 0) syserr(MESS(1001, "int_tento(-n)"));
X if (n < tenlogBASE) {
X while (n != 0) msd *= 10, --n;
X return (integer) MkSmallInt(msd);
X }
X i = (integer) grab_num(1 + (int)(n/tenlogBASE));
X if (i) {
X n %= tenlogBASE;
X while (n != 0) msd *= 10, --n;
X Digit(i, Length(i)-1) = msd;
X }
X /* else caveat invocator */
X return i;
X}
END_OF_FILE
if test 8077 -ne `wc -c <'abc/bint1/i1nui.c'`; then
echo shar: \"'abc/bint1/i1nui.c'\" unpacked with wrong size!
fi
# end of 'abc/bint1/i1nui.c'
fi
if test -f 'abc/bint3/i3gfx.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3gfx.c'\"
else
echo shar: Extracting \"'abc/bint3/i3gfx.c'\" \(8005 characters\)
sed "s/^X//" >'abc/bint3/i3gfx.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * Graphics extension to B.
X *
X * Three commands have been added:
X *
X * SPACE'FROM a, b TO c, d
X * Enters graphics mode; (a, b) is the lower left corner, (c, d) the
X * upper right corner of screen. Clears the screen in any case.
X * A few lines at the bottom of the screen are still used for
X * normal scrolling text. If a=c or b=d, the corresponding
X * scale is taken from the device precision with the origin
X * in the middle of the screen.
X *
X * LINE'FROM a, b TO c, d
X * Draws a line (with clipping) from (a, b) to (c, d).
X * If not already in graphics mode, enter it (with unchanged
X * coordinate space).
X *
X * CLEAR'SCREEN
X * If in graphics mode, turns it off. Clears the screen in any case.
X *
X *
X * Changes have also been made to the editor, parser and interpreter;
X * these are only compiled if '#ifdef GFX' is true.
X */
X
X#include "b.h"
X#include "bobj.h"
X#include "bgfx.h"
X
X#ifdef GFX
X
X/* Interface for interpreter ----------------------------------------------- */
X
Xbool enter_gfx();
Xdo_space();
Xdo_line();
X
X
X/*
X * Enter graphics mode. Clear the screen. Set spacing to given values.
X */
X
XVisible Procedure space_to(v, w) value v, w; {
X do_gfx(v, w, /*&*/do_space);
X}
X
X
X/*
X * Draw a line between given points.
X * If not already in graphics mode, enter it first.
X * (Default spacing is the same as used last time, or (0, 0) TO (100, 100)
X * if no SPACE command was ever issued.)
X */
X
XVisible Procedure line_to(v, w) value v, w; {
X do_gfx(v, w, /*&*/do_line);
X}
X
X
X/*
X * Exit graphics mode.
X * Clear the screen.
X */
X
XVisible Procedure clear_screen() {
X exit_gfx();
X}
X
X
X/* Device-independent code ------------------------------------------------- */
X
X/*
X * Graphics mode.
X */
X
XVisible int gfx_mode= TEXT_MODE;
X
X
X/*
X * Representation of a vector.
X */
X
Xtypedef struct vector {
X double x;
X double y;
X} vector;
X
X
X/*
X * Variables describing the user coordinate space.
X * (Can be changed by calls to space_to).
X */
X
Xstatic vector origin= {0.0, 0.0};
Xstatic vector corner= {0.0, 0.0};
X
X
X/*
X * Scale factor for coordinate transformation.
X * (Computed from above variables plus device information by space_to.)
X */
X
Xstatic vector scale;
X
X
X/*
X * Macros to do the transformation from user to device coordinates.
X */
X
X#define XSCALE(a) (((a) - origin.x) * scale.x)
X#define YSCALE(a) (((a) - origin.y) * scale.y)
X
X
X/*
X * Check to see if a B value is a valid vector (= pair of numbers).
X * If so, extract the value into the vector whose address is passed.
X */
X
XHidden bool get_point(v, pv) value v; vector *pv; {
X value x, y;
X
X if (!Is_compound(v) || Nfields(v) != 2)
X return No;
X x= *Field(v, 0);
X y= *Field(v, 1);
X if (!Is_number(x) || !Is_number(y))
X return No;
X pv->x= numval(x);
X pv->y= numval(y);
X return Yes;
X}
X
X
X/*
X * Generic code for graphics routines that have two vector parameters.
X * Check that the arguments are indeed vectors and call the processing code.
X */
X
XHidden Procedure do_gfx(v, w, proc) value v; value w; int (*proc)(); {
X vector v1, v2;
X
X if (!get_point(v, &v1) || !get_point(w, &v2)) {
X interr(MESS(8000, "argument to graphics command not a vector"));
X return;
X }
X (*proc)(&v1, &v2);
X}
X
X
X/*
X * Routine to enter graphics mode and set the spacing as desired.
X */
X
XHidden Procedure do_space(pv1, pv2) vector *pv1, *pv2; {
X double tmp;
X
X if (gfx_mode != GFX_MODE) {
X if (!enter_gfx()) {
X interr(MESS(8001, "no graphics hardware available"));
X return;
X }
X }
X clipinit(dev_origin.x, dev_origin.y, dev_corner.x, dev_corner.y);
X origin.x= pv1->x;
X origin.y= pv1->y;
X corner.x= pv2->x;
X corner.y= pv2->y;
X if (origin.x > corner.x) {
X tmp= origin.x;
X origin.x= corner.x;
X corner.x= tmp;
X }
X else if (origin.x == corner.x) {
X origin.x= dev_origin.x - (dev_corner.x - dev_origin.x) / 2;
X corner.x= origin.x + (dev_corner.x - dev_origin.x);
X }
X if (origin.y > corner.y) {
X tmp= origin.y;
X origin.y= corner.y;
X corner.y= tmp;
X }
X else if (origin.y == corner.y) {
X origin.y= dev_origin.y - (dev_corner.y - dev_origin.y) / 2;
X corner.y= origin.y + (dev_corner.y - dev_origin.y);
X }
X scale.x= (double) (dev_corner.x - dev_origin.x) /
X (corner.x - origin.x);
X scale.y= (double) (dev_corner.y - dev_origin.y) /
X (corner.y - origin.y);
X}
X
X
X/*
X * Routine to draw a line.
X */
X
XHidden Procedure do_line(pv1, pv2) vector *pv1, *pv2; {
X int x1, y1, x2, y2;
X
X if (gfx_mode != GFX_MODE) {
X do_space(&origin, &corner);
X if (gfx_mode != GFX_MODE)
X return;
X }
X x1= XSCALE(pv1->x);
X x2= XSCALE(pv2->x);
X y1= YSCALE(pv1->y);
X y2= YSCALE(pv2->y);
X if (inview2d(x1, y1, x2, y2) || clip2d(&x1, &y1, &x2, &y2))
X draw_line(x1, y1, x2, y2);
X}
X
X/* Clipping ---------------------------------------------------------------- */
X
X/* @(#)clip.c 1.2 - 85/10/07 */
X/*
X * Fast, 2d, integer clipping plot(3) operations.
X * Clipping algorithm taken from "A New Concept and Method for Line Clipping,"
X * Barsky & Liang, ACM Tran. on Graphics Vol 3, #1, Jan 84.
X * In contrast to the algoritm presented in TOG, this one works
X * on integers only. The idea is to only do that which is useful
X * for my plot(3) based graphics programs.
X */
X
X/* AUTHOR:
XRob Adams <ima!rob>
XInteractive Systems, 7th floor, 441 Stuart st, Boston, MA 02116; 617-247-1155
X*/
X
X/*
X * Interface:
X *
X * clipinit(int xleft, int ybottom, int xright, int ytop)
X * Send this guy the same things you would send to space().
X * Don't worry if xleft > xright.
X *
X * clip2d(int *x0p, int *y0p, int *x1p, int *y1p)
X * By the time this returns, the points referenced will have
X * been clipped. Call this right before line(), with pointers
X * to the same arguments. Returns TRUE is the resulting line
X * can be displayed.
X *
X * inview2d(int x0,int y0,int x1,int y1)
X * Does a fast check for simple acceptance. Returns TRUE if
X * the segment is intirely in view. If your program runs too
X * slowly, consider making this a macro.
X *
X * Usage of clip2d and inview2d would be something like --
X * (inview2d(x0,y0, x1,y1) || clip2d(&x0,&y0, &x1,&y1))
X * && line(x0,y0,x1,y1);
X * If inview2d says the segment is safe or clip2d says the clipped
X * segment is safe, then go ahead and print the line.
X */
Xstatic int Xleft, Xright, Ytop, Ybot;
X
X#define TRUE 1
X#define FALSE 0
X#define bool int
X
X/*------------------------------- clipinit ----------------------------------*/
Xclipinit(x0,y0,x1,y1) {
X if ( x0 > x1 ) {
X Xleft = x1;
X Xright = x0;
X } else {
X Xleft = x0;
X Xright = x1;
X }
X if ( y0 > y1 ) {
X Ytop = y0;
X Ybot = y1;
X } else {
X Ytop = y1;
X Ybot = y0;
X }
X}
X
X/*------------------------------- inview2d ----------------------------------*/
Xbool inview2d(x0,y0, x1,y1) register x0,y0, x1,y1; {
X return x0 >= Xleft && x0 <= Xright && x1 >= Xleft && x1 <= Xright &&
X y0 >= Ybot && y0 <= Ytop && y1 >= Ybot && y1 <= Ytop;
X}
X
X/*-------------------------------- clip2d -----------------------------------*/
Xbool clip2d(x0p, y0p, x1p, y1p) int *x0p, *y0p, *x1p, *y1p; {
X register int x0 = *x0p,
X y0 = *y0p,
X x1 = *x1p,
X y1 = *y1p;
X
X register int dx, dy;
X double t0, t1;
X
X t0 = 0.0, t1 = 1.0; /* init parametic equations */
X dx = x1 - x0;
X if ( clipt( -dx, x0 - Xleft, &t0, &t1) &&
X clipt( dx, Xright - x0, &t0, &t1)) {
X dy = y1 - y0;
X if ( clipt( -dy, y0 - Ybot, &t0, &t1) &&
X clipt( dy, Ytop - y0, &t0, &t1)) {
X if ( t1 < 1 ) {
X *x1p = x0 + t1 * dx;
X *y1p = y0 + t1 * dy;
X }
X if ( t0 > 0.0 ) {
X *x0p = x0 + t0 * dx;
X *y0p = y0 + t0 * dy;
X }
X return TRUE;
X }
X }
X return FALSE;
X}
X
X/*-------------------------------- clipt ------------------------------------*/
Xstatic bool clipt(p, q, t0p, t1p) register int p, q;
X register double *t0p, *t1p; {
X register double r;
X
X if ( p < 0 ) {
X r = (double)q / p;
X if ( r > *t1p )
X return FALSE;
X if ( r > *t0p )
X *t0p = r;
X } else if (p > 0) {
X r = (double)q / p;
X if ( r < *t0p )
X return FALSE;
X if ( r < *t1p )
X *t1p = r;
X } else if (q < 0)
X return FALSE;
X return TRUE;
X}
X
X#endif /* GFX */
END_OF_FILE
if test 8005 -ne `wc -c <'abc/bint3/i3gfx.c'`; then
echo shar: \"'abc/bint3/i3gfx.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3gfx.c'
fi
if test -f 'abc/lin/i1tlt.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/lin/i1tlt.h'\"
else
echo shar: Extracting \"'abc/lin/i1tlt.h'\" \(1494 characters\)
sed "s/^X//" >'abc/lin/i1tlt.h' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/************************************************************************/
X/* Private definitions for small texts, lists and tables module */
X/* A text is modelled as a sequence of len characters. */
X/* */
X/* A list is modelled as a sequence of len values, */
X/* each of which corresponds to a list entry. */
X/* or, for a numeric range display with more than Minrange entries, */
X/* it is modelled as a sequence of two values, corresponding */
X/* to the lower and upper bounds, respectively. */
X/* */
X/* A table is modelled as a sequence of len values, */
X/* each of which corresponds to a table entry; */
X/* table entries are modelled as a compound with two fields. */
X/************************************************************************/
X
X#define Cts(v) (*Ats(v))
X#define Dts(v) (*(Ats(v)+1))
X
X#define List_elem(l, i) (*(Ats(l)+i)) /*counts from 0; takes no copy*/
X#define Key(t, i) (Ats(*(Ats(t)+i))) /*Ditto*/
X#define Assoc(t, i) (Ats(*(Ats(t)+i))+1) /*Ditto*/
X
X#define Lwb(l) (*Ats(l))
X#define Upb(l) (*(Ats(l)+1))
X
Xvalue rangesize();
Xrelation range_comp();
Xbool found();
Xvalue list_elem();
Xvalue key_elem();
END_OF_FILE
if test 1494 -ne `wc -c <'abc/lin/i1tlt.h'`; then
echo shar: \"'abc/lin/i1tlt.h'\" unpacked with wrong size!
fi
# end of 'abc/lin/i1tlt.h'
fi
if test -f 'abc/stc/i2tce.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/stc/i2tce.c'\"
else
echo shar: Extracting \"'abc/stc/i2tce.c'\" \(7902 characters\)
sed "s/^X//" >'abc/stc/i2tce.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* process type unification errors */
X
X#include "b.h"
X#include "bobj.h"
X#include "i2stc.h"
X
X#define I_FOUND_TYPE GMESS(2600, "I found type ")
X#define EG GMESS(2601, "EG ")
X#define WHERE_EXPECTED GMESS(2602, " where I expected ")
X
X#define I_THOUGHT GMESS(2603, "I thought ")
X#define WAS_OF_TYPE GMESS(2604, " was of type ")
X
X#define LT_OF GMESS(2605, "list or table of ")
X#define LT GMESS(2606, "list or table")
X#define T_OR_LT_OF_T GMESS(2607, """, or list or table of """)
X#define TLT GMESS(2608, "text or list or table")
X
X#define INCOMPATIBLE GMESS(2609, "incompatible type for ")
X#define INCOMPATIBLES GMESS(2610, "incompatible types for ")
X#define _AND_ GMESS(2611, " and ")
X
X/*
X * The variables from the users line are inserted in var_list.
X * This is used to produce the right variable names
X * in the error message.
X * Call start_vars() when a new error context is established
X * with the setting of curline.
X */
X
XHidden value var_list;
X
XVisible Procedure start_vars() {
X var_list = mk_elt();
X}
X
XVisible Procedure add_var(tvar) polytype tvar; {
X insert(tvar, &var_list);
X}
X
XHidden bool in_vars(t) polytype t; {
X return in(t, var_list);
X}
X
XVisible Procedure end_vars() {
X release(var_list);
X}
X
X/* t_repr(u) is used to print polytypes when an error
X * has occurred.
X * Because the errors are printed AFTER unification, the variable
X * polytypes in question have changed to the error-type.
X * To print the real types in error, the table has to be
X * saved in reprtable.
X * The routines are called in unify().
X */
X
XHidden value reprtable;
Xextern value ptype_of; /* defined in i2tp.c */
X
XVisible Procedure setreprtable() {
X reprtable = copy(ptype_of);
X}
X
XVisible Procedure delreprtable() {
X release(reprtable);
X}
X
X/* variables whose type is in error are gathered in errvarlist */
X
XHidden value errvarlist;
X
XVisible Procedure starterrvars() {
X errvarlist= mk_elt();
X}
X
XVisible Procedure adderrvar(t) polytype t; {
X if (in_vars(t) && !in(t, errvarlist))
X insert(t, &errvarlist);
X}
X
XVisible Procedure enderrvars() {
X release(errvarlist);
X}
X
X/* miscellaneous procs */
X
XVisible value conc(v, w) value v, w; {
X value c;
X c = concat(v, w);
X release(v); release(w);
X return c;
X}
X
XHidden bool newvar(u) polytype u; {
X value u1;
X char ch;
X u1 = curtail(ident(u), one);
X ch = charval(u1);
X release(u1);
X return (bool) ('0' <= ch && ch <= '9');
X}
X
X#define Known(tu) (!t_is_var(kind(tu)) && !t_is_error(kind(tu)))
X
XHidden polytype oldbottomtype(u) polytype u; {
X polytype tu= u;
X while (t_is_var(kind(tu)) && in_keys(ident(tu), reprtable))
X tu= *adrassoc(reprtable, ident(tu));
X return tu; /* not a copy, just a pointer! */
X}
X
XHidden value t_repr(u) polytype u; {
X typekind u_kind;
X polytype tau;
X value c;
X
X u_kind = kind(u);
X if (t_is_number(u_kind)) {
X return mk_text("0");
X }
X else if (t_is_text(u_kind)) {
X return mk_text("\"\"");
X }
X else if (t_is_tn(u_kind)) {
X return mk_text("\"\" or 0");
X }
X else if (t_is_compound(u_kind)) {
X intlet k, len = nsubtypes(u);
X c = mk_text("(");
X for (k = 0; k < len - 1; k++) {
X c = conc(c, t_repr(subtype(u, k)));
X c = conc(c, mk_text(", "));
X }
X c = conc(c, t_repr(subtype(u, k)));
X return conc(c, mk_text(")"));
X }
X else if (t_is_error(u_kind)) {
X return mk_text("?");
X }
X else if (t_is_var(u_kind)) {
X value tu;
X tu = oldbottomtype(u);
X if (Known(tu))
X return t_repr(tu);
X else if (newvar(u))
X return mk_text("?");
X else
X return copy(ident(u));
X }
X else if (t_is_table(u_kind)) {
X c = conc(mk_text("{["),
X t_repr(keytype(u)));
X c = conc(c, mk_text("]: "));
X c = conc(c, t_repr(asctype(u)));
X return conc(c, mk_text("}"));
X }
X else if (t_is_list(u_kind)) {
X c = conc(mk_text("{"), t_repr(asctype(u)));
X return conc(c, mk_text("}"));
X }
X else if (t_is_lt(u_kind)) {
X tau = oldbottomtype(asctype(u));
X if (Known(tau))
X return conc(mk_text(LT_OF),
X t_repr(tau));
X else
X return mk_text(LT);
X }
X else if (t_is_tlt(u_kind)) {
X tau= oldbottomtype(asctype(u));
X if (Known(tau)) {
X if (t_is_text(kind(tau)))
X return mk_text(T_OR_LT_OF_T);
X else
X return conc(mk_text(LT_OF), t_repr(tau));
X }
X else
X return mk_text(TLT);
X }
X else {
X return mk_text("***"); /* cannot happen */
X }
X}
X
X/* now, the real error messages */
X
XVisible Procedure badtyperr(a, b) polytype a, b; {
X value t;
X value nerrs, n, ne_min, m, sep;
X polytype te, bte;
X
X nerrs= size(errvarlist);
X
X if (compare(nerrs, one) < 0) {
X t= mk_text(I_FOUND_TYPE);
X if (!has_lt(kind(a)))
X t= conc(t, mk_text(EG));
X t= conc(t, t_repr(a));
X t= conc(t, mk_text(WHERE_EXPECTED));
X t= conc(t, t_repr(b));
X }
X else if (compare(nerrs, one) == 0) {
X te= (polytype) item(errvarlist, one);
X bte= oldbottomtype(te);
X if (Known(bte)) {
X t= conc(mk_text(I_THOUGHT),
X copy(ident(te)));
X t= conc(t, mk_text(WAS_OF_TYPE));
X if (!has_lt(kind(bte)))
X t= conc(t, mk_text(EG));
X t= conc(t, t_repr(bte));
X }
X else {
X t= conc(mk_text(INCOMPATIBLE),
X copy(ident(te)));
X }
X }
X else {
X n= copy(one);
X ne_min= diff(nerrs, one);
X t= mk_text(INCOMPATIBLES);
X for (;;) {
X te= item(errvarlist, n);
X t= conc(t, copy(ident(te)));
X if (compare(n, nerrs) == 0)
X break;
X if (compare(n, ne_min) < 0)
X sep= mk_text(", ");
X else
X sep= mk_text(_AND_);
X t= conc(t, sep);
X n= sum(m=n, one);
X release(m); release(te);
X }
X release(te); release(ne_min); release(n);
X }
X release(nerrs);
X
X typerrV(MESS(2612, "%s"), t);
X release(t);
X}
X
X#ifdef TYPETRACE
X#include "i2nod.h"
Xchar *treename[NTYPES] = { /* legible names for debugging */
X "HOW TO",
X "HOW TO RETURN",
X "HOW TO REPORT",
X "REFINEMENT",
X
X/* Commands */
X
X "SUITE",
X "PUT",
X "INSERT",
X "REMOVE",
X "SET RANDOM",
X "DELETE",
X "CHECK",
X "SHARE",
X "PASS",
X
X "WRITE",
X "WRITE1",
X "READ",
X "READ_RAW",
X
X "IF",
X "WHILE",
X "FOR",
X
X "SELECT",
X "TEST_SUITE",
X "ELSE",
X
X "QUIT",
X "RETURN",
X "REPORT",
X "SUCCEED",
X "FAIL",
X
X "USER_COMMAND",
X "EXTENDED_COMMAND",
X
X/* Expressions, targets, tests */
X
X "TAG",
X "COMPOUND",
X
X/* Expressions, targets */
X
X "COLLATERAL",
X "SELECTION",
X "BEHEAD",
X "CURTAIL",
X
X/* Expressions, tests */
X
X "UNPARSED",
X
X/* Expressions */
X
X "MONF",
X "DYAF",
X "NUMBER",
X "TEXT_DIS",
X "TEXT_LIT",
X "TEXT_CONV",
X "ELT_DIS",
X "LIST_DIS",
X "RANGE_BNDS",
X "TAB_DIS",
X
X/* Tests */
X
X "AND",
X "OR",
X "NOT",
X "SOME_IN",
X "EACH_IN",
X "NO_IN",
X "MONPRD",
X "DYAPRD",
X "LESS_THAN",
X "AT_MOST",
X "GREATER_THAN",
X "AT_LEAST",
X "EQUAL",
X "UNEQUAL",
X "Nonode",
X
X "TAGformal",
X "TAGlocal",
X "TAGglobal",
X "TAGrefinement",
X "TAGzerfun",
X "TAGzerprd",
X
X "ACTUAL",
X "FORMAL",
X
X#ifdef GFX
X "SPACE",
X "LINE",
X "CLEAR",
X#endif
X
X "COLON_NODE",
X
X};
X
Xextern FILE *stc_fp;
X
XVisible Procedure t_typecheck(nt, t) int nt; string t; {
X if (stc_fp == NULL)
X return;
X fprintf(stc_fp, "TC NODE %s, CODE %s\n", treename[nt], t);
X fflush(stc_fp);
X}
X
XVisible Procedure s_unify(a, b) polytype a, b; {
X value t;
X
X if (stc_fp == NULL)
X return;
X t= mk_text("START UNIFY ");
X if (t_is_var(kind(a))) {
X t= conc(t, copy(ident(a)));
X t= conc(t, mk_text("="));
X }
X t= conc(t, convert((value)oldbottomtype(a), No, No));
X t= conc(t, mk_text(" WITH "));
X if (t_is_var(kind(b))) {
X t= conc(t, copy(ident(b)));
X t= conc(t, mk_text("="));
X }
X t= conc(t, convert((value)oldbottomtype(b), No, No));
X fprintf(stc_fp, "%s\n", strval(t));
X release(t);
X t= mk_text("USING ");
X t= conc(t, convert(ptype_of, No, No));
X fprintf(stc_fp, "%s\n", strval(t));
X release(t);
X fflush(stc_fp);
X}
X
XVisible Procedure e_unify(a, b, c) polytype a, b, c; {
X value t;
X
X if (stc_fp == NULL)
X return;
X t= mk_text("GIVING ");
X if (t_is_var(kind(c))) {
X t= conc(t, copy(ident(c)));
X t= conc(t, mk_text("="));
X }
X t= conc(t, convert((value)oldbottomtype(c), No, No));
X fprintf(stc_fp, "%s\n", strval(t));
X release(t);
X t= mk_text("PRODUCING ");
X t= conc(t, convert(ptype_of));
X fprintf(stc_fp, "%s\n", strval(t));
X release(t);
X fflush(stc_fp);
X}
X#endif /* TYPETRACE */
END_OF_FILE
if test 7902 -ne `wc -c <'abc/stc/i2tce.c'`; then
echo shar: \"'abc/stc/i2tce.c'\" unpacked with wrong size!
fi
# end of 'abc/stc/i2tce.c'
fi
echo shar: End of archive 17 \(of 25\).
cp /dev/null ark17isdone
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