v23i092: ABC interactive programming environment, Part13/25
Rich Salz
rsalz at bbn.com
Wed Dec 19 06:39:33 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 92
Archive-name: abc/part13
#! /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/e1que1.c abc/bint1/DEP abc/bint3/i3loc.c
# abc/bint3/i3scr.c abc/mkconfig.c
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:28:05 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 13 (of 25)."'
if test -f 'abc/bed/e1que1.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1que1.c'\"
else
echo shar: Extracting \"'abc/bed/e1que1.c'\" \(11620 characters\)
sed "s/^X//" >'abc/bed/e1que1.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Manipulate queues of nodes, lower levels.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "feat.h"
X#include "bobj.h"
X#include "node.h"
X#include "supr.h"
X#include "queu.h"
X#include "gram.h"
X#include "tabl.h"
X
X#ifdef lint
XVisible queue
Xqcopy(q)
X queue q;
X{
X return (queue) copy((value) q);
X}
X
XVisible Procedure
Xqrelease(q)
X queue q;
X{
X release((value) q);
X}
X#endif
X
X/*
X * Append queue 2 to the end of queue 1.
X */
X
XVisible Procedure
Xjoinqueues(pq, q)
X register queue *pq;
X register queue q;
X{
X if (emptyqueue(q))
X return;
X while (*pq) {
X if (Refcnt(*pq) > 1)
X uniql((value*)pq);
X pq = &(*pq)->q_link;
X }
X *pq = q;
X}
X
X
X/*
X * Prepend a node to a queue ("push").
X * Empty strings and Optional holes are silently discarded.
X */
X
XVisible Procedure
Xpreptoqueue(n, pq)
X node n;
X register queue *pq;
X{
X register queue q;
X
X if (Is_etext(n)) {
X if (e_length((value) n) == 0)
X return;
X n = nodecopy(n);
X }
X else { /* Avoid Optional holes */
X if (symbol(n) == Optional)
X return;
X n = nodecopy(n);
X }
X q = (queue) mk_compound(2);
X q->q_data = n;
X q->q_link = *pq;
X *pq = q;
X}
X
X
X/*
X * Append a node to the end of a queue (same extras as preptoqueue).
X */
X
XVisible Procedure
Xaddtoqueue(pq, n)
X register queue *pq;
X register node n;
X{
X auto queue q = Qnil;
X
X preptoqueue(n, &q);
X joinqueues(pq, q);
X}
X
X
X/*
X * Push a string onto a queue.
X */
X
XVisible Procedure
Xstringtoqueue(str, pq)
X register string str;
X register queue *pq;
X{
X register value v;
X
X if (str == NULL)
X return;
X v = mk_etext(str);
X preptoqueue((node) v, pq);
X release(v);
X}
X
X/*
X * Append a string to a queue.
X */
X
X#ifdef NOT_USED
X
XVisible Procedure
Xaddstringtoqueue(pq, str)
X register queue *pq;
X register string str;
X{
X register value v = mk_etext(str);
X
X addtoqueue(pq, (node) v);
X release(v);
X}
X
X#endif /* NOT_USED */
X
X/*
X * Get the first node of a queue and delink it ("pop").
X */
X
XVisible node
Xqueuebehead(pq)
X register queue *pq;
X{
X register node n;
X register queue q = *pq;
X
X Assert(q);
X
X n = nodecopy(q->q_data);
X *pq = qcopy(q->q_link);
X qrelease(q);
X return n;
X}
X
X
X/*
X * Split a node in successive queue elements which are pushed
X * on the queue using preptoqueue.
X * 'Atomic' nodes (texts and holes) are pushed unadorned.
X */
X
XVisible Procedure
Xsplitnode(n, pq)
X register node n;
X register queue *pq;
X{
X register node nn;
X register string *rp;
X register int i;
X register int sym;
X
X if (Is_etext(n)) {
X preptoqueue(n, pq);
X return;
X }
X sym = symbol(n);
X if (sym == Optional)
X return;
X if (sym == Hole) {
X preptoqueue(n, pq);
X return;
X }
X
X rp = noderepr(n);
X for (i = nchildren(n); i >= 0; --i) {
X if (rp[i] && rp[i][0])
X stringtoqueue(rp[i], pq);
X if (i) {
X nn = child(n, i);
X if (Is_etext(nn) || symbol(nn) != Optional)
X preptoqueue(nn, pq);
X }
X }
X}
X
X
X/*
X * Substitute the focus for its parent, appending the remainder of
X * the parent to the queue.
X * The focus must be the first child and not preceded by fixed text.
X * The focus must be allowed in the place of its parent.
X * If any of these conditions is not met, No is returned and nothing
X * is changed.
X *
X * Do not queue a "hollow" rest, since it seems to be substituted anyway.
X * (timo)
X */
X
XVisible bool
Xresttoqueue(pp, pq)
X register path *pp;
X register queue *pq;
X{
X auto queue q = Qnil;
X register path pa = parent(*pp);
X register node n = tree(*pp);
X register int sym = symbol(n);
X /* register markbits x; */
X bool rest_is_hollow();
X
X if (!pa || ichild(*pp) != 1
X || fwidth(noderepr(tree(pa))[0]) != 0 || !allowed(pa, sym))
X return No;
X
X n = nodecopy(n);
X /* x = marks(n); */
X if (!up(pp)) Abort();
X if (!rest_is_hollow(tree(*pp))) {
X splitnode(tree(*pp), &q);
X noderelease(queuebehead(&q));
X joinqueues(pq, q);
X }
X treereplace(pp, n);
X /* if (x) { */
X /* markpath(pp, x); */ /* Actually, should restore all n's marks? */
X /* } */
X return Yes;
X}
X
XHidden bool rest_is_hollow(n) node n; {
X register node nn;
X register string *rp;
X register int i;
X register int sym;
X
X Assert(!Is_etext(n));
X
X rp = noderepr(n);
X for (i = nchildren(n); i >= 0; --i) {
X if (Fwidth(rp[i]) > 0)
X return No;
X if (i > 1) {
X nn = child(n, i);
X if (Is_etext(nn)
X ||
X ((sym=symbol(nn)) != Optional
X &&
X sym != Hole
X )
X )
X return No;
X }
X }
X return Yes;
X}
X
X/*
X * Like resttoqueue, but exactly from current position in fixed text.
X * Also, it cannot fail.
X */
X
XVisible Procedure
Xnosuggtoqueue(ep, pq)
X register environ *ep;
X queue *pq;
X{
X auto queue q = Qnil;
X register int i;
X register string *rp;
X register node n;
X register node nn;
X register int sym;
X string str;
X
X if (issuggestion(ep))
X return;
X Assert((ep->mode == FHOLE || ep->mode == VHOLE) && (ep->s1&1));
X
X n = tree(ep->focus);
X rp = noderepr(n);
X for (i = nchildren(n); i > ep->s1/2; --i) {
X if (!Fw_zero(rp[i]))
X stringtoqueue(rp[i], &q);
X nn = child(n, i);
X sym = symbol(nn);
X if (sym != Optional) {
X preptoqueue(nn, &q);
X if (sym != Hole) {
X s_downi(ep, i);
X delfocus(&ep->focus);
X s_up(ep);
X }
X }
X }
X str = rp[i];
X if (str && str[ep->s2]) /* Push partial first text */
X stringtoqueue(str + ep->s2, &q);
X joinqueues(pq, q);
X}
X
X
X/*
X * Check whether the remainder of the current node is all suggestion.
X */
X
XVisible bool
Xissuggestion(ep)
X register environ *ep;
X{
X register node n;
X register int nch;
X register int sym;
X register int i;
X
X if (ep->mode != VHOLE && ep->mode != FHOLE || !(ep->s1&1))
X return No; /* Actually wrong call? */
X
X n = tree(ep->focus);
X nch = nchildren(n);
X for (i = ep->s1/2 + 1; i <= nch; ++i) {
X sym = symbol(child(n, i));
X if (sym != Hole && sym != Optional)
X return No;
X }
X return Yes;
X}
X
X
X/*
X * See if a node fits in a hole.
X */
X
XVisible bool
Xfitnode(pp, n)
X register path *pp;
X register node n;
X{
X if (!allowed(*pp, symbol(n)))
X return No;
X treereplace(pp, nodecopy(n));
X return Yes;
X}
X
X
X/*
X * Fit a string in a hole.
X * Returns the number of characters consumed.
X * (This does not have to be the maximum possible, but a reasonable attempt
X * is made. If the internal buffer is exhausted, it leaves the rest for
X * another call.)
X */
X
XVisible int
Xfitstring(pp, str, alt_c)
X register path *pp;
X register string str;
X int alt_c;
X{
X environ dummyenv;
X register node n;
X register int ich;
X register int len;
X register string cp;
X char buf[1024];
X
X Assert(str);
X if (!str[0])
X return 0;
X if (!insguess(pp, str[0], &dummyenv)) {
X if (!alt_c)
X return 0;
X if (!insguess(pp, alt_c, &dummyenv))
X return 0;
X }
X if (Is_etext(tree(*pp)))
X if (!up(pp)) Abort();
X if (dummyenv.mode == FHOLE) {
X cp = noderepr(tree(*pp))[0];
X len = 1;
X if (cp) {
X ++str;
X ++cp;
X while (*str >= ' ' && *str == *cp) {
X ++len;
X ++str;
X ++cp;
X }
X }
X return len;
X }
X if (dummyenv.mode == VHOLE) {
X buf[0] = str[0];
X ++str;
X len = 1;
X n = tree(*pp);
X ich = dummyenv.s1/2;
X while (*str && mayinsert(n, ich, len, *str) && len < sizeof buf - 1) {
X buf[len] = *str;
X ++str;
X ++len;
X }
X if (len > 1) {
X buf[len] = 0;
X if (!downi(pp, ich)) Abort();
X treereplace(pp, (node) mk_etext(buf));
X if (!up(pp)) Abort();
X }
X return len;
X }
X return 1;
X}
X
X
X/*
X * Set the focus position (some VHOLE/FHOLE setting, probably)
X * at the 'len'th character from the beginning of the current node.
X * This may involve going to a child or moving beyond the current subtree.
X * Negative 'len' values may be given to indicate negative widths;
X * this is implemented incomplete.
X */
X
XVisible Procedure
Xfixfocus(ep, len)
X register environ *ep;
X register int len;
X{
X node nn;
X register node n = tree(ep->focus);
X register string *rp;
X register int i = 0;
X register int nch;
X register int w;
X
X if (Is_etext(n)) {
X w = e_length((value)n);
X Assert(w >= len && len >= 0);
X if (w > len)
X ep->spflag = No;
X ep->mode = VHOLE;
X ep->s1 = ichild(ep->focus) * 2;
X ep->s2 = len;
X s_up(ep);
X return;
X }
X nch = nchildren(n);
X w = nodewidth(n);
X if (len > w && w >= 0) {
X i = ichild(ep->focus); /* Change initial condition for for-loop */
X if (!up(&ep->focus)) {
X ep->mode = ATEND;
X return;
X }
X higher(ep);
X n = tree(ep->focus);
X }
X
X rp = noderepr(n);
X for (; i <= nch; ++i) {
X if (i) {
X nn = child(n, i);
X w = nodewidth(nn);
X if (w < 0 || w >= len && len >= 0) {
X s_downi(ep, i);
X fixfocus(ep, len);
X return;
X }
X if (len >= 0)
X len -= w;
X }
X w = Fwidth(rp[i]);
X if (w >= len && len >= 0) {
X if (w > len)
X ep->spflag = No;
X ep->mode = FHOLE;
X ep->s1 = 2*i + 1;
X ep->s2 = len;
X return;
X }
X else if (w < 0)
X len = 0;
X else
X len -= w;
X }
X ep->mode = ATEND;
X}
X
X
X/*
X * Apply, if possible, a special fix relating to spaces:
X * when a space has been interpreted as joining character
X * and we end up in the following hole, but we don't succeed
X * in filling the hole; it is then tried to delete the hole
X * and the space.
X * Usually this doesn't occur, but it may occur when inserting
X * after a space that was already fixed on the screen but now
X * deserves re-interpretation.
X */
X
XVisible bool
Xspacefix(ep)
X environ *ep;
X{
X path pa;
X node n;
X string *rp;
X
X if (ichild(ep->focus) != 2 || symbol(tree(ep->focus)) != Hole)
X return No;
X pa = parent(ep->focus);
X n = tree(pa);
X rp = noderepr(n);
X if (!Fw_zero(rp[0]) || Fwidth(rp[1]) != 1 || rp[1][0] != ' ')
X return No;
X n = firstchild(n);
X if (!allowed(pa, symbol(n)))
X return No;
X s_up(ep);
X treereplace(&ep->focus, nodecopy(n));
X ep->mode = ATEND;
X ep->spflag = Yes;
X return Yes;
X}
X
X
X/*
X * Prepend a subset of a node to a queue.
X */
X
XVisible Procedure
Xsubsettoqueue(n, s1, s2, pq)
X register node n;
X register int s1;
X register int s2;
X register queue *pq;
X{
X register string *rp = noderepr(n);
X
X for (; s2 >= s1; --s2) {
X if (s2&1)
X stringtoqueue(rp[s2/2], pq);
X else
X preptoqueue(child(n, s2/2), pq);
X }
X}
X
X#ifdef SHOWBUF
X
X/*
X * Produce flat text out of a queue's first line, to show it on screen.
X */
X
XVisible string
Xquerepr(qv)
X value qv;
X{
X queue q = (queue)qv;
X node n;
X static char buf[1000]; /***** Cannot overflow? *****/
X string cp;
X string sp;
X string *rp;
X int nch;
X int i;
X int len;
X value chld;
X
X cp = buf;
X for (; q; q = q->q_link) {
X n = q->q_data;
X if (Is_etext(n)) {
X for (sp = e_strval((value) n); cp < buf+80 && *sp; ++sp) {
X if (!isprint(*sp) && *sp != ' ')
X break;
X *cp++ = *sp;
X }
X if (*sp == '\n') {
X if (!emptyqueue(q->q_link)) {
X strcpy(cp, " ...");
X cp += 4;
X }
X break;
X }
X }
X else {
X rp = noderepr(n);
X nch = nchildren(n);
X for (i = 0; i <= nch; ++i) {
X if (i > 0) {
X if (Is_etext(child(n, i))) {
X chld= (value) child(n, i);
X len = e_length(chld);
X if (len > 80)
X len = 80;
X strncpy(cp, e_strval(chld), len);
X cp += len;
X }
X else {
X strcpy(cp, "...");
X cp += 3;
X }
X }
X if (Fw_negative(rp[i])) {
X strcpy(cp, " ...");
X cp += 4;
X break;
X }
X if (Fw_positive(rp[i])) {
X strcpy(cp, rp[i]);
X while (*cp)
X ++cp;
X if (cp[-1] == '\t' || cp[-1] == '\b')
X --cp;
X }
X }
X }
X if (cp >= buf+80) {
X strcpy(buf+76, "...");
X break;
X }
X }
X *cp = 0;
X return buf;
X}
X
X#endif /* SHOWBUF */
X
X#ifdef UNUSED
XVisible Procedure dumpqueue(pq, m) queue *pq; string m; {
X char stuff[80];
X register string str = stuff;
X FILE *fp;
X static int qdump;
X queue q= *pq;
X node n;
X
X fp= fopen("/userfs4/abc/timo/mark2/ABCENV", "a");
X Assert(fp != NULL);
X
X qdump++;
X fprintf(fp, "+++ QUEUE %d: %s +++\n", qdump, m);
X
X for (; q; q=q->q_link) {
X fprintf(fp, "NEXTNODE: ");
X n= q->q_data;
X writenode(n, fp);
X fprintf(fp, "\n");
X }
X fprintf(fp, "NILQ\n");
X fclose(fp);
X}
X#endif
END_OF_FILE
if test 11620 -ne `wc -c <'abc/bed/e1que1.c'`; then
echo shar: \"'abc/bed/e1que1.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1que1.c'
fi
if test -f 'abc/bint1/DEP' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint1/DEP'\"
else
echo shar: Extracting \"'abc/bint1/DEP'\" \(2543 characters\)
sed "s/^X//" >'abc/bint1/DEP' <<'END_OF_FILE'
Xi1com.o: i1com.c
Xi1com.o: ../bhdrs/b.h
Xi1com.o: ../uhdrs/osconf.h
Xi1com.o: ../uhdrs/os.h
Xi1com.o: ../uhdrs/conf.h
Xi1com.o: ../uhdrs/config.h
Xi1com.o: ../bhdrs/bint.h
Xi1com.o: ../bhdrs/bobj.h
Xi1com.o: ../ihdrs/i2nod.h
Xi1com.o: ../ihdrs/i2gen.h
Xi1com.o: ../ihdrs/i3env.h
Xi1fun.o: i1fun.c
Xi1fun.o: ../bhdrs/b.h
Xi1fun.o: ../uhdrs/osconf.h
Xi1fun.o: ../uhdrs/os.h
Xi1fun.o: ../uhdrs/conf.h
Xi1fun.o: ../uhdrs/config.h
Xi1fun.o: ../uhdrs/feat.h
Xi1fun.o: ../bhdrs/bobj.h
Xi1fun.o: ../ihdrs/i0err.h
Xi1fun.o: ../ihdrs/i1num.h
Xi1nua.o: i1nua.c
Xi1nua.o: ../bhdrs/b.h
Xi1nua.o: ../uhdrs/osconf.h
Xi1nua.o: ../uhdrs/os.h
Xi1nua.o: ../uhdrs/conf.h
Xi1nua.o: ../uhdrs/config.h
Xi1nua.o: ../uhdrs/feat.h
Xi1nua.o: ../bhdrs/bobj.h
Xi1nua.o: ../ihdrs/i0err.h
Xi1nua.o: ../ihdrs/i1num.h
Xi1nuc.o: i1nuc.c
Xi1nuc.o: ../bhdrs/b.h
Xi1nuc.o: ../uhdrs/osconf.h
Xi1nuc.o: ../uhdrs/os.h
Xi1nuc.o: ../uhdrs/conf.h
Xi1nuc.o: ../uhdrs/config.h
Xi1nuc.o: ../uhdrs/feat.h
Xi1nuc.o: ../bhdrs/bmem.h
Xi1nuc.o: ../bhdrs/bobj.h
Xi1nuc.o: ../ihdrs/i1num.h
Xi1nug.o: i1nug.c
Xi1nug.o: ../bhdrs/b.h
Xi1nug.o: ../uhdrs/osconf.h
Xi1nug.o: ../uhdrs/os.h
Xi1nug.o: ../uhdrs/conf.h
Xi1nug.o: ../uhdrs/config.h
Xi1nug.o: ../uhdrs/feat.h
Xi1nug.o: ../bhdrs/bobj.h
Xi1nug.o: ../ihdrs/i1num.h
Xi1nui.o: i1nui.c
Xi1nui.o: ../bhdrs/b.h
Xi1nui.o: ../uhdrs/osconf.h
Xi1nui.o: ../uhdrs/os.h
Xi1nui.o: ../uhdrs/conf.h
Xi1nui.o: ../uhdrs/config.h
Xi1nui.o: ../uhdrs/feat.h
Xi1nui.o: ../bhdrs/bobj.h
Xi1nui.o: ../ihdrs/i1num.h
Xi1num.o: i1num.c
Xi1num.o: ../bhdrs/b.h
Xi1num.o: ../uhdrs/osconf.h
Xi1num.o: ../uhdrs/os.h
Xi1num.o: ../uhdrs/conf.h
Xi1num.o: ../uhdrs/config.h
Xi1num.o: ../uhdrs/feat.h
Xi1num.o: ../bhdrs/bobj.h
Xi1num.o: ../ihdrs/i1num.h
Xi1nuq.o: i1nuq.c
Xi1nuq.o: ../bhdrs/b.h
Xi1nuq.o: ../uhdrs/osconf.h
Xi1nuq.o: ../uhdrs/os.h
Xi1nuq.o: ../uhdrs/conf.h
Xi1nuq.o: ../uhdrs/config.h
Xi1nuq.o: ../uhdrs/feat.h
Xi1nuq.o: ../bhdrs/bobj.h
Xi1nuq.o: ../ihdrs/i1num.h
Xi1nur.o: i1nur.c
Xi1nur.o: ../bhdrs/b.h
Xi1nur.o: ../uhdrs/osconf.h
Xi1nur.o: ../uhdrs/os.h
Xi1nur.o: ../uhdrs/conf.h
Xi1nur.o: ../uhdrs/config.h
Xi1nur.o: ../uhdrs/feat.h
Xi1nur.o: ../bhdrs/bobj.h
Xi1nur.o: ../ihdrs/i0err.h
Xi1nur.o: ../ihdrs/i1num.h
Xi1nut.o: i1nut.c
Xi1nut.o: ../bhdrs/b.h
Xi1nut.o: ../uhdrs/osconf.h
Xi1nut.o: ../uhdrs/os.h
Xi1nut.o: ../uhdrs/conf.h
Xi1nut.o: ../uhdrs/config.h
Xi1nut.o: ../bhdrs/bobj.h
Xi1nut.o: ../ihdrs/i1num.h
Xi1tra.o: i1tra.c
Xi1tra.o: ../bhdrs/b.h
Xi1tra.o: ../uhdrs/osconf.h
Xi1tra.o: ../uhdrs/os.h
Xi1tra.o: ../uhdrs/conf.h
Xi1tra.o: ../uhdrs/config.h
Xi1tra.o: ../uhdrs/feat.h
Xi1tra.o: ../bhdrs/bobj.h
Xi1tra.o: ../ihdrs/i0err.h
Xi1tra.o: ../ihdrs/i1num.h
END_OF_FILE
if test 2543 -ne `wc -c <'abc/bint1/DEP'`; then
echo shar: \"'abc/bint1/DEP'\" unpacked with wrong size!
fi
# end of 'abc/bint1/DEP'
fi
if test -f 'abc/bint3/i3loc.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3loc.c'\"
else
echo shar: Extracting \"'abc/bint3/i3loc.c'\" \(11448 characters\)
sed "s/^X//" >'abc/bint3/i3loc.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* B locations and environments */
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i0err.h"
X#include "i3env.h" /* for bndtgs */
X#include "i3in2.h"
X
X#define TAR_NO_INIT MESS(3600, "location not initialised")
X#define TARNAME_NO_INIT MESS(3601, "%s hasn't been initialised")
X#define NO_KEY_OF_TABLE MESS(3602, "key not in table")
X#define INS_NO_LIST MESS(3603, "inserting in non-list")
X#define REM_NO_LIST MESS(3604, "removing from non-list")
X#define REM_EMPTY_LIST MESS(3605, "removing from empty list")
X#define SEL_EMPTY MESS(3606, "selection on empty table")
X
X#define Is_local(t) (Is_compound(t))
X#define Is_global(t) (Is_table(t))
X
X#define Loc_indirect(ll) ((ll) != Pnil && *(ll) != Vnil && Is_indirect(*(ll)))
X
XHidden value* location(l, err) loc l; bool err; {
X value *ll= Pnil, lv;
X
X if (Is_locloc(l)) {
X if (!in_locenv(curnv->tab, l, &ll) && err)
X interr(TAR_NO_INIT);
X return ll;
X }
X else if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X value ta= sl->e->tab, ke= sl->i;
X
X if (!in_locenv(ta, ke, &ll)) {
X if (Loc_indirect(ll) && Is_global(ta))
X load_global(*ll, ke, err);
X else if (err) {
X if (Is_locloc(ke))
X interr(TAR_NO_INIT);
X else
X interrV(TARNAME_NO_INIT, ke);
X }
X }
X return ll;
X }
X else if (Is_tbseloc(l)) {
X tbseloc *tl= Tbseloc(l);
X
X lv= locvalue(tl->R, &ll, err);
X if (lv != Vnil) {
X if (!Is_table(lv)) {
X if (err) interr(SEL_NO_TABLE);
X ll= Pnil;
X }
X else {
X ll= adrassoc(lv, tl->K);
X if (ll == Pnil && err)
X interr(NO_KEY_OF_TABLE);
X }
X }
X return ll;
X }
X else {
X syserr(MESS(3607, "call of location with improper type"));
X return (value *) Dummy;
X }
X}
X
XVisible value locvalue(l, ll, err) loc l; value **ll; bool err; {
X *ll= location(l, err);
X if (*ll == Pnil || **ll == Vnil)
X return Vnil;
X else if (Is_indirect(**ll))
X return Indirect(**ll)->val;
X else return **ll;
X}
X
XHidden bool in_locenv(t, k, ll) value t, k, **ll; {
X *ll= envassoc(t, k);
X if (*ll == Pnil || **ll == Vnil)
X return No;
X else if (Is_indirect(**ll) && Indirect(**ll)->val == Vnil)
X return No;
X else return Yes;
X}
X
XVisible Procedure uniquify(l) loc l; {
X if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X value *ta= &(sl->e->tab), ke= sl->i;
X value *aa;
X
X check_location(l);
X uniql(ta);
X if (still_ok) {
X if (Is_local(*ta))
X uniql(aa= Field(*ta, SmallIntVal(ke)));
X else {
X VOID uniq_assoc(*ta, ke);
X aa= adrassoc(*ta, ke);
X }
X if (*aa != Vnil && Is_indirect(*aa))
X uniql(&(Indirect(*aa)->val));
X }
X }
X else if (Is_tbseloc(l)) {
X tbseloc *tl= Tbseloc(l);
X value ta, ke, *ll;
X
X uniquify(tl->R);
X if (still_ok) {
X ta= locvalue(tl->R, &ll, Yes);
X ke= tl->K;
X if (!Is_table(ta)) interr(SEL_NO_TABLE);
X else if (empty(ta)) interr(SEL_EMPTY);
X else if (!in_keys(ke, ta)) interr(NO_KEY_OF_TABLE);
X else VOID uniq_assoc(ta, ke);
X }
X }
X else if (Is_trimloc(l)) {
X syserr(MESS(3608, "uniquifying text-selection location"));
X }
X else if (Is_compound(l)) {
X syserr(MESS(3609, "uniquifying comploc"));
X }
X else syserr(MESS(3610, "uniquifying non-location"));
X}
X
XVisible Procedure check_location(l) loc l; {
X VOID location(l, Yes);
X /* location may produce an error message */
X}
X
XHidden value content(l) loc l; {
X value *ll;
X value lv= locvalue(l, &ll, Yes);
X return still_ok ? copy(lv) : Vnil;
X}
X
X#define TRIM_TARG_TYPE MESS(3611, "text-selection (@ or |) on non-text")
X#define TRIM_TARG_TEXT MESS(3612, "in the location t at p or t|p, t does not contain a text")
X#define TRIM_TARG_BND MESS(3613, "in the location t at p or t|p, p is out of bounds")
X
XVisible loc trim_loc(l, N, sign) loc l; value N; char sign; {
X loc root, res= Lnil;
X value text, B, C;
X
X if (Is_simploc(l) || Is_tbseloc(l)) {
X root= l;
X B= zero; C= zero;
X }
X else if (Is_trimloc(l)) {
X trimloc *rr= Trimloc(l);
X root= rr->R;
X B= rr->B; C= rr->C;
X }
X else {
X interr(TRIM_TARG_TYPE);
X return Lnil;
X }
X text= content(root);
X if (!still_ok);
X else if (!Is_text(text))
X interr(TRIM_TARG_TEXT);
X else {
X value n= size(text), w;
X value Bnew= Vnil, Cnew= Vnil;
X bool changed= No;
X
X if (sign == '@') { /* behead: B= max{N-1+B, B} */
X Bnew= sum(B, w= diff(N, one));
X if (changed= (compare(Bnew, B) > 0))
X B= Bnew;
X }
X else { /* curtail: C= max{n-N-B, C} */
X Cnew= diff(w= diff(n, N), B);
X if (changed= (compare(Cnew, C) > 0))
X C= Cnew;
X }
X if (changed) {
X value b_plus_c= sum(B, C);
X if (still_ok && compare(b_plus_c, n) > 0)
X interr(TRIM_TARG_BND);
X release(b_plus_c);
X }
X if (still_ok) res= mk_trimloc(root, B, C);
X release(Bnew);
X release(Cnew);
X release(w);
X release(n);
X }
X release(text);
X return res;
X}
X
XVisible loc tbsel_loc(R, K) loc R; value K; {
X if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
X else interr(MESS(3614, "selection on location of improper type"));
X return Lnil;
X}
X
XVisible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }
X
XVisible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }
X
XHidden Procedure put_trim(v, tl) value v; trimloc *tl; {
X value rr, nn, head, tail, part, *ll;
X value B= tl->B, C= tl->C, len, b_plus_c, tail_start;
X
X rr= locvalue(tl->R, &ll, Yes);
X len= size(rr);
X b_plus_c= sum(B, C);
X if (compare(b_plus_c, len) > 0)
X interr(MESS(3615, "text-selection (@ or |) out of bounds"));
X else {
X if (compare(B, zero) < 0) B= zero;
X tail_start= sum(len, one);
X if (compare(C, zero) > 0) {
X tail_start= diff(nn= tail_start, C);
X release(nn);
X }
X head= curtail(rr, B); /* rr|B */
X tail= behead(rr, tail_start); /* rr@(#rr-C+1) */
X release(tail_start);
X part= concat(head, v); release(head);
X nn= concat(part, tail); release(part); release(tail);
X put(nn, tl->R); release(nn);
X }
X release(len); release(b_plus_c);
X}
X
XHidden Procedure rm_indirection(l) loc l; {
X for (; Is_tbseloc(l); l= Tbseloc(l)->R)
X ;
X if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X value *ll= envassoc(sl->e->tab, sl->i);
X
X if (Loc_indirect(ll)) {
X value v= copy(Indirect(*ll)->val);
X release(*ll);
X *ll= v;
X }
X }
X}
X
XVisible Procedure put(v, l) value v; loc l; {
X if (Is_locloc(l)) {
X e_replace(v, &curnv->tab, l);
X }
X else if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X e_replace(v, &(sl->e->tab), sl->i);
X }
X else if (Is_trimloc(l)) {
X if (!Is_text(v)) interr(MESS(3616, "putting non-text in text-selection (@ or |)"));
X else put_trim(v, Trimloc(l));
X }
X else if (Is_compound(l)) {
X intlet k, len= Nfields(l);
X if (!Is_compound(v))
X interr(MESS(3617, "putting non-compound in compound location"));
X else if (Nfields(v) != Nfields(l))
X interr(MESS(3618, "putting compound in compound location of different length"));
X else k_Overfields { put(*Field(v, k), *Field(l, k)); }
X }
X else if (Is_tbseloc(l)) {
X tbseloc *tl= Tbseloc(l);
X uniquify(tl->R);
X if (still_ok) {
X value *ll, lv;
X lv= locvalue(tl->R, &ll, Yes);
X if (!Is_table(lv))
X interr(SEL_NO_TABLE);
X else {
X rm_indirection(tl->R);
X replace(v, ll, tl->K);
X }
X }
X }
X else interr(MESS(3619, "putting in non-location"));
X}
X
X/* Check for correct effect of multiple put-command: catches PUT 1, 2 IN x, x.
X The assignment cannot be undone, but this is not considered a problem.
X For trimmed-texts, no checks are made because the language definition
X itself causes problem (try PUT "abc", "" IN x at 2|1, x at 3|1). */
X
XHidden bool putck(v, l) value v; loc l; {
X intlet k, len;
X value *ll, lv;
X if (!still_ok) return No;
X if (Is_compound(l)) {
X if (!Is_compound(v) || Nfields(v) != (len= Nfields(l)))
X return No; /* Severe type error */
X k_Overfields
X { if (!putck(*Field(v, k), *Field(l, k))) return No; }
X return Yes;
X }
X if (Is_trimloc(l)) return Yes; /* Don't check trim locations */
X lv= locvalue(l, &ll, No);
X return lv != Vnil && compare(v, lv) == 0;
X}
X
X/* The check can't be called from within put because put is recursive,
X and so is the check: then, for the inner levels the check would be done
X twice. Moreover, we don't want to clutter up put, which is called
X internally in, many places. */
X
XVisible Procedure put_with_check(v, l) value v; loc l; {
X intlet i, k, len; bool ok;
X put(v, l);
X if (!still_ok || !Is_compound(l))
X return; /* Single target can't be wrong */
X len= Nfields(l); ok= Yes;
X /* Quick check for putting in all different local targets: */
X k_Overfields {
X if (!IsSmallInt(*Field(l, k))) { ok= No; break; }
X for (i= k-1; i >= 0; --i) {
X if (*Field(l, i) == *Field(l, k)) { ok= No; break; }
X }
X if (!ok) break;
X }
X if (ok) return; /* All different local basic-targets */
X if (!putck(v, l))
X interr(MESS(3620, "putting different values in same location"));
X}
X
X
X#define DEL_NO_TARGET MESS(3621, "deleting non-location")
X#define DEL_TRIM_TARGET MESS(3622, "deleting text-selection (@ or |) location")
X
XHidden bool l_exists(l) loc l; {
X if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X value ta= sl->e->tab, *ll;
X return in_locenv(ta, sl->i, &ll) ||
X Loc_indirect(ll) && Is_global(ta);
X }
X else if (Is_trimloc(l)) {
X interr(DEL_TRIM_TARGET);
X return No;
X }
X else if (Is_compound(l)) {
X intlet k, len= Nfields(l);
X k_Overfields { if (!l_exists(*Field(l, k))) return No; }
X return Yes;
X }
X else if (Is_tbseloc(l)) {
X tbseloc *tl= Tbseloc(l);
X value *ll;
X value lv= locvalue(tl->R, &ll, Yes);
X if (still_ok) {
X if (!Is_table(lv))
X interr(SEL_NO_TABLE);
X else
X return in_keys(tl->K, lv);
X }
X return No;
X }
X else {
X interr(DEL_NO_TARGET);
X return No;
X }
X}
X
X/* Delete a location if it exists */
X
XVisible Procedure l_del(l) loc l; {
X if (Is_simploc(l)) {
X simploc *sl= Simploc(l);
X e_delete(&(sl->e->tab), sl->i);
X if (sl->e == prmnv)
X del_target(sl->i);
X }
X else if (Is_trimloc(l)) {
X interr(DEL_TRIM_TARGET);
X }
X else if (Is_compound(l)) {
X intlet k, len= Nfields(l);
X k_Overfields { l_del(*Field(l, k)); }
X }
X else if (Is_tbseloc(l)) {
X tbseloc *tl= Tbseloc(l);
X value *ll, lv;
X uniquify(tl->R);
X if (still_ok) {
X lv= locvalue(tl->R, &ll, Yes);
X if (in_keys(tl->K, lv)) {
X rm_indirection(tl->R);
X delete(ll, tl->K);
X }
X }
X }
X else interr(DEL_NO_TARGET);
X}
X
XVisible Procedure l_delete(l) loc l; {
X if (l_exists(l)) l_del(l);
X else interr(MESS(3623, "deleting non-existent location"));
X}
X
XVisible Procedure l_insert(v, l) value v; loc l; {
X value *ll, lv;
X uniquify(l);
X if (still_ok) {
X lv= locvalue(l, &ll, Yes);
X if (!Is_list(lv))
X interr(INS_NO_LIST);
X else {
X rm_indirection(l);
X insert(v, ll);
X }
X }
X}
X
XVisible Procedure l_remove(v, l) value v; loc l; {
X value *ll, lv;
X uniquify(l);
X if (still_ok) {
X lv= locvalue(l, &ll, Yes);
X if (!Is_list(lv))
X interr(REM_NO_LIST);
X else if (empty(lv))
X interr(REM_EMPTY_LIST);
X else {
X rm_indirection(l);
X remove(v, ll);
X }
X }
X}
X
XVisible Procedure bind(l) loc l; {
X if (*bndtgs != Vnil) {
X if (Is_simploc(l)) {
X simploc *ll= Simploc(l);
X if (!in(ll->i, *bndtgs)) /* kludge */ /* what for? */
X insert(ll->i, bndtgs);
X }
X else if (Is_compound(l)) {
X intlet k, len= Nfields(l);
X k_Overfields { bind(*Field(l, k)); }
X }
X else interr(MESS(3624, "binding non-location"));
X }
X l_del(l);
X}
X
XVisible Procedure unbind(l) loc l; {
X if (*bndtgs != Vnil) {
X if (Is_simploc(l)) {
X simploc *ll= Simploc(l);
X if (in(ll->i, *bndtgs))
X remove(ll->i, bndtgs);
X }
X else if (Is_compound(l)) {
X intlet k, len= Nfields(l);
X k_Overfields { unbind(*Field(l, k)); }
X }
X else interr(MESS(3625, "unbinding non-location"));
X }
X l_del(l);
X}
END_OF_FILE
if test 11448 -ne `wc -c <'abc/bint3/i3loc.c'`; then
echo shar: \"'abc/bint3/i3loc.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3loc.c'
fi
if test -f 'abc/bint3/i3scr.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3scr.c'\"
else
echo shar: Extracting \"'abc/bint3/i3scr.c'\" \(12005 characters\)
sed "s/^X//" >'abc/bint3/i3scr.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* B input/output handling */
X
X#include "b.h"
X#include "bint.h"
X#include "feat.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "bcom.h"
X#include "i2nod.h"
X#include "i2par.h"
X#include "i3typ.h"
X#include "i3env.h"
X#include "i3in2.h"
X#include "i3scr.h"
X
X#ifdef SETJMP
X#include <setjmp.h>
X#endif
X
XVisible bool interactive;
XVisible bool rd_interactive;
XVisible value iname= Vnil; /* input name */
XVisible bool outeractive;
XVisible bool at_nwl= Yes; /*Yes if currently at the start of an output line*/
XHidden bool last_was_text= No; /*Yes if last value written was a text*/
X
XVisible bool Eof;
XHidden FILE *ofile= stdout;
XVisible FILE *ifile; /* input file */
XVisible FILE *sv_ifile; /* copy of ifile for restoring after reading unit */
X
XVisible bool readIcontext= No;
X#ifdef SETJMP
XVisible jmp_buf readIinterrupt;
X#endif
X
X/******************************* Output *******************************/
X
XHidden int ocol; /* Current output column */
X
XHidden Procedure putch(c) char c; {
X if (still_ok) {
X putchr(ofile, c);
X if (c == '\n') { at_nwl= Yes; ocol= 0; }
X else {
X if (at_nwl) { ocol= 0; at_nwl= No;}
X ++ocol;
X }
X }
X}
X
XVisible Procedure newline() {
X putch('\n');
X fflush(ofile);
X}
X
XVisible Procedure oline() {
X if (!at_nwl) newline();
X}
X
XVisible Procedure wri_space() {
X putch(' ');
X}
X
XVisible Procedure writ(v) value v; {
X wri(v, No, Yes, No);
X fflush(ofile);
X}
X
X#define Putch_sp() {if (!perm) putch(' ');}
X
XHidden int intsize(v) value v; {
X value s= size(v); int len=0;
X if (large(s)) interr(MESS(3800, "value too big to output"));
X else len= intval(s);
X release(s);
X return len;
X}
X
XHidden bool lwt;
X
X#ifdef RANGEPRINT
XHidden Procedure wri_vals(l, u) value l, u; {
X if (compare(l, u) == 0)
X wri(l, No, No, No);
X else if (is_increment(u, l)) {
X wri(l, No, No, No);
X putch(';'); putch(' ');
X wri(u, No, No, No);
X }
X else {
X wri(l, No, No, No);
X putch('.'); putch('.');
X wri(u, No, No, No);
X }
X}
X#endif /* RANGEPRINT */
X
XVisible Procedure wri(v, coll, outer, perm) value v; bool coll, outer, perm; {
X if (outer && !at_nwl && (!Is_text(v) || !last_was_text)
X && (!Is_compound(v) || !coll)) putch(' ');
X lwt= No;
X if (Is_number(v)) {
X if (perm) printnum(ofile, v);
X else {
X string cp= convnum(v);
X while(*cp && still_ok) putch(*cp++);
X }
X } else if (Is_text(v)) {
X wrtext(putch, v, outer ? '\0' : '"');
X lwt= outer;
X } else if (Is_compound(v)) {
X intlet k, len= Nfields(v);
X if (!coll) putch('(');
X for (k=0; k<len && still_ok; k++) {
X wri(*Field(v, k), No, No, perm);
X if (!Lastfield(k)) {
X putch(',');
X Putch_sp();
X }
X }
X if (!coll) putch(')');
X } else if (Is_list(v) || Is_ELT(v)) {
X putch('{');
X#ifndef RANGEPRINT
X if (perm && is_rangelist(v)) {
X value vm;
X wri(vm=min1(v), No, No, perm);
X release(vm);
X putch('.'); putch('.');
X wri(vm=max1(v), No, No, perm);
X release(vm);
X }
X else {
X value i, s, vi;
X relation c;
X
X i= copy(one); s= size(v);
X while((c= numcomp(i, s)) <= 0 && !Interrupted()) {
X vi= item(v, i);
X wri(vi, No, No, perm);
X if (c < 0) {
X putch(';'); putch(' ');
X }
X release(vi);
X i= sum(vi=i, one);
X release(vi);
X }
X release(i); release(s);
X }
X#else /* RANGEPRINT */
X if (is_rangelist(v)) {
X value vm;
X wri(vm=min1(v), No, No, perm);
X release(vm);
X putch('.'); putch('.');
X wri(vm=max1(v), No, No, perm);
X release(vm);
X }
X else if (!perm) {
X value i, s, vi, lwb, upb;
X bool first= Yes;
X i= copy(one); s= size(v);
X while (numcomp(i, s) <= 0 && !Interrupted()) {
X vi= item(v, i);
X if (first) {
X lwb= copy(vi);
X upb= copy(vi);
X first= No;
X }
X else if (is_increment(vi, upb)) {
X release(upb);
X upb= copy(vi);
X }
X else {
X wri_vals(lwb, upb) ;
X putch(';'); putch(' ');
X release(lwb); release(upb);
X lwb= copy(vi); upb= copy(vi);
X }
X release(vi);
X i= sum(vi=i, one);
X release(vi);
X }
X if (!first) {
X wri_vals(lwb, upb);
X release(lwb); release(upb);
X }
X release(i); release(s);
X }
X else {
X value ve; int k, len= intsize(v);
X for (k=0; k<len && still_ok; k++) {
X wri(ve= thof(k+1, v), No, No, perm);
X release(ve);
X if (k < len - 1) {
X putch(';');
X Putch_sp();
X }
X }
X }
X#endif
X putch('}');
X } else if (Is_table(v)) {
X int k, len= intsize(v);
X putch('{');
X for (k=0; k<len && still_ok; k++) {
X putch('['); wri(*key(v, k), Yes, No, perm);
X putch(']'); putch(':'); Putch_sp();
X wri(*assoc(v, k), No, No, perm);
X if (k < len - 1) {
X putch(';');
X Putch_sp();
X }
X }
X putch('}');
X } else {
X if (testing) { putch('?'); putch(Type(v)); putch('?'); }
X else syserr(MESS(3801, "writing value of unknown type"));
X }
X last_was_text= lwt;
X if (interrupted) clearerr(ofile); /* needed for MSDOS
X * harmless for unix ???
X */
X}
X
X/***************************** Input ****************************************/
X
X/* Read a line; EOF only allowed if not interactive, in which case eof set */
X/* Returns the line input */
X/* This is the only place where a long jump is necessary */
X/* In other places, interrupts are just like procedure calls, and checks */
X/* of still_ok and interrupted suffice: eventually the stack unwinds to the*/
X/* main loop in imm_command(). Here though, an interrupt must actually */
X/* terminate the read. Hence the bool readIcontext indicating if the */
X/* long jump is necessary or not */
X
X#define Mixed_stdin_file (!rd_interactive && sv_ifile == stdin)
X
XHidden bufadm i_buf, o_buf;
Xextern bool i_looked_ahead;
X
XHidden char *read_line(kind, should_prompt, eof)
X literal kind;
X bool should_prompt, *eof;
X{
X bufadm *bp= (kind == R_cmd && ifile == sv_ifile) ? &i_buf : &o_buf;
X FILE *fp= (kind == R_cmd || kind == R_ioraw) ? ifile : stdin;
X
X bufreinit(bp);
X *eof= No;
X
X#ifdef SETJMP
X if (setjmp(readIinterrupt) != 0) {
X readIcontext= No;
X return bp->buf;
X }
X#endif
X if ((kind == R_expr || kind == R_raw)
X && Mixed_stdin_file && i_looked_ahead)
X {
X /* e.g. "abc <mixed_commands_and_input_for_READs_on_file" */
X /* ilev looked_ahead for command following suite */
X /* and ate a line meant for a READ command */
X bufcpy(bp, i_buf.buf);
X i_looked_ahead= No;
X }
X else if (!should_prompt) {
X if (!fileline(fp, bp))
X *eof= Yes;
X }
X else if (cmdline(kind, bp, (at_nwl ? 0 : ocol))) {
X if (outeractive) at_nwl= Yes;
X }
X return bp->buf;
X}
X
X#define LINESIZE 200
X
XHidden bool fileline(fp, bp) FILE *fp; bufadm *bp; {
X char line[LINESIZE];
X char *pline;
X
X for (;;) {
X readIcontext= Yes;
X pline= fgets(line, LINESIZE, fp);
X readIcontext= No;
X if (pline == NULL) {
X bufcpy(bp, "\n");
X if (*(bp->buf) == '\n')
X return No;
X clearerr(fp);
X return Yes;
X }
X bufcpy(bp, line);
X if (strchr(line, '\n') != NULL)
X return Yes;
X }
X}
X
XHidden Procedure init_read() {
X bufinit(&i_buf);
X bufinit(&o_buf);
X bufcpy(&o_buf, "\n");
X tx= (txptr) o_buf.buf;
X}
X
XHidden Procedure end_read() {
X buffree(&i_buf);
X buffree(&o_buf);
X}
X
X/****************************************************************************/
X
X#define ANSWER MESS(3802, "*** Please answer with '%c' or '%c'\n")
X#define JUST_YES_OR_NO MESS(3803, "*** Just '%c' or '%c', please\n")
X#define LAST_CHANCE MESS(3804, "*** This is your last chance. Take it. I really don't know what you want.\n So answer the question\n")
X#define NO_THEN MESS(3805, "*** Well, I shall assume that your refusal to answer the question means '%c'!\n")
X
X/* Rather over-fancy routine to ask the user a question */
X/* Will anybody discover that you're only given 4 chances? */
X
XVisible char q_answer(m, c1, c2, c3) int m; char c1, c2, c3; {
X char answer; intlet try; txptr tp; bool eof;
X
X if (!interactive)
X return c1;
X if (outeractive)
X oline();
X for (try= 1; try<=4; try++){
X if (try == 1 || try == 3)
X q_mess(m, c1, c2);
X tp= (txptr) read_line(R_answer, Yes, &eof);
X if (interrupted) {
X interrupted= No;
X if (c3 == '\0') {
X still_ok= Yes;
X q_mess(NO_THEN, c2, c1);
X break;
X }
X else {
X return c3;
X }
X }
X skipsp(&tp);
X answer= Char(tp);
X if (answer == c1)
X return c1;
X if (answer == c2)
X return c2;
X if (outeractive)
X oline();
X if (try == 1)
X q_mess(ANSWER, c1, c2);
X else if (try == 2)
X q_mess(JUST_YES_OR_NO, c1, c2);
X else if (try == 3)
X q_mess(LAST_CHANCE, c1, c2);
X else
X q_mess(NO_THEN, c2, c1);
X } /* end for */
X return c2;
X}
X
XHidden Procedure q_mess(m, c1, c2) int m; char c1, c2; {
X put2Cmess(errfile, m, c1, c2);
X fflush(errfile);
X}
X
XVisible bool is_intended(m) int m; {
X char c1, c2;
X
X#ifdef FRENCH
X c1= 'o'; c2= 'n';
X#else /* ENGLISH */
X c1= 'y'; c2= 'n';
X#endif
X return q_answer(m, c1, c2, (char)'\0') == c1 ? Yes : No;
X}
X
X#define EG_EOF MESS(3806, "End of input encountered during READ command")
X#define RAW_EOF MESS(3807, "End of input encountered during READ t RAW")
X#define EG_INCOMP MESS(3808, "type of expression does not agree with that of EG sample")
X#define TRY_AGAIN MESS(3809, "*** Please try again\n")
X
X/* Read_eg uses evaluation but it shouldn't.
X Wait for a more general mechanism. */
X
XVisible Procedure read_eg(l, t) loc l; btype t; {
X context c; parsetree code;
X parsetree r= NilTree; value rv= Vnil; btype rt= Vnil;
X envtab svprmnvtab= Vnil;
X txptr fcol_save= first_col, tx_save= tx;
X do {
X still_ok= Yes;
X sv_context(&c);
X if (cntxt != In_read) {
X release(read_context.uname);
X sv_context(&read_context);
X }
X svprmnvtab= prmnvtab == Vnil ? Vnil : prmnv->tab;
X /* save scratch-pad copy because of following setprmnv() */
X setprmnv();
X cntxt= In_read;
X first_col= tx= (txptr) read_line(R_expr, rd_interactive, &Eof);
X if (still_ok && Eof) interr(EG_EOF);
X if (!rd_interactive) {
X if (sv_ifile == stdin)
X f_lino++;
X else
X i_lino++;
X }
X rt= Vnil;
X if (still_ok) {
X findceol();
X r= expr(ceol);
X if (still_ok) fix_nodes(&r, &code);
X rv= evalthread(code); release(r);
X if (still_ok) rt= valtype(rv);
X }
X if (svprmnvtab != Vnil) {
X prmnvtab= prmnv->tab;
X prmnv->tab= svprmnvtab;
X }
X if (still_ok) must_agree(t, rt, EG_INCOMP);
X set_context(&c);
X release(rt);
X if (!still_ok && rd_interactive && !interrupted)
X putmess(errfile, TRY_AGAIN);
X } while (!interrupted && !still_ok && rd_interactive);
X if (still_ok) put(rv, l);
X first_col= fcol_save;
X tx= tx_save;
X release(rv);
X}
X
XVisible Procedure read_raw(l) loc l; {
X value r; bool eof;
X txptr text= (txptr) read_line(R_raw, rd_interactive, &eof);
X if (still_ok && eof)
X interr(RAW_EOF);
X if (!rd_interactive) {
X if (sv_ifile == stdin)
X f_lino++;
X else
X i_lino++;
X }
X if (still_ok) {
X txptr rp= text;
X while (*rp != '\n') rp++;
X *rp= '\0';
X r= mk_text(text);
X put(r, l);
X release(r);
X }
X}
X
XVisible bool io_exit;
X
XVisible bool read_ioraw(v) value *v; { /* returns Yes if end of input */
X txptr text, rp;
X bool eof;
X
X *v= Vnil;
X io_exit= No;
X text= (txptr) read_line(R_ioraw, rd_interactive, &eof);
X if (eof || interrupted || !still_ok)
X return Yes;
X rp= text;
X while (*rp != '\n')
X rp++;
X *rp= '\0';
X if (strlen(text) > 0 || !io_exit)
X *v= mk_text(text);
X return io_exit;
X}
X
XVisible char *getline() {
X bool should_prompt=
X interactive && ifile == sv_ifile;
X return read_line(R_cmd, should_prompt, &Eof);
X}
X
X/******************************* Files ******************************/
X
XVisible Procedure redirect(of) FILE *of; {
X static bool woa= No, wnwl= No; /*was outeractive, was at_nwl */
X ofile= of;
X if (of == stdout) {
X outeractive= woa;
X at_nwl= wnwl;
X } else {
X woa= outeractive; outeractive= No;
X wnwl= at_nwl; at_nwl= Yes;
X }
X}
X
XVisible Procedure vs_ifile() {
X ifile= sv_ifile;
X}
X
XVisible Procedure re_screen() {
X sv_ifile= ifile;
X interactive= f_interactive(ifile);
X Eof= No;
X}
X
X/* initscr is a reserved name of CURSES */
XVisible Procedure init_scr() {
X outeractive= f_interactive(stdout);
X rd_interactive= f_interactive(stdin);
X init_read();
X}
X
XVisible Procedure end_scr() {
X end_read();
X}
END_OF_FILE
if test 12005 -ne `wc -c <'abc/bint3/i3scr.c'`; then
echo shar: \"'abc/bint3/i3scr.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3scr.c'
fi
if test -f 'abc/mkconfig.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/mkconfig.c'\"
else
echo shar: Extracting \"'abc/mkconfig.c'\" \(12184 characters\)
sed "s/^X//" >'abc/mkconfig.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
X
X/* Generate constants for configuration file */
X
X#include "osconf.h"
X
X/* If your C system is not unix but does have signal/setjmp, */
X/* add a #define unix */
X/* You may also need to add some calls to signal(). */
X
X#ifdef unix
X
X#define SIGNAL
X
X#include <signal.h>
X#include <setjmp.h>
X
X jmp_buf lab;
X overflow(sig) int sig; { /* what to do on overflow/underflow */
X signal(sig, overflow);
X longjmp(lab, 1);
X }
X
X#else
X /* Dummy routines instead */
X int lab=1;
X int setjmp(lab) int lab; { return(0); }
X
X#endif
X
X#define absval(x) (((x)<0.0)?(-x):(x))
X#define min(x,y) (((x)<(y))?(x):(y))
X
X/* These routines are intended to defeat any attempt at optimisation */
XDstore(a, b) double a, *b; { *b=a; }
Xdouble Dsum(a, b) double a, b; { double r; Dstore(a+b, &r); return (r); }
Xdouble Ddiff(a, b) double a, b; { double r; Dstore(a-b, &r); return (r); }
Xdouble Dmul(a, b) double a, b; { double r; Dstore(a*b, &r); return (r); }
Xdouble Ddiv(a, b) double a, b; { double r; Dstore(a/b, &r); return (r); }
X
Xdouble power(x, n) int x, n; {
X double r=1.0;
X for (;n>0; n--) r*=x;
X return r;
X}
X
Xint floor_log(base, x) int base; double x; { /* return floor(log base(x)) */
X int r=0;
X while (x>=base) { r++; x/=base; }
X return r;
X}
X
Xint ceil_log(base, x) int base; double x; {
X int r=0;
X while (x>1.0) { r++; x/=base; }
X return r;
X}
X
X/* The following is ABC specific. */
X/* It tries to prevent different alignments for the field */
X/* following common HEADER fields in various structures */
X/* used by the ABC system for different types of values. */
X
X/* literal and reftype are in ?hdrs/osconf.h */
Xtypedef short intlet;
X#define HEADER literal type; reftype refcnt; intlet len
Xtypedef struct header { HEADER; } header;
Xtypedef struct value { HEADER; char **cts;} value;
X
X
Xmain(argc, argv) int argc; char *argv[]; {
X char c;
X short newshort, maxshort, maxershort;
X int newint, maxint, maxdigit, shortbits, bits, mantbits,
X *p, shortpower, intpower, longpower;
X long newlong, maxlong;
X#ifdef MEMSIZE
X long count;
X#endif
X unsigned long nfiller;
X int i, ibase, iexp, irnd, imant, iz, k, machep, maxexp, minexp,
X mx, negeps, tendigs;
X double a, b, base, basein, basem1, eps, epsneg, xmax, newxmax,
X xmin, xminner, y, y1, z, z1, z2;
X
X double BIG, Maxreal;
X int BASE, MAXNUMDIG, tenlogBASE, Maxexpo, Minexpo, DBLBITS, LONGBITS;
X
X#ifdef SIGNAL
X signal(SIGFPE, overflow);
X if (setjmp(lab)!=0) { printf("Unexpected over/underflow\n"); exit(1); }
X#endif
X
X/****** Calculate max short *********************************************/
X/* Calculate 2**n-1 until overflow - then use the previous value */
X
X newshort=1; maxshort=0;
X
X if (setjmp(lab)==0)
X for(shortpower=0; newshort>maxshort; shortpower++) {
X maxshort=newshort;
X newshort=newshort*2+1;
X }
X
X /* Now for those daft Cybers: */
X
X maxershort=0; newshort=maxshort;
X
X if (setjmp(lab)==0)
X for(shortbits=shortpower; newshort>maxershort; shortbits++) {
X maxershort=newshort;
X newshort=newshort+newshort+1;
X }
X
X bits= (shortbits+1)/sizeof(short);
X c= (char)(-1);
X printf("/\* char=%d bits, %ssigned *\/\n", sizeof(c)*bits,
X ((int)c)<0?"":"un");
X printf("/\* maxshort=%d (=2**%d-1) *\/\n", maxshort, shortpower);
X
X if (maxershort>maxshort) {
X printf("/\* There is a larger maxshort, %d (=2**%d-1), %s *\/\n",
X maxershort, shortbits,
X "but only for addition, not multiplication");
X }
X
X/****** Calculate max int by the same method ***************************/
X
X newint=1; maxint=0;
X
X if (setjmp(lab)==0)
X for(intpower=0; newint>maxint; intpower++) {
X maxint=newint;
X newint=newint*2+1;
X }
X
X printf("/\* maxint=%d (=2**%d-1) *\/\n", maxint, intpower);
X
X/****** Calculate max long by the same method ***************************/
X
X newlong=1; maxlong=0;
X
X if (setjmp(lab)==0)
X for(longpower=0; newlong>maxlong; longpower++) {
X maxlong=newlong;
X newlong=newlong*2+1;
X }
X
X if (setjmp(lab)!=0) { printf("\nUnexpected under/overflow\n"); exit(1); }
X
X printf("/\* maxlong=%ld (=2**%d-1) *\/\n", maxlong, longpower);
X
X/****** Pointers ********************************************************/
X printf("/\* pointers=%d bits%s *\/\n", sizeof(p)*bits,
X sizeof(p)>sizeof(int)?" BEWARE! larger than int!":"");
X
X/****** Base and size of mantissa ***************************************/
X a=1.0;
X do { a=Dsum(a, a); } while (Ddiff(Ddiff(Dsum(a, 1.0), a), 1.0) == 0.0);
X b=1.0;
X do { b=Dsum(b, b); } while ((base=Ddiff(Dsum(a, b), a)) == 0.0);
X ibase=base;
X printf("/\* base=%d *\/\n", ibase);
X
X imant=0; b=1.0;
X do { imant++; b=Dmul(b, base); }
X while (Ddiff(Ddiff(Dsum(b,1.0),b),1.0) == 0.0);
X printf("/\* Significant base digits=%d *\/\n", imant);
X tendigs= ceil_log(10, b); /* the number of digits */
X
X/****** Various flavours of epsilon *************************************/
X basem1=Ddiff(base,1.0);
X if (Ddiff(Dsum(a, basem1), a) != 0.0) irnd=1;
X else irnd=0;
X
X negeps=imant+imant;
X basein=1.0/base;
X a=1.0;
X for(i=1; i<=negeps; i++) a*=basein;
X
X b=a;
X while (Ddiff(Ddiff(1.0, a), 1.0) == 0.0) {
X a*=base;
X negeps--;
X }
X negeps= -negeps;
X printf("/\* Smallest x such that 1.0-base**x != 1.0=%d *\/\n", negeps);
X
X epsneg=a;
X if ((ibase!=2) && (irnd==1)) {
X /* a=(a*(1.0+a))/(1.0+1.0); => */
X a=Ddiv(Dmul(a, Dsum(1.0, a)), Dsum(1.0, 1.0));
X /* if ((1.0-a)-1.0 != 0.0) epsneg=a; => */
X if (Ddiff(Ddiff(1.0, a), 1.0) != 0.0) epsneg=a;
X }
X printf("/\* Small x such that 1.0-x != 1.0=%g *\/\n", epsneg);
X /* it may not be the smallest */
X
X machep= -imant-imant;
X a=b;
X while (Ddiff(Dsum(1.0, a), 1.0) == 0.0) { a*=base; machep++; }
X printf("/\* Smallest x such that 1.0+base**x != 1.0=%d *\/\n", machep);
X
X eps=a;
X if ((ibase!=2) && (irnd==1)) {
X /* a=(a*(1.0+a))/(1.0+1.0); => */
X a=Ddiv(Dmul(a, Dsum(1.0, a)), Dsum(1.0, 1.0));
X /* if ((1.0+a)-1.0 != 0.0) eps=a; => */
X if (Ddiff(Dsum(1.0, a), 1.0) != 0.0) eps=a;
X }
X printf("/\* Smallest x such that 1.0+x != 1.0=%g *\/\n", eps);
X
X/****** Round or chop ***************************************************/
X if (irnd == 1) { printf("/\* Arithmetic rounds *\/\n"); }
X else {
X printf("/\* Arithmetic chops");
X if (Ddiff(Dmul(Dsum(1.0,eps),1.0),1.0) != 0.0) {
X printf(" but uses guard digits");
X }
X printf(" *\/\n");
X }
X
X/****** Size of and minimum normalised exponent ****************************/
X y=0; i=0; k=1; z=basein; z1=(1.0+eps)/base;
X
X /* Coarse search for the largest power of two */
X if (setjmp(lab)==0) /* in case of underflow trap */
X do {
X y=z; y1=z1;
X z=Dmul(y,y); z1=Dmul(z1, y);
X a=Dmul(z,1.0);
X z2=Ddiv(z1,y);
X if (z2 != y1) break;
X if ((Dsum(a,a) == 0.0) || (absval(z) >= y)) break;
X i++;
X k+=k;
X } while(1);
X
X if (ibase != 10) {
X iexp=i+1; /* for the sign */
X mx=k+k;
X } else {
X iexp=2;
X iz=ibase;
X while (k >= iz) { iz*=ibase; iexp++; }
X mx=iz+iz-1;
X }
X
X /* Fine tune starting with y and y1 */
X if (setjmp(lab)==0) /* in case of underflow trap */
X do {
X xmin=y; z1=y1;
X y=Ddiv(y,base); y1=Ddiv(y1,base);
X a=Dmul(y,1.0);
X z2=Dmul(y1,base);
X if (z2 != z1) break;
X if ((Dsum(a,a) == 0.0) || (absval(y) >= xmin)) break;
X k++;
X } while (1);
X
X if (setjmp(lab)!=0) { printf("Unexpected over/underflow\n"); exit(1); }
X
X minexp= (-k)+1;
X
X if ((mx <= k+k-3) && (ibase != 10)) { mx+=mx; iexp+=1; }
X printf("/\* Number of bits used for exponent=%d *\/\n", iexp);
X printf("/\* Minimum normalised exponent=%d *\/\n", minexp);
X printf("/\* Minimum normalised positive number=%g *\/\n", xmin);
X
X/****** Minimum exponent ***************************************************/
X if (setjmp(lab)==0) /* in case of underflow trap */
X do {
X xminner=y;
X y=Ddiv(y,base);
X a=Dmul(y,1.0);
X if ((Dsum(a,a) == 0.0) || (absval(y) >= xminner)) break;
X } while (1);
X
X if (setjmp(lab)!=0) { printf("Unexpected over/underflow\n"); exit(1); }
X
X if (xminner != 0.0 && xminner != xmin) {
X printf("/\* The smallest numbers are not kept normalised *\/\n");
X printf("/\* Smallest unnormalised positive number=%g *\/\n",
X xminner);
X }
X
X/****** Maximum exponent ***************************************************/
X maxexp=2; xmax=1.0; newxmax=base+1.0;
X if (setjmp(lab) == 0) {
X while (xmax<newxmax) {
X xmax=newxmax;
X newxmax=Dmul(newxmax, base);
X if (Ddiv(newxmax, base) != xmax) break; /* ieee infinity */
X maxexp++;
X }
X }
X if (setjmp(lab)!=0) { printf("Unexpected over/underflow\n"); exit(1); }
X
X printf("/\* Maximum exponent=%d *\/\n", maxexp);
X
X/****** Largest and smallest numbers ************************************/
X xmax=Ddiff(1.0, epsneg);
X if (Dmul(xmax,1.0) != xmax) xmax=Ddiff(1.0, Dmul(base,epsneg));
X for (i=1; i<=maxexp; i++) xmax=Dmul(xmax, base);
X printf("/\* Maximum number=%g *\/\n", xmax);
X
X/****** Hidden bit + sanity check ***************************************/
X if (ibase != 10) {
X mantbits=floor_log(2, (double)ibase)*imant;
X if (mantbits+iexp+1 == sizeof(double)*bits+1) {
X printf("/\* Double arithmetic uses a hidden bit *\/\n");
X } else if (mantbits+iexp+1 == sizeof(double)*bits) {
X printf("/\* Double arithmetic doesn't use a hidden bit *\/\n");
X } else {
X printf("/\* Something fishy here! %s %s *\/\n",
X "Exponent size + mantissa size doesn't match",
X "with the size of a double.");
X }
X }
X
X/****** The point of it all: ********************************************/
X printf("\n/\* Numeric package constants *\/\n");
X
X tenlogBASE= floor_log(10, (double)maxlong)/2;
X BASE=1; for(i=1; i<=tenlogBASE; i++) BASE*=10;
X
X BIG= power(ibase, imant)-1.0;
X MAXNUMDIG= tendigs;
X Maxreal= xmax;
X Maxexpo= floor_log(2, (double)ibase)*maxexp;
X Minexpo= floor_log(2, (double)ibase)*minexp;
X DBLBITS= floor_log(2, (double)ibase)*imant;
X LONGBITS= longpower;
X
X printf("#define Maxintlet %d /\* Maximum short *\/\n", maxshort);
X printf("#define Maxint %d /\* Maximum int *\/\n", maxint);
X
X if (2*intpower + 1 <= longpower) {
X printf("typedef int digit;\n");
X maxdigit= maxint;
X }
X else {
X printf("typedef short digit;\n");
X maxdigit= maxshort;
X }
X printf("typedef long twodigit;\n");
X
X printf("\/* BASE must be a power of ten, BASE**2 must fit in a twodigit *\/\n");
X printf("\/* and -2*BASE as well as BASE*2 must fit in a digit *\/\n");
X
X printf("#define BASE %d\n", BASE);
X if (((double)BASE)*BASE > maxlong || ((double)BASE)+BASE > maxdigit) {
X printf("*** BASE value wrong\n");
X exit(1);
X }
X printf("#define tenlogBASE %d /\* = log10(BASE) *\/\n", tenlogBASE);
X
X printf("#define BIG %1.1f /\* Maximum integral double *\/\n", BIG);
X printf("#define MAXNUMDIG %d /\* The number of decimal digits in BIG *\/\n",
X MAXNUMDIG);
X printf("#define MINNUMDIG 6 /\* Don't change: this is here for consistency *\/\n");
X
X printf("#define Maxreal %e /\* Maximum double *\/\n", Maxreal);
X printf("#define Maxexpo %d /\* Maximum value such that 2**Maxexpo<=Maxreal *\/\n",
X Maxexpo);
X printf("#define Minexpo (%d) /\* Minimum value such that -2**Minexpo>=Minreal *\/\n",
X Minexpo);
X printf("#define DBLBITS %d /\* The number of bits in the fraction of a double *\/\n",
X DBLBITS);
X
X printf("#define LONGBITS %d /\* The number of bits in a long *\/\n",
X LONGBITS);
X printf("#define TWOTO_DBLBITSMIN1 %1.1f /\* 2**(DBLBITS-1) *\/\n",
X power(2, DBLBITS-1));
X printf("#define TWOTO_LONGBITS %1.1f /\* 2**LONGBITS *\/\n",
X power(2, LONGBITS));
X printf("#define RNDM_LIMIT %1.1f /\* save limit for choice *\/\n",
X power(2, (DBLBITS < 66 ? DBLBITS-3 : 63)));
X
X#ifdef MEMSIZE
X/* An extra goody: the approximate amount of data-space */
X/* Put here because it is likely to be slower then the rest */
X
X /*Allocate blocks of 1000 until no more available*/
X /*Don't be tempted to change this to 1024: */
X /*we don't know how much header information there is*/
X
X for(count=0; (p=(int *)malloc(1000))!=0; count++) { }
X
X printf("\n/\* Memory~= %d000 *\/\n", count);
X#endif /*MEMSIZE*/
X
X /* Aligning ABC values */
X
X printf("\n");
X nfiller= (unsigned)
X ((sizeof(value)) - ((sizeof(header)) + (sizeof(char **))));
X printf("#define HEADER literal type; reftype refcnt; intlet len");
X if (nfiller > 0)
X printf("; char filler[%u]", nfiller);
X printf("\n");
X printf("#define FILLER");
X if (nfiller > 0) {
X printf(" {");
X for (i= 1; i < nfiller; i++) {
X printf("0, ");
X }
X printf("0},");
X }
X printf("\n");
X
X exit(0);
X}
END_OF_FILE
if test 12184 -ne `wc -c <'abc/mkconfig.c'`; then
echo shar: \"'abc/mkconfig.c'\" unpacked with wrong size!
fi
# end of 'abc/mkconfig.c'
fi
echo shar: End of archive 13 \(of 25\).
cp /dev/null ark13isdone
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