v23i093: ABC interactive programming environment, Part14/25
Rich Salz
rsalz at bbn.com
Wed Dec 19 06:40:01 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
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 at 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 at 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<len; ++k) {
X ch= thof(k+1, v);
X d= .987*d+.277*charval(ch);
X release(ch);
X }
X return d;
X } else if (Is_list(v)) {
X value el;
X for (k= 0; k<len; ++k) {
X d= .874*d+.310*hash(el= thof(k+1, v));
X release(el);
X }
X return d;
X } else if (Is_table(v)) {
X for (k= 0; k<len; ++k) {
X d= .874*d+.310*hash(*key(v, k))
X +.123*hash(*assoc(v, k));
X }
X return d;
X } else {
X syserr(MESS(502, "hash called with unknown type"));
X return (double) 0; /* (double)NULL crashes atari MWC */
X }
X }
X}
X
XVisible value convert(v, coll, outer) value v; bool coll, outer; {
X value t, quote, c, cv, sep, th, open, close; int k, len; char ch;
X switch (Type(v)) {
X case Num:
X return mk_text(convnum(v));
X case Tex:
X if (outer) return copy(v);
X quote= mk_text("\"");
X len= length(v);
X t= copy(quote);
X for (k=1; k<=len; k++) {
X c= thof(k, v);
X ch= charval(c);
X concato(&t, c);
X if (ch == '"' || ch == '`') concato(&t, c);
X release(c);
X }
X concato(&t, quote);
X release(quote);
X break;
X case Com:
X len= Nfields(v);
X outer&= coll;
X sep= mk_text(outer ? " " : ", ");
X t= mk_text(coll ? "" : "(");
X for (k= 0; k<len; ++k) {
X concato(&t, cv= convert(*Field(v, k), No, outer));
X release(cv);
X if (k < len - 1) concato(&t, sep);
X }
X release(sep);
X if (!coll) {
X concato(&t, cv= mk_text(")"));
X release(cv);
X }
X break;
X case Lis:
X case ELT:
X len= length(v);
X t= mk_text("{");
X sep= mk_text("; ");
X for (k=1; k<=len; k++) {
X concato(&t, cv= convert(th= thof(k, v), No, No));
X release(cv); release(th);
X if (k != len) concato(&t, sep);
X }
X release(sep);
X concato(&t, cv= mk_text("}"));
X release(cv);
X break;
X case Tab:
X len= length(v);
X open= mk_text("[");
X close= mk_text("]: ");
X sep= mk_text("; ");
X t= mk_text("{");
X for (k= 0; k<len; ++k) {
X concato(&t, open);
X concato(&t, cv= convert(*key(v, k), Yes, No));
X release(cv);
X concato(&t, close);
X concato(&t, cv= convert(*assoc(v, k), No, No));
X release(cv);
X if (k < len - 1) concato(&t, sep);
X }
X concato(&t, cv= mk_text("}")); release(cv);
X release(open); release(close); release(sep);
X break;
X default:
X if (testing) {
X t= mk_text("?");
X concato(&t, cv= mkchar(Type(v))); release(cv);
X concato(&t, cv= mkchar('$')); release(cv);
X break;
X }
X syserr(MESS(503, "unknown type in convert"));
X }
X return t;
X}
X
XHidden value adj(v, w, side) value v, w; char side; {
X value t, c, sp, r, i;
X int len, wid, diff, left, right;
X c= convert(v, Yes, Yes);
X len= length(c);
X wid= intval(w);
X if (wid<=len) return c;
X else {
X diff= wid-len;
X if (side == 'L') { left= 0; right= diff; }
X else if (side == 'R') { left= diff; right= 0; }
X else {left= diff/2; right= (diff+1)/2; }
X sp= mk_text(" ");
X if (left == 0) t= c;
X else {
X t= repeat(sp, i= mk_integer(left)); release(i);
X concato(&t, c);
X release(c);
X }
X if (right != 0) {
X r= repeat(sp, i= mk_integer(right)); release(i);
X concato(&t, r);
X release(r);
X }
X release(sp);
X return t;
X }
X}
X
XVisible value adjleft(v, w) value v, w; {
X return adj(v, w, 'L');
X}
X
XVisible value adjright(v, w) value v, w; {
X return adj(v, w, 'R');
X}
X
XVisible value centre(v, w) value v, w; {
X return adj(v, w, 'C');
X}
X
END_OF_FILE
if test 5814 -ne `wc -c <'abc/btr/i1obj.c'`; then
echo shar: \"'abc/btr/i1obj.c'\" unpacked with wrong size!
fi
# end of 'abc/btr/i1obj.c'
fi
if test -f 'abc/btr/i1tlt.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/btr/i1tlt.c'\"
else
echo shar: Extracting \"'abc/btr/i1tlt.c'\" \(10941 characters\)
sed "s/^X//" >'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...
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list