Subject: v23i093: ABC interactive programming environment, Part14/25 Newsgroups: comp.sources.unix Approved: rsalz@uunet.UU.NET X-Checksum-Snefru: a898e146 3316befe b20c0c2a 983b099f Submitted-by: Steven Pemberton Posting-number: Volume 23, Issue 93 Archive-name: abc/part14 #! /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/e1node.c abc/bed/e1scrn.c abc/bint1/i1nua.c # abc/btr/i1obj.c abc/btr/i1tlt.c # Wrapped by rsalz@litchi.bbn.com on Mon Dec 17 13:28:07 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 14 (of 25)."' if test -f 'abc/bed/e1node.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1node.c'\" else echo shar: Extracting \"'abc/bed/e1node.c'\" \(10811 characters\) sed "s/^X//" >'abc/bed/e1node.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* X * B editor -- Parse tree and Focus stack. X */ X X#include "b.h" X#include "bedi.h" X#include "etex.h" X#include "bobj.h" X#include "node.h" X#include "bmem.h" X Xvalue grab(); X X#define Register register X /* Used for registers 4-6. Define as empty macro on PDP */ X X X/* X * Lowest level routines for 'node' data type. X */ X X#define Isnode(n) ((n) && (n)->type == Nod) X X#define Nchildren(n) ((n)->len) X#define Symbol(n) ((n)->n_symbol) X#define Child(n, i) ((n)->n_child[(i)-1]) X#define Marks(n) ((n)->n_marks) X#define Width(n) ((n)->n_width) X X X/* X * Routines which are macros for the compiler but real functions for lint, X * so it will check the argument types more strictly. X */ X X#ifdef lint Xnode Xnodecopy(n) X node n; X{ X return (node) copy((value) n); X} X Xnoderelease(n) X node n; X{ X release((value)n); X} X Xnodeuniql(pn) X node *pn; X{ X uniql((value*)pn); X} X#endif /* lint */ X X/* X * Allocate a new node. X */ X XHidden node Xmk_node(nch) X register int nch; X{ X register node n = (node) grab(Nod, nch); X register int i; X X n->n_marks = 0; X n->n_width = 0; X n->n_symbol = 0; X for (i = nch-1; i >= 0; --i) X n->n_child[i] = Nnil; X return n; X} X XVisible node Xnewnode(nch, sym, children) X register int nch; X Register int sym; X register node children[]; X{ X register node n = (node) mk_node(nch); /* Must preset with zeros! */ X X Symbol(n) = sym; X for (; nch > 0; --nch) X Child(n, nch) = children[nch-1]; X Width(n) = evalwidth(n); X return n; X} X XVisible int nodewidth(n) node n; { X if (Is_etext(n)) X return e_length((value) n); X else X return Width(n); X} X X/* X * Macros to change the fields of a node. X */ X X#define Locchild(pn, i) \ X (Refcnt(*(pn)) == 1 || nodeuniql(pn), &Child(*(pn), i)) X#define Setmarks(pn, x) \ X (Refcnt(*(pn)) == 1 || nodeuniql(pn), Marks(*(pn))=(x)) X#define Setwidth(pn, w) (Refcnt(*(pn)) == 1 || nodeuniql(pn), Width(*(pn))=w) X X X/* X * Change a child of a node. X * Like treereplace(), it does not increase the reference count of n. X */ X XVisible Procedure Xsetchild(pn, i, n) X register node *pn; X register int i; X Register node n; X{ X register node *pch; X register node oldchild; X X Assert(Isnode(*pn)); X pch = Locchild(pn, i); X oldchild = *pch; X *pch = n; X repwidth(pn, oldchild, n); X noderelease(oldchild); X} X X X/* X * Lowest level routines for 'path' data type. X */ X X#define NPATHFIELDS 6 X X#define Parent(p) ((p)->p_parent) X#define Tree(p) ((p)->p_tree) X#define Ichild(p) ((p)->p_ichild) X X X/* X * Routines which are macros for the compiler but real functions for lint, X * so it will check the argument types more strictly. X */ X X#ifdef lint XVisible path Xpathcopy(p) X path p; X{ X return (path) copy((value) p); X} X XVisible Procedure Xpathrelease(p) X path p; X{ X release((value)p); X} X XVisible Procedure Xpathuniql(pp) X path *pp; X{ X uniql((value*)pp); X} X#endif /* lint */ X X/* X * Allocate a new path entry. X */ X XHidden path Xmk_path() X{ X register path p = (path) grab(Pat, 0); X X p->p_parent = NilPath; X p->p_tree = Nnil; X p->p_ichild = 0; X p->p_ycoord = 0; X p->p_xcoord = 0; X p->p_level = 0; X p->p_addmarks = 0; X p->p_delmarks = 0; X return p; X} X XVisible path Xnewpath(pa, n, i) X register path pa; X register node n; X Register int i; X{ X register path p = (path) mk_path(); X X Parent(p) = pa; X Tree(p) = n; X Ichild(p) = i; X Ycoord(p) = Xcoord(p) = Level(p) = 0; X return p; X} X X X/* X * Macros to change the fields of a path entry. X */ X X#define Uniqp(pp) (Refcnt(*(pp)) == 1 || pathuniql(pp)) X X#define Setcoord(pp, y, x, level) (Uniqp(pp), \ X (*(pp))->p_ycoord = y, (*(pp))->p_xcoord = x, (*(pp))->p_level = level) X X#define Locparent(pp) (Uniqp(pp), &Parent(*(pp))) X X#define Loctree(pp) (Uniqp(pp), &Tree(*(pp))) X X#define Addmarks(pp, x) (Uniqp(pp), \ X (*(pp))->p_addmarks |= (x), (*(pp))->p_delmarks &= ~(x)) X X#define Delmarks(pp, x) (Uniqp(pp), \ X (*(pp))->p_delmarks |= (x), (*(pp))->p_addmarks &= ~(x)) X X/* X * The following procedure sets the new width of node *pn when child X * oldchild is replaced by child newchild. X * This was added because the original call to evalwidth seemed to X * be the major caller of noderepr() and fwidth(). X */ X XHidden Procedure Xrepwidth(pn, old, new) X register node *pn; X Register node old; X Register node new; X{ X register int w = Width(*pn); X register int oldwidth = nodewidth(old); X register int newwidth = nodewidth(new); X X if (w >= 0) { X Assert(oldwidth >= 0); X if (newwidth < 0) { X Setwidth(pn, newwidth); X return; X } X } X else { X if (oldwidth == w && newwidth > 0) { X w= evalwidth(*pn); X Setwidth(pn, w); X return; X } X if (oldwidth > 0) X oldwidth = 0; X if (newwidth > 0) X newwidth = 0; X } X newwidth -= oldwidth; X if (newwidth) X Setwidth(pn, w + newwidth); X} X X XVisible Procedure Xmarkpath(pp, new) X register path *pp; X register markbits new; X{ X register node *pn; X register markbits old; X X Assert(Is_Node(Tree(*pp))); X old = Marks(Tree(*pp)); X if ((old|new) == old) X return; /* Bits already set */ X X pn = Loctree(pp); X Setmarks(pn, old|new); X Addmarks(pp, new&~old); X} X X XVisible Procedure Xunmkpath(pp, del) X register path *pp; X register int del; X{ X register node *pn; X register markbits old; X X Assert(Is_Node(Tree(*pp))); X old = Marks(Tree(*pp)); X if ((old&~del) == del) X return; X X pn = Loctree(pp); X Setmarks(pn, old&~del); X Delmarks(pp, del&old); X} X X XHidden Procedure Xclearmarks(pn) X register node *pn; X{ X register int i; X X if (!Marks(*pn)) X return; X if (Isnode(*pn)) { X Setmarks(pn, 0); X for (i = Nchildren(*pn); i > 0; --i) X clearmarks(Locchild(pn, i)); X } X} X X X/* X * Replace the focus' tree by a new node. X * WARNING: n's reference count is not increased! X * You can also think of this as: treereplace(pp, n) implies noderelease(n). X * Mark bits are copied from the node being replaced. X */ X XVisible Procedure Xtreereplace(pp, n) X register path *pp; X register node n; X{ X register node *pn; X register markbits old; X X pn = Loctree(pp); X if (Is_Node(*pn)) X old = Marks(*pn); X else X old = 0; X noderelease(*pn); X *pn = n; X if (Is_Node(n)) { X clearmarks(pn); X if (old) X Setmarks(pn, old); X } X else if (old) X Addmarks(pp, old); X} X X XVisible bool Xup(pp) X register path *pp; X{ X register path p = *pp; X register path pa = Parent(p); X register path *ppa; X register node n; X register node npa; X register node *pn; X node oldchild; X node *pnpa; X int i; X markbits add; X markbits del; X X if (!pa) X return No; X X i = ichild(p); X n = Tree(p); X if (Child(Tree(pa), i) != n) { X n = nodecopy(n); X ppa = Locparent(pp); X pnpa = Loctree(ppa); X pn = Locchild(pnpa, i); X oldchild = *pn; X *pn = n; X repwidth(pnpa, oldchild, n); X noderelease(oldchild); X X add = p->p_addmarks; X del = p->p_delmarks; X if (add|del) { X p = *pp; X p->p_addmarks = 0; X p->p_delmarks = 0; X if (add) X Addmarks(ppa, add); X npa = *pnpa; X if (del) { X for (i = Nchildren(npa); i > 0; --i) X if (i != ichild(p)) X del &= ~marks(Child(npa, i)); X Delmarks(ppa, del); X } X Setmarks(pnpa, Marks(npa)&~del|add); X } X } X /* else: still connected */ X X p = pathcopy(Parent(*pp)); X pathrelease(*pp); X *pp = p; X return Yes; X} X X XVisible bool Xdowni(pp, i) X register path *pp; X register int i; X{ X register node n; X auto int y; X auto int x; X auto int level; X X n = Tree(*pp); X if (!Isnode(n) || i < 1 || i > Nchildren(n)) X return No; X X y = Ycoord(*pp); X x = Xcoord(*pp); X level = Level(*pp); X *pp = newpath(*pp, nodecopy(Child(n, i)), i); X evalcoord(n, i, &y, &x, &level); X Setcoord(pp, y, x, level); X return Yes; X} X X XVisible bool Xdownrite(pp) X register path *pp; X{ X if (!Isnode(Tree(*pp))) X return No; X return downi(pp, Nchildren(Tree(*pp))); X} X X XVisible bool Xleft(pp) X register path *pp; X{ X register int i; X X i = ichild(*pp) - 1; X if (i <= 0) X return No; X if (!up(pp)) X return No; X return downi(pp, i); X} X X XVisible bool Xrite(pp) X register path *pp; X{ X register int i; X register path pa = Parent(*pp); X X i = ichild(*pp) + 1; X if (!pa || i > Nchildren(Tree(pa))) X return No; X if (!up(pp)) X return No; X return downi(pp, i); X} X X X/* X * Highest level: small utilities. X * X * WARNING: Several of the following routines may change their argument X * even if they return No. X * HINT: Some of these routines are not used; they are included for X * completeness of the provided set of operators only. If you have X * space problems (as, e.g., on a PDP-11), you can delete the superfluous X * ones (lint will tell you which they are). X */ X XVisible Procedure Xtop(pp) X register path *pp; X{ X while (up(pp)) X ; X} X X#ifdef NOT_USED XVisible bool Xnextnode(pp) X register path *pp; X{ X while (!rite(pp)) { X if (!up(pp)) X return No; X } X return Yes; X} X#endif X X#ifdef NOT_USED XVisible Procedure Xfirstleaf(pp) X register path *pp; X{ X while (down(pp)) X ; X} X#endif X X#ifdef NOT_USED XVisible bool Xnextleaf(pp) X register path *pp; X{ X if (!nextnode(pp)) X return No; X firstleaf(pp); X return Yes; X} X#endif X X#ifdef NOT_USED XVisible bool Xprevnode(pp) X register path *pp; X{ X while (!left(pp)) { X if (!up(pp)) X return No; X } X return Yes; X} X#endif X X#ifdef NOT_USED XVisible Procedure Xlastleaf(pp) X register path *pp; X{ X while (downrite(pp)) X ; X} X#endif X X#ifdef NOT_USED XVisible bool Xprevleaf(pp) X register path *pp; X{ X if (!prevnode(pp)) X return No; X lastleaf(pp); X return Yes; X} X#endif X X#ifdef NOT_USED XVisible bool Xnextmarked(pp, x) X register path *pp; X register markbits x; X{ X do { X if (!nextnode(pp)) X return No; X } while (!marked(*pp, x)); X while (down(pp)) { X while (!marked(*pp, x)) { X if (!rite(pp)) { X if (!up(pp)) Abort(); X return Yes; X } X } X } X return Yes; X} X#endif X XVisible bool Xfirstmarked(pp, x) X register path *pp; X register markbits x; X{ X while (!marked(*pp, x)) { X if (!up(pp)) X return No; X } X while (down(pp)) { X while (Is_etext(tree(*pp)) || !marked(*pp, x)) { X if (!rite(pp)) { X if (!up(pp)) Abort(); X return Yes; X } X } X } X return Yes; X} X X#ifdef NOT_USED XVisible bool Xprevmarked(pp, x) X register path *pp; X register markbits x; X{ X do { X if (!prevnode(pp)) X return No; X } while (!marked(*pp, x)); X while (downrite(pp)) { X while (!marked(*pp, x)) { X if (!left(pp)) { X if (!up(pp)) Abort(); X return Yes; X } X } X } X return Yes; X} X#endif X X/* X * Deliver the path length to the root. X */ X X XVisible Procedure Xpathlength(p) X register path p; X{ X register int n; X X for (n = 0; p; ++n) X p = parent(p); X return n; X} X XVisible Procedure Xputintrim(pn, head, tail, str) X register value *pn; X register int head; X Register int tail; X Register string str; X{ X register value v = *pn; X value t1, t2, t3; X int len= e_length(v); X X Assert(head >= 0 && tail >= 0 && head + tail <= len); X t1= e_icurtail(v, head); X t2= mk_etext(str); X t3= e_concat(t1, t2); X release(t1); release(t2); X t1= e_ibehead(v, len - tail + 1); X t2= e_concat(t3, t1); X release(t3); release(t1); X release(v); X *pn = t2; X} X X/* X * Touch the node in focus. X */ X XVisible Procedure Xtouchpath(pp) X register path *pp; X{ X nodeuniql(Loctree(pp)); X} END_OF_FILE if test 10811 -ne `wc -c <'abc/bed/e1node.c'`; then echo shar: \"'abc/bed/e1node.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1node.c' fi if test -f 'abc/bed/e1scrn.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1scrn.c'\" else echo shar: Extracting \"'abc/bed/e1scrn.c'\" \(11204 characters\) sed "s/^X//" >'abc/bed/e1scrn.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* X * B editor -- Screen management package, higher level routines. X */ X X#include "b.h" X#include "bedi.h" X#include "etex.h" X#include "feat.h" X#include "bobj.h" X#include "erro.h" X#include "node.h" X#include "supr.h" X#include "gram.h" X#include "cell.h" X#include "trm.h" X#include "args.h" X Xcell *gettop(); Xextern int focy; Xextern int focx; X XVisible int winstart; X XVisible int winheight; XVisible int indent; XVisible int llength; X XVisible bool noscroll; XVisible bool nosense; XVisible bool raw_newline= No; X XHidden cell *tops; X X X/* X * Actual screen update. X */ X XVisible Procedure Xactupdate(copybuffer, recording, lasttime) X value copybuffer; X bool recording; X bool lasttime; /* Yes if called from final screen update */ X{ X register cell *p; X cell *top = tops; X register int diff; X register int curlno; X register int delcnt = 0; /* Lines deleted during the process. */ X /* Used as offset for lines that are on the screen. */ X int totlines = 0; X int topline = 0; X int scrlines = 0; X X if (winstart > 0) X growwin(); X if (winstart <= 0) { X top = gettop(tops); X for (p = tops; p && p != top; p = p->c_link) X ++topline; X totlines = topline; X } X startactupdate(lasttime); X focy = Nowhere; X for (p = top, curlno = winstart; p && curlno < winheight; X curlno += Space(p), p = p->c_link) { X ++scrlines; X if (lasttime) { X p->c_newfocus = No; X p->c_newvhole = 0; X } X if (p->c_onscreen != Nowhere && Space(p) == Oldspace(p)) { X /* Old comrade */ X diff = p->c_onscreen - (curlno+delcnt); X /* diff can't be negative due to 'makeroom' below! */ X if (diff > 0) { /* Get him here */ X trmscrollup(curlno, winheight, diff); X delcnt += diff; X } X if (p->c_oldfocus || p->c_newfocus X || p->c_oldindent != p->c_newindent X || p->c_onscreen + Space(p) >= winheight) { X delcnt = make2room(p, curlno, delcnt); X outline(p, curlno); X } X } X else { /* New guy, make him toe the line */ X delcnt = makeroom(p, curlno, delcnt); X delcnt = make2room(p, curlno, delcnt); X outline(p, curlno); X } X p->c_onscreen = curlno; X p->c_oldindent = p->c_newindent; X p->c_oldvhole = p->c_newvhole; X p->c_oldfocus = p->c_newfocus; X } X totlines += scrlines; X for (; p; p = p->c_link) { /* Count rest and remove old memories */ X ++totlines; X /* This code should never find any garbage?! */ X#ifndef NDEBUG X if (p->c_onscreen != Nowhere) X debug("[Garbage removed from screen list]"); X#endif /* NDEBUG */ X p->c_onscreen = Nowhere; X } X trmscrollup(curlno, winheight, -delcnt); X curlno += delcnt; X if (curlno < winheight) { /* Clear lines beyond end of unit */ X trmputdata(curlno, winheight-1, 0, ""); X scrlines += winheight-curlno; X } X if (!lasttime) { X stsline(totlines, topline, scrlines, copybuffer, recording); X if (focy != Nowhere) X trmsync(focy, focx); X else X trmsync(winheight, 0); X } X endactupdate(); X} X X X/* X * Grow the window if not maximum size. X */ X XHidden Procedure Xgrowwin() X{ X register int winsize; X register int growth; X register cell *p; X X winsize = 0; X for (p = tops; p; p = p->c_link) X winsize += Space(p); X if (winsize <= winheight - winstart) X return; /* No need to grow */ X if (winsize > winheight) X winsize = winheight; /* Limit size to maximum available */ X X growth = winsize - (winheight - winstart); X trmscrollup(0, winheight - (winstart!=winheight), growth); X winstart -= growth; X for (p = tops; p; p = p->c_link) { X if (p->c_onscreen != Nowhere) X p->c_onscreen -= growth; X } X} X X X/* X * Make room for possible insertions. X * (If a line is inserted, it may be necessary to delete lines X * further on the screen.) X */ X XHidden Procedure Xmakeroom(p, curlno, delcnt) X register cell *p; X register int curlno; X register int delcnt; X{ X register int here = 0; X register int need = Space(p); X register int amiss; X int avail; X int diff; X X Assert(p); X do { X p = p->c_link; X if (!p) X return delcnt; X } while (p->c_onscreen == Nowhere); X here = p->c_onscreen - delcnt; X avail = here - curlno; X amiss = need - avail; X#ifndef NDEBUG X if (dflag) X debug("[makeroom: curlno=%d, delcnt=%d, here=%d, avail=%d, amiss=%d]", X curlno, delcnt, here, avail, amiss); X#endif /* NDEBUG */ X if (amiss <= 0) X return delcnt; X if (amiss > delcnt) { X for (; p; p = p->c_link) { X if (p->c_onscreen != Nowhere) { X diff = amiss-delcnt; X if (p->c_onscreen - delcnt - here < diff) X diff = p->c_onscreen - delcnt - here; X if (diff > 0) { X trmscrollup(here, winheight, diff); X delcnt += diff; X } X p->c_onscreen += -delcnt + amiss; X here = p->c_onscreen - amiss; X if (p->c_onscreen >= winheight) X p->c_onscreen = Nowhere; X } X here += Space(p); X } X /* Now for all p encountered whose p->c_onscreen != Nowhere, X * p->c_onscreen - amiss is its actual position. X */ X if (amiss > delcnt) { X trmscrollup(winheight - amiss, winheight, amiss-delcnt); X delcnt = amiss; X } X } X /* Now amiss <= delcnt */ X trmscrollup(curlno + avail, winheight, -amiss); X return delcnt - amiss; X} X X X/* X * Addition to makeroom - make sure the status line is not overwritten. X * Returns new delcnt, like makeroom does. X */ X XHidden int Xmake2room(p, curlno, delcnt) X cell *p; X int curlno; X int delcnt; X{ X int nextline = curlno + Space(p); X int sline = winheight - delcnt; X int diff; X X if (sline < curlno) { X#ifndef NDEBUG X debug("[Status line overwritten]"); X#endif /* NDEBUG */ X return delcnt; X } X if (nextline > winheight) X nextline = winheight; X diff = nextline - sline; X if (diff > 0) { X trmscrollup(sline, winheight, -diff); X delcnt -= diff; X } X return delcnt; X X} X X X/* X * Routine called for every change in the screen. X */ X XVisible Procedure Xvirtupdate(oldep, newep, highest) X environ *oldep; X environ *newep; X int highest; X{ X environ old; X environ new; X register int oldlno; X register int newlno; X register int oldlcnt; X register int newlcnt; X register int i; X X if (!oldep) { X highest = 1; X trmputdata(winstart, winheight, indent, ""); X discard(tops); X tops = Cnil; X Ecopy(*newep, old); X } X else { X Ecopy(*oldep, old); X } X Ecopy(*newep, new); X X savefocus(&new); X X oldlcnt = fixlevels(&old, &new, highest); X newlcnt = -nodewidth(tree(new.focus)); X if (newlcnt < 0) X newlcnt = 0; X i = -nodewidth(tree(old.focus)); X if (i < 0) X i = 0; X newlcnt -= i - oldlcnt; X /* Offset newlcnt as much as oldcnt is offset */ X X oldlno = Ycoord(old.focus); X newlno = Ycoord(new.focus); X if (!atlinestart(&old)) X ++oldlcnt; X else X ++oldlno; X if (!atlinestart(&new)) X ++newlcnt; X else X ++newlno; X Assert(oldlno == newlno); X X tops = replist(tops, build(new.focus, newlcnt), oldlno, oldlcnt); X X setfocus(tops); /* Incorporate the information saved by savefocus */ X X Erelease(old); X Erelease(new); X} X X XHidden bool Xatlinestart(ep) X environ *ep; X{ X register string repr = noderepr(tree(ep->focus))[0]; X X return Fw_negative(repr); X} X X X/* X * Make the two levels the same, and make sure they both are line starters X * if at all possible. Return the OLD number of lines to be replaced. X * (0 if the whole unit has no linefeeds.) X */ X XHidden int Xfixlevels(oldep, newep, highest) X register environ *oldep; X register environ *newep; X register int highest; X{ X register int oldpl = pathlength(oldep->focus); X register int newpl = pathlength(newep->focus); X register bool intraline = No; X register int w; X X if (oldpl < highest) X highest = oldpl; X if (newpl < highest) X highest = newpl; X while (oldpl > highest) { X if (!up(&oldep->focus)) Abort(); X --oldpl; X } X while (newpl > highest) { X if (!up(&newep->focus)) Abort(); X --newpl; X } X if (Ycoord(newep->focus) != Ycoord(oldep->focus) || X Level(newep->focus) != Level(oldep->focus)) { X /* Inconsistency found. */ X Assert(highest > 1); /* Inconsistency at top level. Stop. */ X return fixlevels(oldep, newep, 1); /* Try to recover. */ X } X intraline = nodewidth(tree(oldep->focus)) >= 0 X && nodewidth(tree(newep->focus)) >= 0; X while (!atlinestart(oldep) || !atlinestart(newep)) { X /* Find beginning of lines for both */ X if (!up(&newep->focus)) { X Assert(!up(&newep->focus)); X break; X } X --oldpl; X if (!up(&oldep->focus)) Abort(); X --newpl; X } X if (intraline) X return atlinestart(oldep); X w = nodewidth(tree(oldep->focus)); X return w < 0 ? -w : 0; X} X X X/* X * Initialization code. X */ X XVisible Procedure Xinitterm() X{ X initvtrm(); /* init virtual terminal package */ X initgetc(); /* term-init string */ X} X X XVisible bool in_vtrm= No; Xextern bool in_init; X XHidden Procedure Xinitvtrm() X{ X int flags = 0; X int err; X X err= trmstart(&winheight, &llength, &flags); X if (err != TE_OK) { X if (err <= TE_DUMB) X putmess(errfile, X MESS(6600, "*** Bad $TERM or termcap, or dumb terminal\n")); X else if (err == TE_BADSCREEN) X putmess(errfile, X MESS(6601, "*** Bad SCREEN environment\n")); X else X putmess(errfile, X MESS(6602, "*** Cannot reach keyboard or screen\n")); X X if (in_init) X immexit(2); X else X bye(2); X } X noscroll = (flags&CAN_SCROLL) == 0; X nosense= (flags&CAN_SENSE) == 0; X#ifndef macintosh X raw_newline= Yes; X /* should be: X * raw_newline= (flags&RAW_NEWLINE) != 0; X * with change in trm-module interface; X * RAW_NEWLINE means the cursor only goes down vertically on '\n' X */ X#endif X X winstart = --winheight; X X in_vtrm= Yes; X} X XVisible Procedure Xendterm() X{ X trmsync(winheight, 0); /* needed for buggy vt100's, that X * may leave cusor at top of screen X * if only trmstart was called X * (which did send cs_str) X */ X endgetc(); /* term-end string */ X trmend(); X in_vtrm= No; X} X X/* X * Routine to move the cursor to the first line after the just edited X * document. (Called after each editing action.) X */ X XVisible Procedure Xendshow() X{ X register cell *p; X register int last = winheight; X X for (p = tops; p; p = p->c_link) { X if (p->c_onscreen != Nowhere) X last = p->c_onscreen + Oldspace(p); X } X if (last > winheight) X last = winheight; X discard(tops); X tops = Cnil; X trmputdata(last, winheight, 0, ""); X trmsync(winheight, 0); X} X X#ifdef GOTOCURSOR X X/* X * Translate a cursor position in tree coordinates. X * X * ***** DOESN'T WORK IF SCREEN INDENT DIFFERS FROM TREE INDENT! ***** X * (I.e. for lines with >= 80 spaces indentation) X */ X XVisible bool Xbacktranslate(py, px) X int *py; X int *px; X{ X cell *p; X int y = *py; X int x = *px; X int i; X X for (i = 0, p = tops; p; ++i, p = p->c_link) { X if (p->c_onscreen != Nowhere X && y >= p->c_onscreen && y < p->c_onscreen + Space(p)) { X *px += (y - p->c_onscreen) * llength - indent; X if (*px < 0) X *px = 0; X *py = i; X if (p->c_oldvhole && (y > focy || y == focy && x > focx)) X --*px; /* Correction if beyond Vhole on same logical line */ X return Yes; X } X } X ederr(GOTO_OUT); X return No; X} X X#endif /*GOTOCURSOR*/ X/* X * Set the indent level and window start line. X */ X XVisible Procedure Xsetindent(x) X int x; X{ X winstart= winheight; X /* the following is a hack; should change when X * interpreter also writes through trm-interface. X * Then it must be clear what's on the screen already X * Handled in this file? X */ X if (llength==0) X indent= x; X else X indent= x % llength; X} X X X/* X * Show the command prompt. X */ X XVisible Procedure cmdprompt(prompt) X string prompt; X{ X setindent(strlen(prompt)); X trmputdata(winstart, winstart, 0, prompt); X} END_OF_FILE if test 11204 -ne `wc -c <'abc/bed/e1scrn.c'`; then echo shar: \"'abc/bed/e1scrn.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1scrn.c' fi if test -f 'abc/bint1/i1nua.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bint1/i1nua.c'\" else echo shar: Extracting \"'abc/bint1/i1nua.c'\" \(10983 characters\) sed "s/^X//" >'abc/bint1/i1nua.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* Approximate arithmetic */ X X#include "b.h" X#include "feat.h" /* for EXT_RANGE */ X#include "bobj.h" X#include "i0err.h" X#include "i1num.h" X X/* XFor various reasons, on some machines (notably the VAX), the range Xof the exponent is too small (ca. 1.7E38), and we cope with this by Xadding a second word which holds the exponent. XHowever, on other machines (notably the IBM PC), the range is sufficient X(ca. 1E300), and here we try to save as much code as possible by not Xdoing our own exponent handling. (To be fair, we also don't check Xcertain error conditions, to save more code.) XThe difference is made by #defining EXT_RANGE (in i1num.h), meaning we Xhave to EXTend the RANGE of the exponent. X*/ X X#ifdef EXT_RANGE XHidden struct real app_0_buf = {Num, 1, -1, FILLER 0.0, -BIG}; X /* Exponent must be less than any realistic exponent! */ X#else /* !EXT_RANGE */ XHidden struct real app_0_buf = {Num, 1, -1, FILLER 0.0}; X#endif /* !EXT_RANGE */ X XVisible real app_0 = &app_0_buf; X XHidden double logtwo; XHidden double twologBASE; X X/* X * Build an approximate number. X */ X X#define TOO_LARGE MESS(700, "approximate number too large") X XVisible real mk_approx(frac, expo) double frac, expo; { X real u; X#ifdef EXT_RANGE X expint v; X if (frac != 0) frac = frexp(frac, &v), expo += v; X if (frac == 0 || expo < -BIG) return (real) Copy(app_0); X if (expo > BIG) { X interr(TOO_LARGE); X expo = BIG; X } X#else /* !EXT_RANGE */ X if (frac == 0.0) return (real) Copy(app_0); X if (frac > 0 && log(frac)+expo*logtwo > log(Maxreal)) { X interr(TOO_LARGE); X frac= Maxreal; X } X else X frac= ldexp(frac, (int)expo); X#endif /* EXT_RANGE */ X u = (real) grab_num(-1); X Frac(u) = frac; X#ifdef EXT_RANGE X Expo(u) = expo; X#endif /* EXT_RANGE */ X return u; X} X XHidden value twotodblbits; /* 2**DBLBITS */ XHidden value twoto_dblbitsmin1; /* 2**(DBLBITS-1) */ X /* stored as an unnormalized rational */ X XHidden double getexponent(v) value v; { X integer p, q; X struct integer pp, qq; X double x; X X v = absval(v); X if (Integral(v)) { X p = (integer) v; X q = (integer) one; X } X else { X p = Numerator((rational) v); X q = Denominator((rational) v); X } X FreezeSmallInt(p, pp); FreezeSmallInt(q, qq); X X x = log((double) Msd(p)) / logtwo; X x-= log((double) Msd(q)) / logtwo; X x+= (double) ((Length(p)-Length(q)) * twologBASE); X X release(v); X return floor(x) + 1; X} X XVisible value app_frexp(v) value v; { X integer w; X struct integer ww; X value s, t; X double frac, expo; X relation neg; X int i; X X if ((neg = numcomp(v, zero)) == 0) X return Copy(app_0); X else if (neg < 0) X v = negated(v); X X expo = getexponent(v); /* it can be +1 or -1 off !!! */ X X s = (value) mk_int((double)DBLBITS - expo); X s = prod2n(v, t = s, No); X release(t); X /* do the correction */ X if (numcomp(s, twotodblbits) >= 0) { X s = prod2n(t = s, (value) int_min1, No); /* s / 2 */ X ++expo; X release(t); X } X else if (numcomp(s, twoto_dblbitsmin1) < 0) { X s = prod2n(t = s, (value) int_1, No); /* s * 2 */ X --expo; X release(t); X } X w = (integer) round1(s); X release(s); X FreezeSmallInt(w, ww); X X frac = 0.0; X for (i = Length(w) - 1; i >= 0; --i) { X frac = frac * BASE + Digit(w, i); X } X frac = ldexp(frac, -DBLBITS); X X release((value) w); X if (neg < 0) { X frac = -frac; X release(v); X } X return (value) mk_approx(frac, expo); X} X X/* X * Approximate arithmetic. X */ X XVisible real app_sum(u, v) real u, v; { X#ifdef EXT_RANGE X real w; X if (Expo(u) < Expo(v)) w = u, u = v, v = w; X if (Expo(v) - Expo(u) < Minexpo) return (real) Copy(u); X return mk_approx(Frac(u) + ldexp(Frac(v), (int)(Expo(v) - Expo(u))), X Expo(u)); X#else /* !EXT_RANGE */ X return mk_approx(Frac(u) + Frac(v), 0.0); X#endif /* !EXT_RANGE */ X} X XVisible real app_diff(u, v) real u, v; { X#ifdef EXT_RANGE X real w; X int sign = 1; X if (Expo(u) < Expo(v)) w = u, u = v, v = w, sign = -1; X if (Expo(v) - Expo(u) < Minexpo) X return sign < 0 ? app_neg(u) : (real) Copy(u); X return mk_approx( X sign * (Frac(u) - ldexp(Frac(v), (int)(Expo(v) - Expo(u)))), X Expo(u)); X#else /* !EXT_RANGE */ X return mk_approx(Frac(u) - Frac(v), 0.0); X#endif /* !EXT_RANGE */ X} X XVisible real app_neg(u) real u; { X return mk_approx(-Frac(u), Expo(u)); X} X XVisible real app_prod(u, v) real u, v; { X return mk_approx(Frac(u) * Frac(v), Expo(u) + Expo(v)); X} X XVisible real app_quot(u, v) real u, v; { X if (Frac(v) == 0.0) { X interr(ZERO_DIVIDE); X return (real) Copy(u); X } X return mk_approx(Frac(u) / Frac(v), Expo(u) - Expo(v)); X} X X/* X YIELD log"(frac, expo): X CHECK frac > 0 X RETURN normalize"(expo*logtwo + log(frac), 0) X*/ X XVisible real app_log(v) real v; { X double frac = Frac(v), expo = Expo(v); X return mk_approx(expo*logtwo + log(frac), 0.0); X} X X/* X YIELD exp"(frac, expo): X IF expo < minexpo: RETURN zero" X WHILE expo < 0: PUT frac/2, expo+1 IN frac, expo X PUT exp frac IN f X PUT normalize"(f, 0) IN f, e X WHILE expo > 0: X PUT (f, e) prod" (f, e) IN f, e X PUT expo-1 IN expo X RETURN f, e X*/ X XVisible real app_exp(v) real v; { X#ifdef EXT_RANGE X expint ei; X double frac = Frac(v), vexpo = Expo(v), new_expo; X static double canexp; X if (!canexp) X canexp = floor(log(log(Maxreal/2.718281828459045235360)+1.0)/logtwo); X if (vexpo <= canexp) { X if (vexpo < Minexpo) return mk_approx(1.0, 0.0); X frac = ldexp(frac, (int)vexpo); X vexpo = 0; X } X else if (vexpo >= Maxexpo) { X /* Definitely too big (the real boundary is much smaller X but here we are in danger of overflowing new_expo X in the loop below) */ X if (frac < 0) X return (real) Copy(app_0); X return mk_approx(1.0, Maxreal); /* Force an error! */ X } X else { X frac = ldexp(frac, (int)canexp); X vexpo -= canexp; X } X frac = exp(frac); X new_expo = 0; X while (vexpo > 0 && frac != 0) { X frac = frexp(frac, &ei); X new_expo += ei; X frac *= frac; X new_expo += new_expo; X --vexpo; X } X return mk_approx(frac, new_expo); X#else /* !EXT_RANGE */ X if (Frac(v) > (Maxexpo)*logtwo) X return mk_approx(1.0, Maxreal); X /* Force error! X * (since BSD exp generates illegal instr) X * [still ~2**126 ain't save against their failing exp] */ X return mk_approx(exp(Frac(v)), 0.0); X#endif /* !EXT_RANGE */ X} X XVisible real app_power(u, v) real u, v; { X double ufrac = Frac(u); X if (ufrac <= 0) { X if (ufrac < 0) interr(NEG_EXACT); X if (v == app_0) return mk_approx(1.0, 0.0); /* 0**0 = 1 */ X return (real) Copy(app_0); /* 0**x = 0 */ X } X else { X /* u ** v = exp(v * log (u)) */ X real logu= app_log(u); X real vlogu= app_prod(v, logu); X real expvlogu= app_exp(vlogu); X Release(logu); X Release(vlogu); X return expvlogu; X } X} X X/* about2_to_integral(ru, v, rv) returns, via rv, exactly (0.5, v+1) X * if ru == ~2 and v is an integral. Why?, well, X * to speed up reading the value of an approximate from a file, X * the exponent part is stored as ~2**expo and X * to prevent loss of precision, we cannot use the normal procedure X * app_power(). X */ X XVisible bool about2_to_integral(ru, v, rv) value v; real ru, *rv; { X double expo; X integer w; X struct integer ww; X int i; X bool neg = No; X X#ifdef EXT_RANGE X if (!(Frac(ru) == 0.5 && Expo(ru) == 2.0 && Integral(v))) X return No; X#else X if (!(Frac(ru) == 2.0 && Integral(v))) X return No; X#endif X w = (integer) v; X if (numcomp((value) w, zero) < 0) { X w = int_neg(w); X neg = Yes; X } X FreezeSmallInt(w, ww); X X expo = 0.0; X for (i = Length(w) - 1; i >= 0; --i) { X expo = expo * BASE + Digit(w, i); X } X if (neg) { X expo = -expo; X Release(w); X } X *rv = mk_approx(0.5, expo+1); X return Yes; X} X XVisible int app_comp(u, v) real u, v; { X double xu, xv; X#ifdef EXT_RANGE X double eu, ev; X#endif /* EXT_RANGE */ X if (u == v) return 0; X xu = Frac(u), xv = Frac(v); X#ifdef EXT_RANGE X if (xu*xv > 0) { X eu = Expo(u), ev = Expo(v); X if (eu < ev) return xu < 0 ? 1 : -1; X if (eu > ev) return xu < 0 ? -1 : 1; X } X#endif /* EXT_RANGE */ X if (xu < xv) return -1; X if (xu > xv) return 1; X return 0; X} X XVisible integer app_floor(u) real u; { X double frac, expo; X expint ei; X integer v, w; X value twotow, result; X X frac= Frac(u); X expo= Expo(u); X frac= frexp(frac, &ei); X expo+= ei; X X if (expo <= DBLBITS) { X return mk_int(floor(ldexp(frac, X (int)(expo < 0 ? -1 : expo)))); X } X v = mk_int(ldexp(frac, DBLBITS)); X w = mk_int(expo - DBLBITS); X twotow = power((value)int_2, (value)w); X result = prod((value)v, twotow); X Release(v), Release(w), Release(twotow); X if (!Integral(result)) X syserr(MESS(701, "app_floor: result not integral")); X return (integer) result; X} X XHidden value twotolongbits; X XVisible value app_exactly(u) real u; { X value w; X integer v, n, t1, t2; X double frac, expo, rest, p; X unsigned long l; X expint e, re, dummy; X int z, digits; X bool neg; X X if (Frac(u) == 0.0) X return zero; X frac= Frac(u); X expo= Expo(u); X if (frac < 0.0) { frac= -frac; neg= Yes; } X else neg= No; X frac= frexp(frac, &e); X expo+= e; X p= floor(ldexp(frac, LONGBITS)); /* shift the digits */ X l= (unsigned long) p; X v= mk_int((double) l); X rest= frexp(frac - frexp(p, &dummy), &re); X z= -re - LONGBITS; /* number of leading zeros */ X digits= LONGBITS; /* count the number of digits */ X X while (rest != 0.0) { X p= floor(ldexp(rest, LONGBITS - z)); X l= (unsigned long) p; X v= int_prod(t1= v, (integer) twotolongbits); X Release(t1); X v= int_sum(t1= v, t2= mk_int((double) l)); X Release(t1); Release(t2); X rest= frexp(rest - frexp(p, &dummy), &re); X z= z - re - LONGBITS; X digits+= LONGBITS; X } X if (neg) { X v= int_neg(t1= v); X Release(t1); X } X n= mk_int(expo - (double) digits); X w= prod2n((value) v, (value) n, Yes); X Release(v); Release(n); X X return w; X} X X/* X * app_print(f, v) writes an approximate v on file f in such a way that it X * can be read back identically, assuming integral powers of ~2 can be X * computed exactly. To ensure this we have incorporated a test in the X * routine power(). X */ X XVisible Procedure app_print(fp, v) FILE *fp; real v; { X double frac= Frac(v); X double expo= Expo(v); X expint ei; X integer w; X string str; X X frac = frexp(frac, &ei); X expo += ei; X X if (frac == 0.0) { X fputs("~0", fp); X return; X } X if (frac < 0) { X frac = -frac; X putc('-', fp); X } X if (frac == 0.5) X fprintf(fp, "~2**%.0lf", expo-1); X else { X w = mk_int(ldexp(frac, DBLBITS)); X expo -= DBLBITS; X str = convnum((value) w); X fprintf(fp, "%s*~2**%.0lf", str, expo); X Release(w); X } X} X XHidden Procedure initlog() { X double logBASE, invlogtwo; X X logtwo= log(2.0); X X logBASE= log(10.0) * tenlogBASE; X invlogtwo= 1.0 / logtwo; X twologBASE= logBASE * invlogtwo; X} X XVisible Procedure initapp() { X value v; X rational r; X X initlog(); X X twotolongbits= (value) mk_int((double) TWOTO_LONGBITS); X X v = (value) mk_int((double) TWOTO_DBLBITSMIN1); X twotodblbits= prod(v, (value) int_2); X release(v); X X /* to save space, twoto_dblbitsmin1 is stored as X * an unnormalized rational. X */ X r = (rational) grab_rat(0); X Numerator(r) = (integer) copy(twotodblbits); X Denominator(r) = int_2; X twoto_dblbitsmin1= (value) r; X} X XVisible Procedure endapp() { X release(twoto_dblbitsmin1); X release(twotodblbits); X release(twotolongbits); X} END_OF_FILE if test 10983 -ne `wc -c <'abc/bint1/i1nua.c'`; then echo shar: \"'abc/bint1/i1nua.c'\" unpacked with wrong size! fi # end of 'abc/bint1/i1nua.c' fi if test -f 'abc/btr/i1obj.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/btr/i1obj.c'\" else echo shar: Extracting \"'abc/btr/i1obj.c'\" \(5814 characters\) sed "s/^X//" >'abc/btr/i1obj.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* Generic routines for all values */ X X#include "b.h" X#include "bmem.h" X#include "bobj.h" X#include "i1btr.h" X#include "i1tlt.h" X#include "i3typ.h" X XVisible unsigned tltsyze(type, len, nptrs) X literal type; intlet len; int *nptrs; X{ X *nptrs= 1; X return (unsigned) (sizeof(value)); X} X XVisible Procedure rel_subvalues(v) value v; { X if (Is_tlt(v)) { X relbtree(Root(v), Itemtype(v)); X v->type= '\0'; X freemem((ptr) v); X } X else rrelease(v); X} X X#define INCOMP MESS(500, "incompatible types %s and %s") X XHidden Procedure incompatible(v, w) value v, w; { X value m1, m2, m3, m; X string s1, s2; X X m1= convert(m3= (value) valtype(v), No, No); release(m3); X m2= convert(m3= (value) valtype(w), No, No); release(m3); X s1= sstrval(m1); X s2= sstrval(m2); X sprintf(messbuf, getmess(INCOMP), s1, s2); X m= mk_text(messbuf); X interrV(-1, m); X X fstrval(s1); fstrval(s2); X release(m1); release(m2); X release(m); X} X XVisible bool comp_ok = Yes; /* Temporary, to catch type errors */ X Xrelation comp_tlt(), comp_text(); /* From b1lta.c */ X XVisible relation compare(v, w) value v, w; { X literal vt, wt; X int i; X relation rel; X X comp_ok = Yes; X X if (v EQ w) return(0); X if (IsSmallInt(v) && IsSmallInt(w)) X return SmallIntVal(v) - SmallIntVal(w); X vt = Type(v); X wt = Type(w); X switch (vt) { X case Num: X if (wt != Num) { X incomp: X /*Temporary until static checks are implemented*/ X incompatible(v, w); X comp_ok= No; X return -1; X } X return(numcomp(v, w)); X case Com: X if (wt != Com || Nfields(v) != Nfields(w)) goto incomp; X for (i = 0; i < Nfields(v); i++) { X rel = compare(*Field(v, i), *Field(w, i)); X if (rel NE 0) return(rel); X } X return(0); X case Tex: X if (wt != Tex) goto incomp; X return(comp_text(v, w)); X case Lis: X if (wt != Lis && wt != ELT) goto incomp; X return(comp_tlt(v, w)); X case Tab: X if (wt != Tab && wt != ELT) goto incomp; X return(comp_tlt(v, w)); X case ELT: X if (wt != Tab && wt != Lis && wt != ELT) goto incomp; X return(Root(w) EQ Bnil ? 0 : -1); X default: X syserr(MESS(501, "comparison of unknown types")); X /*NOTREACHED*/ X } X} X X/* Used for set'random. Needs to be rewritten so that for small changes in v */ X/* you get large changes in hash(v) */ X XVisible double hash(v) value v; { X if (Is_number(v)) return numhash(v); X else if (Is_compound(v)) { X int len= Nfields(v), k; double d= .404*len; X k_Overfields { X d= .874*d+.310*hash(*Field(v, k)); X } X return d; X } else { X int len= length(v), k; double d= .404*len; X if (len == 0) return .909; X else if (Is_text(v)) { X value ch; X for (k= 0; k'abc/btr/i1tlt.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* generic routines for B texts, lists and tables */ X X#include "b.h" X#include "feat.h" X#include "bobj.h" X#include "i1btr.h" X#include "i1tlt.h" X X#define SIZE_TLT MESS(300, "in #t, t is not a text list or table") X X#define SIZE2_TLT MESS(301, "in e#t, t is not a text list or table") X#define SIZE2_CHAR MESS(302, "in e#t, t is a text, but e is not a character") X X#define MIN_TLT MESS(303, "in min t, t is not a text list or table") X#define MIN_EMPTY MESS(304, "in min t, t is empty") X X#define MAX_TLT MESS(305, "in max t, t is not a text list or table") X#define MAX_EMPTY MESS(306, "in max t, t is empty") X X#define MIN2_TLT MESS(307, "in e min t, t is not a text list or table") X#define MIN2_EMPTY MESS(308, "in e min t, t is empty") X#define MIN2_CHAR MESS(309, "in e min t, t is a text, but e is not a character") X#define MIN2_ELEM MESS(310, "in e min t, no element of t exceeds e") X X#define MAX2_TLT MESS(311, "in e max t, t is not a text list or table") X#define MAX2_EMPTY MESS(312, "in e max t, t is empty") X#define MAX2_CHAR MESS(313, "in e max t, t is a text, but e is not a character") X#define MAX2_ELEM MESS(314, "in e max t, no element of t is less than e") X X#define ITEM_TLT MESS(315, "in t item n, t is not a text list or table") X#define ITEM_EMPTY MESS(316, "in t item n, t is empty") X#define ITEM_NUM MESS(317, "in t item n, n is not a number") X#define ITEM_INT MESS(318, "in t item n, n is not an integer") X#define ITEM_L_BND MESS(319, "in t item n, n is < 1") X#define ITEM_U_BND MESS(320, "in t item n, n exceeds #t") X X#ifdef B_COMPAT X X#define THOF_TLT MESS(321, "in n th'of t, t is not a text list or table") X#define THOF_EMPTY MESS(322, "in n th'of t, t is empty") X#define THOF_NUM MESS(323, "in n th'of t, n is not a number") X#define THOF_INT MESS(324, "in n th'of t, n is not an integer") X#define THOF_L_BND MESS(325, "in n th'of t, n is < 1") X#define THOF_U_BND MESS(326, "in n th'of t, n exceeds #t") X X#endif /* B_COMPAT */ X X/* From b1lta.c */ Xint l2size(); Xvalue l2min(), l2max(); X XVisible value mk_elt() { /* {}, internal only */ X value e = grab(ELT, Lt); X Root(e) = Bnil; X return e; X} X XVisible bool empty(v) value v; { /* #v=0, internal only */ X switch (Type(v)) { X case ELT: X case Lis: X case Tex: X case Tab: X return Root(v) EQ Bnil; X default: X return No; X /* Some routines must test empty(t) end return an error X message if it fails, before testing Type(t). X In this way, they won't give the wrong error message. */ X } X} X X/* return size of (number of items in) dependent tree */ X XHidden value treesize(pnode) btreeptr pnode; { X int psize; X value vsize, childsize, u; X intlet l; X psize = Size(pnode); X if (psize EQ Bigsize) { X switch (Flag(pnode)) { X case Inner: X vsize = mk_integer((int) Lim(pnode)); X for (l = 0; l <= Lim(pnode); l++) { X childsize = treesize(Ptr(pnode, l)); X u = vsize; X vsize = sum(vsize, childsize); X release(u); X release(childsize); X } X break; X case Irange: X u = diff(Upbval(pnode), Lwbval(pnode)); X vsize = sum(u, one); X release(u); X break; X case Bottom: X case Crange: X syserr(MESS(327, "Bigsize in Bottom or Crange")); X } X return(vsize); X } X return mk_integer(psize); X} X XVisible value size(t) value t; { /* #t */ X int tsize; X switch (Type(t)) { X case ELT: X case Lis: X case Tex: X case Tab: X tsize = Tltsize(t); X if (tsize EQ Bigsize) return treesize(Root(t)); X return mk_integer(tsize); X default: X reqerr(SIZE_TLT); X return zero; X } X} X XVisible value item(v, num) value v, num; { /* v item num */ X value m= Vnil; X if (!Is_tlt(v)) X interr(ITEM_TLT); X else if (!Is_number(num)) X interr(ITEM_NUM); X else if (empty(v)) X interr(ITEM_EMPTY); X else if (numcomp(num, one) < 0) X interr(ITEM_L_BND); X else if (Tltsize(v) == Bigsize) { X /* only happens for big Iranges; X * the following code is only valid for flat ranges X */ X value r; X r= treesize(Root(v)); X if (compare(r, num) < 0) X interr(ITEM_U_BND); X else { X release(r); X r= sum(num, Lwbval(Root(v))); X m= diff(r, one); X } X release(r); X } X else { X m= thof(intval(num), v); X if (m == Vnil && still_ok) X interr(ITEM_U_BND); X } X return m; X} X X#ifdef B_COMPAT X XVisible value th_of(num, v) value num, v; { /* num th'of v */ X value m= Vnil; X if (!Is_tlt(v)) X interr(THOF_TLT); X else if (!Is_number(num)) X interr(THOF_NUM); X else if (empty(v)) X interr(THOF_EMPTY); X else if (numcomp(num, one) < 0) X interr(THOF_L_BND); X else if (Tltsize(v) == Bigsize) { X /* only happens for big Iranges; X * the following code is only valid for flat ranges X */ X value r; X r= treesize(Root(v)); X if (compare(r, num) < 0) X interr(ITEM_U_BND); X else { X release(r); X r= sum(num, Lwbval(Root(v))); X m= diff(r, one); X } X release(r); X } X else { X m= thof(intval(num), v); X if (m == Vnil && still_ok) X interr(THOF_U_BND); X } X return m; X} X X#endif /* B_COMPAT */ X X/* X * 'Walktree' handles functions on texts and associates of tables. X * The actual function performed is determined by the 'visit' function. X * The tree is walked (possibly recursively) and all items are visited. X * The return value of walktree() and visit() is used to determine whether X * the walk should continue (Yes == continue, No == stop now). X * Global variables are used to communicate the result, and the parameters X * of the function. The naming convention is according to "e func t". X */ X XHidden intlet tt; /* type of walked value t */ XHidden intlet wt; /* width of items in walked value t */ XHidden value ve; /* value of e, if func is dyadic */ XHidden char ce; /* C char in e, if t is a text */ X XHidden int count; /* result of size2 */ XHidden bool found; /* result for in */ XHidden intlet m_char; /* result for min/max on texts */ XHidden value m_val; /* result for min/max on tables */ X X#define Lowchar (-Maxintlet) /* -infinity for characters */ X#define Highchar (Maxintlet) /* +infinity */ X XHidden bool walktree(p, visit) btreeptr p; bool (*visit)(); { X intlet l; X X if (p EQ Bnil) return Yes; /* i.e., not found (used by in() !) */ X for (l=0; l < Lim(p); l++) { X switch (Flag(p)) { X case Inner: X if (!walktree(Ptr(p, l), visit) || !still_ok) X return No; X if (!(*visit)(Piitm(p, l, wt)) || !still_ok) X return No; X break; X case Bottom: X if (!(*visit)(Pbitm(p, l, wt)) || !still_ok) X return No; X } X } X return Flag(p) EQ Bottom || walktree(Ptr(p, l), visit); X} X X/* Common code for min/max-1/2, size2, in. */ X XHidden int tlterr; X#define T_TLT 1 X#define T_EMPTY 2 X#define T_CHAR 3 X XHidden int tlt_func(e, t, li_func, te_visit, ta_visit) X value e, t; /* [e] func t */ X value (*li_func)(); /* func for lists */ X bool (*te_visit)(), (*ta_visit)(); /* 'visit' for walktree */ X{ X m_val = Vnil; X if (empty(t)) { X tlterr= T_EMPTY; X return -1; X } X tt = Type(t); X switch (tt) { X case Lis: X m_val = (*li_func)(e, t); X break; X case Tex: X if (e NE Vnil) { X if (!Character(e)) { X tlterr= T_CHAR; X return -1; X } X ce = Bchar(Root(e), 0); X } X wt = Itemwidth(Itemtype(t)); X found = !walktree(Root(t), te_visit); X if (m_char NE Lowchar && m_char NE Highchar) X m_val = mkchar(m_char); X break; X case Tab: X ve = e; X wt = Itemwidth(Itemtype(t)); X found = !walktree(Root(t), ta_visit); X break; X default: X tlterr= T_TLT; X return -1; X } X return 0; X} X XHidden value li2size(e, t) value e, t; { X count = l2size(e, t); X return Vnil; X} X XHidden bool te2size(pitm) itemptr pitm; { X if (ce EQ Charval(pitm)) X count++; X return Yes; X} X XHidden bool ta2size(pitm) itemptr pitm; { X if (compare(ve, Ascval(pitm)) EQ 0) X count++; X return Yes; X} X XVisible value size2(e, t) value e, t; { /* e#t */ X m_char = Lowchar; X count = 0; X if (tlt_func(e, t, li2size, te2size, ta2size) == -1) { X switch (tlterr) { X case T_TLT: interr(SIZE2_TLT); X case T_EMPTY: return copy(zero); X case T_CHAR: interr(SIZE2_CHAR); X } X } X return mk_integer(count); X} X XHidden value li_in(e, t) value e, t; { X found = in_keys(e, t); X return Vnil; X} X XHidden bool te_in(pitm) itemptr pitm; { X return Charval(pitm) NE ce; X} X XHidden bool ta_in(pitm) itemptr pitm; { X return compare(ve, Ascval(pitm)) NE 0; X} X XVisible bool in(e, t) value e, t; { X m_char = Lowchar; X found = No; X if (tlt_func(e, t, li_in, te_in, ta_in) == -1) { X switch (tlterr) { X case T_EMPTY: return No; X } X } X return found; X} X XHidden value li_min(e, t) value e, t; { X return item(t, one); X} X XHidden bool te_min(pitm) itemptr pitm; { X if (m_char > Charval(pitm)) X m_char = Charval(pitm); X return Yes; X} X XHidden bool ta_min(pitm) itemptr pitm; { X if (m_val EQ Vnil || compare(m_val, Ascval(pitm)) > 0) { X release(m_val); X m_val = copy(Ascval(pitm)); X } X return Yes; X} X XVisible value min1(t) value t; { X m_char = Highchar; X if (tlt_func(Vnil, t, li_min, te_min, ta_min) == -1) { X switch (tlterr) { X case T_TLT: interr(MIN_TLT); X case T_EMPTY: interr(MIN_EMPTY); X } X } X return m_val; X} X XHidden value li_max(e, t) value e, t; { X value v= size(t); X m_val = item(t, v); X release(v); X return m_val; X} X XHidden bool te_max(pitm) itemptr pitm; { X if (m_char < Charval(pitm)) X m_char = Charval(pitm); X return Yes; X} X XHidden bool ta_max(pitm) itemptr pitm; { X if (m_val EQ Vnil || compare(Ascval(pitm), m_val) > 0) { X release(m_val); X m_val = copy(Ascval(pitm)); X } X return Yes; X} X XVisible value max1(t) value t; { X m_char = Lowchar; X if (tlt_func(Vnil, t, li_max, te_max, ta_max) == -1) { X switch (tlterr) { X case T_TLT: interr(MAX_TLT); X case T_EMPTY: interr(MAX_EMPTY); X } X } X return m_val; X} X XHidden bool te2min(pitm) itemptr pitm; { X if (m_char > Charval(pitm) && Charval(pitm) > ce) { X m_char = Charval(pitm); X } X return Yes; X} X XHidden bool ta2min(pitm) itemptr pitm; { X if (compare(Ascval(pitm), ve) > 0 X && X (m_val EQ Vnil || compare(m_val, Ascval(pitm)) > 0)) { X release(m_val); X m_val = copy(Ascval(pitm)); X } X return Yes; X} X XVisible value min2(e, t) value e, t; { X m_char = Highchar; X if (tlt_func(e, t, l2min, te2min, ta2min) == -1) { X switch (tlterr) { X case T_TLT: interr(MIN2_TLT); X case T_EMPTY: interr(MIN2_EMPTY); X case T_CHAR: interr(MIN2_CHAR); X } X return Vnil; X } X if (m_val EQ Vnil && still_ok) X reqerr(MIN2_ELEM); X return m_val; X} X X/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ X XHidden bool te2max(pitm) itemptr pitm; { X if (ce > Charval(pitm) && Charval(pitm) > m_char) { X m_char = Charval(pitm); X } X return Yes; X} X XHidden bool ta2max(pitm) itemptr pitm; { X if (compare(ve, Ascval(pitm)) > 0 X && X (m_val EQ Vnil || compare(Ascval(pitm), m_val) > 0)) { X release(m_val); X m_val = copy(Ascval(pitm)); X } X return Yes; X} X XVisible value max2(e, t) value e, t; { X m_char = Lowchar; X if (tlt_func(e, t, l2max, te2max, ta2max) == -1) { X switch (tlterr) { X case T_TLT: interr(MAX2_TLT); X case T_EMPTY: interr(MAX2_EMPTY); X case T_CHAR: interr(MAX2_CHAR); X } X return Vnil; X } X if (m_val EQ Vnil && still_ok) X reqerr(MAX2_ELEM); X return m_val; X} X END_OF_FILE if test 10941 -ne `wc -c <'abc/btr/i1tlt.c'`; then echo shar: \"'abc/btr/i1tlt.c'\" unpacked with wrong size! fi # end of 'abc/btr/i1tlt.c' fi echo shar: End of archive 14 \(of 25\). cp /dev/null ark14isdone 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...