rsalz@bbn.com (Rich Salz) (12/20/90)
Submitted-by: Steven Pemberton <steven@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@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@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@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.