home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Usenet 1994 October
/
usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso
/
unix
/
volume23
/
abc
/
part20
< prev
next >
Wrap
Text File
|
1991-01-08
|
56KB
|
2,385 lines
Subject: v23i099: ABC interactive programming environment, Part20/25
Newsgroups: comp.sources.unix
Approved: rsalz@uunet.UU.NET
X-Checksum-Snefru: 5ec2aeb9 9f828266 4f0d2de8 f003a395
Submitted-by: Steven Pemberton <steven@cwi.nl>
Posting-number: Volume 23, Issue 99
Archive-name: abc/part20
#! /bin/sh
# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to comp-sources-unix@uunet.uu.net if you want that tool.
# Contents: abc/bed/e1erro.c abc/bed/e1eval.c abc/bed/e1line.c
# abc/bint1/i1nur.c abc/bint3/i3fil.c abc/bio/i4fil.c
# abc/boot/Makefile abc/ihdrs/i1num.h abc/keys/keyhlp.c
# abc/stc/i2tcu.c abc/unix/u1file.c
# Wrapped by rsalz@litchi.bbn.com on Mon Dec 17 13:28:18 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 20 (of 25)."'
if test -f 'abc/bed/e1erro.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1erro.c'\"
else
echo shar: Extracting \"'abc/bed/e1erro.c'\" \(4638 characters\)
sed "s/^X//" >'abc/bed/e1erro.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Handle error messages.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "feat.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "erro.h"
X#include "node.h"
X
Xextern bool hushbaby;
X
Xstring querepr();
X
Xextern int winheight; /* From scrn.c */
Xextern int winstart; /* From scrn.c */
Xextern int llength; /* From scrn.c */
X
X#define SOBIT 0200 /* Interface with wind.c */
X
X#define MAXMSG 1000
X#define MAXBUF 50
Xstatic char *msgbuffer;
Xstatic bool ringbell;
Xstatic int priority;
X
X#define M_RECORDING MESS(6400, "Recording")
X#define M_COPYBUF MESS(6401, "Copy buffer")
X
Xstatic char *mrecbuf;
Xstatic char *mcopybuf;
X
X/*
X * Status line. A combination of scroll bar, error message etc.
X * Put the message on the screen and clear the buffers for next time.
X * If there is no message, show status and copy buffer and recording mode.
X */
X
XVisible Procedure
Xstsline(totlines, topline, scrlines, copybuffer, recording)
X int totlines;
X int topline;
X int scrlines;
X value copybuffer;
X bool recording;
X{
X register string bp;
X
X if (ringbell && !hushbaby)
X trmbell();
X if (msgbuffer[0]) {
X msgbuffer[llength-1] = '\0'; /* Truncate */
X if (ringbell) {
X for (bp = msgbuffer; *bp; ++bp)
X *bp |= SOBIT;
X }
X }
X else {
X bp = msgbuffer;
X#ifdef SCROLLBAR
X bp += addscrollbar(totlines, topline, scrlines);
X#endif /* SCROLLBAR */
X if (recording) {
X if (!mrecbuf[0])
X strcpy(mrecbuf, getmess(M_RECORDING));
X sprintf(bp, "[%s] ", mrecbuf);
X while (*bp)
X ++bp;
X }
X if (copybuffer) {
X if (!mcopybuf[0])
X strcpy(mcopybuf, getmess(M_COPYBUF));
X#ifdef SHOWBUF
X sprintf(bp, "[%s: %.80s]", mcopybuf, querepr(copybuffer));
X while (*bp)
X ++bp;
X if (bp >= msgbuffer+80)
X strcpy(msgbuffer+75, "...]");
X#else /* !SHOWBUF */
X sprintf(bp, "[%s]", mcopybuf);
X#endif /* !SHOWBUF */
X }
X }
X trmputdata(winheight, winheight, 0, msgbuffer);
X msgbuffer[0] = '\0';
X priority = 0;
X ringbell = No;
X}
X
X#ifdef SCROLLBAR
X
X/*
X * Paint a beautiful scroll bar so the user can see about what part of the
X * unit is visible on the screen (considering logical lines).
X */
X
XHidden int
Xaddscrollbar(totlines, topline, scrlines)
X int totlines;
X int topline;
X int scrlines;
X{
X int endline;
X register int i;
X
X if (winstart > 0 || scrlines > totlines)
X return 0; /* Nothing outside screen */
X if (totlines <= 0)
X totlines = 1; /* Don't want to divide by 0 */
X topline = topline*winheight / totlines;
X endline = topline + (scrlines*winheight + totlines-1) / totlines;
X if (endline > winheight)
X endline = winheight;
X if (topline >= endline)
X topline = endline-1;
X for (i = 0; i < topline; ++i)
X msgbuffer[i] = '-';
X for (; i < endline; ++i)
X msgbuffer[i] = '#';
X for (; i < winheight; ++i)
X msgbuffer[i] = '-';
X msgbuffer[i++] = ' ';
X msgbuffer[i] = '\0';
X return i;
X}
X
X#endif /* SCROLLBAR */
X
X/*
X * Issue an error message. These have highest priority.
X * Once an error message is in the buffer, further error messages are ignored
X * until it has been displayed.
X */
X
XHidden Procedure
Xederr1(s)
X string s;
X{
X ringbell = Yes;
X if (s && priority < 3) {
X priority = 3;
X strcpy(msgbuffer, s);
X }
X}
X
XVisible Procedure
Xederr(m)
X int m;
X{
X if (m == 0) ringbell= Yes;
X else ederr1(getmess(m));
X}
X
XVisible Procedure
XederrS(m, s)
X int m;
X string s;
X{
X sprintf(messbuf, getmess(m), s);
X ederr1(messbuf);
X}
X
XVisible Procedure
XederrC(m, c)
X int m;
X char c;
X{
X sprintf(messbuf, getmess(m), c);
X ederr1(messbuf);
X}
X
X/*
X * Issue an informative message. These have medium priority.
X * Unlike error messages, the last such message is displayed.
X */
X
XVisible Procedure
Xedmessage(s)
X string s;
X{
X if (s && priority <= 2) {
X priority = 2;
X strcpy(msgbuffer, s);
X }
X}
X
X
X/*
X * Issue a debugging message. These have lowest priority and
X * are not shown to ordinary users.
X */
X
X#ifndef NDEBUG
X
X/* VARARGS 1 */
XVisible Procedure
Xdebug(fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
X string fmt;
X{
X if (fmt && priority <= 1) {
X priority = 1;
X sprintf(msgbuffer,
X fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10);
X }
X}
X
X#endif /* NDEBUG */
X
X/*
X * Dump any error message still remaining to console or stderr.
X */
X
XVisible Procedure
Xenderro()
X{
X if (!msgbuffer)
X return;
X if (msgbuffer[0])
X putSstr(errfile, "%s\n", msgbuffer);
X msgbuffer[0] = '\0';
X priority = 0;
X ringbell = No;
X}
X
XVisible Procedure init_erro() {
X msgbuffer= (char*) getmem(MAXMSG);
X msgbuffer[0]= '\0';
X mrecbuf= (char*) getmem(MAXBUF);
X mrecbuf[0]= '\0';
X mcopybuf= (char*) getmem(MAXBUF);
X mcopybuf[0]= '\0';
X}
X
XVisible Procedure end_erro() {
X freemem((ptr) msgbuffer);
X freemem((ptr) mrecbuf);
X freemem((ptr) mcopybuf);
X}
END_OF_FILE
if test 4638 -ne `wc -c <'abc/bed/e1erro.c'`; then
echo shar: \"'abc/bed/e1erro.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1erro.c'
fi
if test -f 'abc/bed/e1eval.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1eval.c'\"
else
echo shar: Extracting \"'abc/bed/e1eval.c'\" \(4245 characters\)
sed "s/^X//" >'abc/bed/e1eval.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Width attribute evaluation.
X */
X
X#include "b.h"
X#include "b0lan.h"
X#include "bedi.h"
X#include "etex.h"
X#include "node.h"
X#include "gram.h"
X
X
X/*
X * The following convention is used throughout the editor to indicate
X * the sizes of objects.
X * - A zero or positive `width' value means the object contains no
X * linefeeds. The width is counted in characters.
X * - A negative `width' means the object (or its children) contains
X * at leasty one linefeed (return is treated as a linefeed here).
X * The number of linefeeds is -width.
X * There is no indication whether the object fits on that number of
X * physical lines, as logical lines may have arbitrary length.
X *
X * For coordinates the following convention is used.
X * (Note that, in accordance to the convention in curses(3), the
X * `y' coordinate always precedes the `x' coorxdinate.)
X * - `Y' is the line number, counted from the beginning of the unit.
X * These are logical lines rather than physical lines.
X * The first line has line number 0.
X * - `X' is the column number. The first column is 0. For x < 0,
X * see the important notice below.
X * - `Level' is the indentation level, indicating where a new line
X * would start if inserted at the current position.
X * The initial `x' position of such a line is `level*INDENTSIZE'.
X *
X * ***** IMPORTANT NOTICE *****
X * A special case is x = -1. This means that the current x position is
X * unknown. Further output on the same line is suppressed, until a
X * linefeed is encountered. This feature is necessary because while
X * calculating coordinates, when an object has width < 0, only the y
X * coordinate of the end of that object is known. In this case, the
X * next non-empty object MUST START WITH A LINEFEED, or it will not
X * be visible on the screen (in practice, a space is sometimes present
X * in the parse tree which is not shown then).
X */
X
X
X/*
X * Compute the (y, x) coordinates and indent level just before
X * the beginning of the j'th child, if the current node starts
X * at the initial values of (y, x) and level.
X */
X
XVisible Procedure
Xevalcoord(n, jch, py, px, plevel)
X register node n;
X register int jch;
X int *py;
X int *px;
X int *plevel;
X{
X node nn;
X register int i;
X register string *rp = noderepr(n);
X register int k;
X register int y = 0;
X int x = *px;
X int level = *plevel;
X int nch;
X
X nch = Is_etext(n) ? 0 : nchildren(n);
X if (jch > nch)
X jch = nch+1;
X for (i = 0; i < jch; ++i) {
X if (i) {
X nn = child(n, i);
X k = nodewidth(nn);
X if (k < 0) {
X y += -k;
X x = k;
X }
X else if (x >= 0)
X x += k;
X }
X k = Fwidth(rp[i]);
X if (k < 0) {
X y += -k;
X /* The \r in the next line is actually a
X \n on the Mac. I forgot what \r was meant
X for; believe it isn't used. */
X x = /*rp[i][0] == '\r' ? 0 :*/ INDENTSIZE*level;
X x += strlen(rp[i]) - 1;
X }
X else {
X if (x >= 0)
X x += k;
X if (rp[i]) {
X if (rp[i][k] == '\t')
X ++level;
X else if (rp[i][k] == '\b')
X --level;
X }
X }
X }
X
X *py += y;
X *px = x;
X *plevel = level;
X}
X
X
X/*
X * Yield the width of a piece of fixed text as found in a node's repr,
X * excluding \b or \t. If \n or \r is found, -1 is returned.
X * It assumes that \n or \r only occur as first
X * character, and \b or \t only as last.
X */
X
XVisible int
Xfwidth(str)
X register string str;
X{
X register int c;
X register int n = 0;
X
X if (!str)
X return 0;
X c = str[0];
X if (c == '\r' || c == '\n')
X return -1;
X for (; c; c = *++str)
X ++n;
X if (n > 0) {
X c = str[-1];
X if (c == '\t' || c == '\b')
X --n;
X }
X return n;
X}
X
X
X/*
X * Evaluate the width of node n, assuming the widths of its children
X * have correctly been calculated.
X */
X
XVisible int
Xevalwidth(n)
X register node n;
X{
X register int w;
X register int i;
X register string *rp;
X register int y = 0;
X register int x = 0;
X register int nch;
X register node nn;
X
X rp = noderepr(n);
X nch = Is_etext(n) ? 0 : nchildren(n);
X for (i = 0; i <= nch; ++i) {
X if (i) {
X nn = child(n, i);
X w = nodewidth(nn);
X if (w < 0) {
X y += -w;
X x = w;
X }
X else
X x += w;
X }
X w = Fwidth(rp[i]);
X if (w < 0) {
X y += -w;
X x = 0;
X }
X else
X x += w;
X }
X if (y > 0)
X return -y;
X return x;
X}
END_OF_FILE
if test 4245 -ne `wc -c <'abc/bed/e1eval.c'`; then
echo shar: \"'abc/bed/e1eval.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1eval.c'
fi
if test -f 'abc/bed/e1line.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1line.c'\"
else
echo shar: Extracting \"'abc/bed/e1line.c'\" \(4243 characters\)
sed "s/^X//" >'abc/bed/e1line.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Routines for treating the parse tree as a sequence of lines.
X *
X * WARNING: The routines in this file (and many others!) assume that a
X * `newline' can only occur in the zero'th representation string of a node
X * (i.e., rp[0]).
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "bobj.h"
X#include "node.h"
X#include "gram.h"
X#include "supr.h"
X
X
X/*
X * Compute equality of subtrees, based on common descent.
X * Strings are not checked for characterwise equality, but must
X * be the same pointer; other nodes must have the same symbol and
X * their children must be equal in this sense (equal pointers are
X * always used as a shortcut).
X *
X * (Used by screen update algorithm only.)
X */
X
XVisible bool
Xeqlines(n1, n2)
X node n1;
X node n2;
X{
X register node nn1;
X register node nn2;
X register int w1;
X register int w2;
X register int nch;
X register int i;
X
X if (n1 == n2)
X return Yes;
X if (!Is_Node(n1) || !Is_Node(n2))
X return No;
X if (symbol(n1) != symbol(n2))
X return No;
X nch = nchildren(n1);
X Assert(nch == nchildren(n2));
X for (i = 1; i <= nch; ++i) {
X nn1 = child(n1, i);
X nn2 = child(n2, i);
X w1 = nodewidth(nn1);
X w2 = nodewidth(nn2);
X if (w1 >= 0 && w2 >= 0) {
X if (!eqlines(nn1, nn2))
X return No;
X }
X else {
X if (nn1 == nn2)
X return Yes;
X if (fwidth(noderepr(nn1)[0]) < 0 || fwidth(noderepr(nn2)[0]) < 0)
X return linelen(n1) == linelen(n2);
X return eqlines(nn1, nn2);
X }
X }
X return Yes;
X}
X
X
X/*
X * Compute the length of the line beginning at the current node.
X */
X
XVisible int
Xlinelen(n)
X node n;
X{
X register node nn;
X register string *rp = noderepr(n);
X register int w;
X register int nch = nchildren(n);
X register int i;
X register int len = fwidth(rp[0]);
X
X if (len < 0)
X len = 0;
X for (i = 1; i <= nch; ++i) {
X nn = child(n, i);
X w = nodewidth(nn);
X if (w >= 0)
X len += w;
X else {
X n = nn;
X i = 0;
X nch = nchildren(n);
X rp = noderepr(n);
X }
X w = Fwidth(rp[i]);
X if (w < 0)
X break;
X len += w;
X }
X return len;
X}
X
X
X/*
X * Move the focus to the next line.
X * NB: This is a building block for use in the 'show' module;
X * it cannot set ep->mode or call higher() properly!
X */
X
XVisible bool
Xnextline(pp)
X register path *pp;
X{
X register node n;
X register node nn;
X register int w;
X register int nch;
X register int i = 0;
X
X for (;;) {
X n = tree(*pp);
X if (nodewidth(n) < 0) {
X nch = nchildren(n);
X while (++i <= nch) {
X nn = child(n, i);
X w = nodewidth(nn);
X if (w < 0) {
X if (!downi(pp, i)) Abort();
X n = tree(*pp);
X if (fwidth(noderepr(n)[0]) < 0)
X return Yes;
X nch = nchildren(n);
X i = 0;
X }
X }
X }
X /* Must go upward in the tree */
X i = ichild(*pp);
X if (!up(pp))
X return No;
X }
X}
X
X
X/*
X * Compute the current line number. If the current node begins with
X * a `newline', add one because the first character is actually
X * on the next line.
X */
X
XVisible int
Xlineno(ep)
X register environ *ep;
X{
X register int y;
X
X y = -focoffset(ep);
X if (y < 0)
X y = 0;
X if (focchar(ep) == '\n')
X ++y;
X return y + Ycoord(ep->focus);
X}
X
X
X/*
X * Similarly, compute the current column number.
X * (Hope the abovementioned trick isn't necessary.)
X */
X
XVisible int
Xcolno(ep)
X environ *ep;
X{
X int x= focoffset(ep);
X
X if (x < 0)
X x= 0; /* In fact, give up */
X return x + Xcoord(ep->focus);
X}
X
X
X/*
X * Make the focus exactly one line wide (if at all possible).
X */
X
XVisible Procedure
Xoneline(ep)
X register environ *ep;
X{
X register node n;
X node nn;
X register string *rp;
X register int s1;
X register int s2;
X register int len;
X int ich;
X int nch;
X
X ich = 1;
X while (nodewidth(tree(ep->focus)) >= 0) {
X ich = ichild(ep->focus);
X if (!up(&ep->focus)) {
X ep->mode = WHOLE;
X higher(ep);
X return;
X }
X }
X higher(ep);
X n = tree(ep->focus);
X nch = nchildren(n);
X rp = noderepr(n);
X for (s1 = 2*ich-1; s1 >= 1; --s1) {
X if (s1&1)
X len = fwidth(rp[s1/2]);
X else {
X nn = child(n, s1/2);
X len = nodewidth(nn);
X }
X if (len < 0)
X break;
X }
X for (s2 = 2*ich+1; s2 <= 2*nch+1; ++s2) {
X if (s2&1)
X len = fwidth(rp[s2/2]);
X else {
X nn = child(n, s2/2);
X len = nodewidth(nn);
X }
X if (len < 0)
X break;
X }
X ep->mode = SUBSET;
X ep->s1 = s1+1;
X ep->s2 = s2-1;
X}
END_OF_FILE
if test 4243 -ne `wc -c <'abc/bed/e1line.c'`; then
echo shar: \"'abc/bed/e1line.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1line.c'
fi
if test -f 'abc/bint1/i1nur.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint1/i1nur.c'\"
else
echo shar: Extracting \"'abc/bint1/i1nur.c'\" \(5345 characters\)
sed "s/^X//" >'abc/bint1/i1nur.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Rational 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/* Length calculations used for fraction sizes: */
X
X#define Maxlen(u, v) \
X (Roundsize(u) > Roundsize(v) ? Roundsize(u) : Roundsize(v))
X#define Sumlen(u, v) (Roundsize(u)+Roundsize(v))
X#define Difflen(u, v) (Roundsize(u)-Roundsize(v))
X
X/* To shut off lint and other warnings: */
X#undef Copy
X#define Copy(x) ((integer)copy((value)(x)))
X
X/* Globally used constants */
X
Xrational rat_half;
X
X/* Make a normalized rational from two integers */
X
XVisible rational mk_rat(x, y, len, simplify)
X integer x, y; int len; bool simplify; {
X rational a;
X integer u,v;
X
X if (y == int_0) {
X if (interrupted)
X return rat_zero();
X syserr(MESS(1200, "mk_rat(x, y) with y=0"));
X }
X
X if (x == int_0 && len <= 0) return rat_zero();
X
X if (Msd(y) < 0) { /* interchange signs */
X u = int_neg(x);
X v = int_neg(y);
X } else {
X u = Copy(x);
X v = Copy(y);
X }
X
X a = (rational) grab_rat(len);
X
X if (u == int_0 || v == int_1) {
X /* No simplification possible */
X Numerator(a) = Copy(u);
X Denominator(a) = int_1;
X }
X else if (!simplify) {
X Numerator(a) = Copy(u);
X Denominator(a) = Copy(v);
X }
X else {
X integer g, abs_u;
X
X if (Msd(u) < 0) abs_u = int_neg(u);
X else abs_u = Copy(u);
X g = int_gcd(abs_u, v);
X Release(abs_u);
X
X if (g != int_1) {
X Numerator(a) = int_quot(u, g);
X Denominator(a) = int_quot(v, g);
X } else {
X Numerator(a) = Copy(u);
X Denominator(a) = Copy(v);
X }
X Release(g);
X }
X
X Release(u); Release(v);
X
X return a;
X}
X
X
X/* Arithmetic on rational numbers */
X
X/* Shorthands: */
X#define N(u) Numerator(u)
X#define D(u) Denominator(u)
X
XVisible rational rat_sum(u, v) register rational u, v; {
X integer t1, t2, t3, t4;
X rational a;
X
X t2= int_prod(N(u), D(v));
X t3= int_prod(N(v), D(u));
X t1= int_sum(t2, t3);
X t4= int_prod(D(u), D(v));
X a= mk_rat(t1, t4, Maxlen(u, v), Yes);
X Release(t1); Release(t2);
X Release(t3); Release(t4);
X
X return a;
X}
X
X
XVisible rational rat_diff(u, v) register rational u, v; {
X integer t1, t2, t3, t4;
X rational a;
X
X t2= int_prod(N(u), D(v));
X t3= int_prod(N(v), D(u));
X t1= int_diff(t2, t3);
X t4= int_prod(D(u), D(v));
X a= mk_rat(t1, t4, Maxlen(u, v), Yes);
X Release(t1); Release(t2);
X Release(t3); Release(t4);
X
X return a;
X}
X
X
XVisible rational rat_prod(u, v) register rational u, v; {
X integer t1, t2;
X rational a;
X
X t1= int_prod(N(u), N(v));
X t2= int_prod(D(u), D(v));
X a= mk_rat(t1, t2, Sumlen(u, v), Yes);
X Release(t1); Release(t2);
X
X return a;
X}
X
X
XVisible rational rat_quot(u, v) register rational u, v; {
X integer t1, t2;
X rational a;
X
X if (N(v) == int_0) {
X interr(ZERO_DIVIDE);
X return rat_zero();
X }
X
X t1= int_prod(N(u), D(v));
X t2= int_prod(D(u), N(v));
X a= mk_rat(t1, t2, Difflen(u, v), Yes);
X Release(t1); Release(t2);
X
X return a;
X}
X
X
XVisible rational rat_neg(u) register rational u; {
X register rational a;
X
X /* Avoid a real subtraction from zero */
X
X if (N(u) == int_0) return (rational) Copy(u);
X
X a = (rational) grab_rat(0);
X N(a) = int_neg(N(u));
X D(a) = Copy(D(u));
X Length(a) = Length(u);
X
X return a;
X}
X
X/* Rational number to the integral power */
X
XVisible rational rat_power(a, n) rational a; integer n; {
X integer u, v, tu, tv, temp;
X
X if (n == int_0) return mk_rat(int_1, int_1, 0, Yes);
X
X if (Msd(n) < 0) {
X if (N(a) == int_0) {
X interr(NEG_POWER);
X return (rational) Copy(a);
X }
X if (Msd(N(a)) < 0) {
X u= int_neg(D(a));
X v = int_neg(N(a));
X }
X else {
X u = Copy(D(a));
X v = Copy(N(a));
X }
X n = int_neg(n);
X } else {
X if (N(a) == int_0) return (rational) Copy(a);
X /* To avoid necessary simplification later on */
X u = Copy(N(a));
X v = Copy(D(a));
X n = Copy(n);
X }
X
X tu = int_1;
X tv = int_1;
X
X while (n != int_0 && !Interrupted()) {
X if (Odd(Lsd(n))) {
X if (u != int_1) {
X temp = tu;
X tu = int_prod(u, tu);
X Release(temp);
X }
X if (v != int_1) {
X temp = tv;
X tv = int_prod(v, tv);
X Release(temp);
X }
X if (n == int_1)
X break; /* Avoid useless last squaring */
X }
X
X /* Square u, v */
X
X if (u != int_1) {
X temp = u;
X u = int_prod(u, u);
X Release(temp);
X }
X if (v != int_1) {
X temp = v;
X v = int_prod(v, v);
X Release(temp);
X }
X
X n = int_half(n);
X } /* while (n!=0) */
X
X Release(n);
X Release(u);
X Release(v);
X a = mk_rat(tu, tv, 0, No);
X Release(tu); Release(tv);
X
X return a;
X}
X
X
X/* Compare two rational numbers */
X
XVisible relation rat_comp(u, v) register rational u, v; {
X int sd, su, sv;
X integer nu, nv;
X
X /* 1. Compare pointers */
X if (u == v || N(u) == N(v) && D(u) == D(v)) return 0;
X
X /* 2. Either zero? */
X if (N(u) == int_0) return int_comp(int_0, N(v));
X if (N(v) == int_0) return int_comp(N(u), int_0);
X
X /* 3. Compare signs */
X su = Msd(N(u));
X sv = Msd(N(v));
X su = (su>0) - (su<0);
X sv = (sv>0) - (sv<0);
X if (su != sv) return su > sv ? 1 : -1;
X
X /* 4. Compute numerator of difference and return sign */
X nu= int_prod(N(u), D(v));
X nv= int_prod(N(v), D(u));
X sd= int_comp(nu, nv);
X Release(nu); Release(nv);
X return sd;
X}
X
XVisible rational rat_zero() {
X rational r= (rational) grab_rat(0);
X N(r) = int_0;
X D(r) = int_1;
X return r;
X}
X
XVisible Procedure rat_init() {
X rat_half = (rational) grab_rat(0);
X N(rat_half) = int_1;
X D(rat_half) = int_2;
X}
X
XVisible Procedure endrat() {
X Release(rat_half);
X}
END_OF_FILE
if test 5345 -ne `wc -c <'abc/bint1/i1nur.c'`; then
echo shar: \"'abc/bint1/i1nur.c'\" unpacked with wrong size!
fi
# end of 'abc/bint1/i1nur.c'
fi
if test -f 'abc/bint3/i3fil.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3fil.c'\"
else
echo shar: Extracting \"'abc/bint3/i3fil.c'\" \(4560 characters\)
sed "s/^X//" >'abc/bint3/i3fil.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Facilities supplied by the file system */
X
X#include "b.h"
X#include "bmem.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i2nod.h"
X#include "i2par.h"
X#include "i3scr.h"
X#include "i3sou.h"
X
XVisible Procedure f_rename(fname, nfname) value fname, nfname; {
X char *f1, f2[100];
X
X strcpy(f2, strval(nfname));
X unlink(f2);
X f1= strval(fname);
X VOID rename(f1, f2);
X /* what if it fails??? */
X}
X
XVisible Procedure f_delete(fname) value fname; {
X unlink(strval(fname));
X}
X
XVisible unsigned f_size(file) FILE *file; {
X long s, ftell();
X fseek(file, 0l, 2);
X s= ftell(file);
X fseek(file, 0l, 0); /* rewind */
X return s;
X}
X
XVisible Procedure f_close(ofile) FILE *ofile; {
X bool ok= fflush(ofile) != EOF;
X if (fclose(ofile) == EOF || !ok)
X interr(MESS(3700, "write error (disk full?)"));
X}
X
XVisible bool f_interactive(file) FILE *file; {
X return isatty(fileno(file));
X}
X
X/* f_getline() returns a line from a file with the newline character */
X
X#define LINESIZE 200
X
XVisible char *f_getline(file) FILE *file; {
X char line[LINESIZE];
X char *pline= NULL;
X
X while (fgets(line, LINESIZE, file) != NULL) {
X if (pline == NULL)
X pline= (char *) savestr(line);
X else {
X int len= strlen(pline) + strlen(line) + 1;
X regetmem(&pline, (unsigned) len);
X strcat(pline, line);
X }
X if (strchr(pline, '\n') != NULL)
X return pline;
X }
X if (pline != NULL)
X freestr(pline);
X return NULL;
X}
X
XHidden struct class { literal type; char *suffix; };
X
XHidden struct class classes[]= {
X {Cmd, Cmd_ext},
X {Zfd, Zfd_ext},
X {Mfd, Mfd_ext},
X {Dfd, Dfd_ext},
X {Zpd, Zpd_ext},
X {Mpd, Mpd_ext},
X {Dpd, Dpd_ext},
X {Tar, Cts_ext},
X {Wsp, Wsp_ext}
X};
X
X#define NCLASSES (sizeof classes / sizeof classes[0])
X
XHidden char *filesuffix(type) literal type; {
X register struct class *cp;
X
X for (cp= classes; cp < &classes[NCLASSES]; ++cp) {
X if (type == cp->type)
X return cp->suffix;
X }
X return "";
X}
X
X/*
X * the following constants were moved here from all os.h's
X * to use more portable filenames;
X * e.g. MSDOS conventions, since these are the most limited.
X */
X#define FNMLEN 8
X#define SUFFIXLEN 4
X
XVisible value new_fname(name, type) value name; literal type; {
X char fname[FNMLEN + SUFFIXLEN + 1];
X char *suffix= filesuffix(type);
X string sname= strval(name);
X char *sp= strchr(sname, ' ');
X intlet len= sp ? sp-sname : strlen(sname);
X /* if a command name only the first keyword */
X
X if (len > FNMLEN) len= FNMLEN;
X strncpy(fname, sname, len); fname[len]= '\0';
X strcat(fname, suffix);
X /* convert also if not MSDOS, to make abc-ws's portable: */
X conv_fname(fname, suffix);
X if (type != Wsp &&
X F_exists(fname) &&
X !fnm_extend(fname, len, suffix) &&
X !fnm_narrow(fname, len)
X )
X return Vnil;
X return mk_text(fname);
X}
X
XHidden bool fnm_extend(fname, n, suffix) char *fname, *suffix; int n; {
X /* e.g. "ABC.cmd" => "ABC1.cmd" */
X int m;
X int k= n;
X
X do {
X for (m= k-1; fname[m] == '9'; --m);
X if (isdigit(fname[m])) {
X ++fname[m];
X while (++m < k) fname[m]= '0';
X }
X else if (k >= FNMLEN) {
X /* reset */
X fname[n]= '\0';
X strcat(fname, suffix);
X return No;
X }
X else {
X fname[++m]= '1';
X while (++m <= k) fname[m]= '0';
X fname[++k]= '\0';
X strcat(fname, suffix);
X }
X }
X while (F_exists(fname));
X return Yes;
X}
X
XHidden bool fnm_narrow(fname, n) char *fname; int n; {
X /* e.g. "ABC.cmd" => "AB1.cmd" */
X int m;
X
X do {
X for (m= n-1; ; --m) {
X if (m < 1)
X return No;
X else if (!isdigit(fname[m])) {
X fname[m]= '1';
X break;
X }
X else if (fname[m] != '9') {
X ++fname[m];
X break;
X }
X else fname[m]= '0';
X }
X }
X while (F_exists(fname));
X return Yes;
X}
X
X/* Conversion of characters:
X * . uppercase to lowercase
X * . point to CONVP_SIGN
X * . double quote to CONVDQ_SIGN
X * . single quote can stay
X * the latter is as portably unspecial as possible.
X */
X
XHidden Procedure conv_fname(fname, suffix) char *fname, *suffix; {
X char *ext_point= fname + strlen(fname) - strlen(suffix);
X
X while (fname < ext_point) {
X if (isupper(*fname))
X *fname= tolower(*fname);
X else if (*fname == C_QUOTE)
X *fname= CONVDQ_SIGN;
X else if (*fname == C_POINT)
X *fname= CONVP_SIGN;
X fname++;
X }
X}
X
X/* recover location or workspace name from filename */
X
XVisible value mkabcname(name) char *name; {
X char *p;
X
X for (p= name; *p != '\0'; ++p) {
X if (Cap(*p))
X *p= tolower(*p);
X else if (*p == CONVP_SIGN)
X *p= (*(p+1) == '\0' ? '\0' : C_POINT);
X else if (*p == CONVDQ_SIGN)
X *p= C_QUOTE;
X else if (!Tagmark(p))
X *p= C_QUOTE;
X }
X return mk_text(name);
X}
END_OF_FILE
if test 4560 -ne `wc -c <'abc/bint3/i3fil.c'`; then
echo shar: \"'abc/bint3/i3fil.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3fil.c'
fi
if test -f 'abc/bio/i4fil.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bio/i4fil.c'\"
else
echo shar: Extracting \"'abc/bio/i4fil.c'\" \(4420 characters\)
sed "s/^X//" >'abc/bio/i4fil.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */
X
X#include "b.h"
X#include "bfil.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "i3sou.h"
X
X#ifdef HAS_READDIR
X#include <sys/dir.h>
X#else
X#include "dir.h"
X#endif
X
X/**************************************************************************/
X/* get_names() is used to get at the names of all ABC files/workspaces */
X/* in a given directory. */
X/* */
X/* This version of the file is supposed to work for any kind of Unix */
X/* and for MS-DOS. */
X/**************************************************************************/
X
X /* Note: it uses readdir so isn't portable to non-BSD
X Unix, unless you also port readdir and friends.
X Luckily, public-domain versions are available,
X and one should be distributed with ABC.
X It works for MS-DOS because I have ported readdir
X to MS-DOS, too. Guido. */
X
XVisible value get_names(path, isabc) char *path; bool (*isabc)(); {
X DIR *dp;
X struct direct *dirp;
X value v;
X value name;
X
X dp= opendir(path);
X if (dp == (DIR *) NULL)
X return Vnil;
X v= mk_elt();
X for (;;) {
X dirp= readdir(dp);
X if (dirp == (struct direct *) NULL) {
X closedir(dp);
X break;
X }
X if ((*isabc)(path, dirp->d_name)) {
X name= mk_text(dirp->d_name);
X insert(name, &v);
X release(name);
X }
X }
X return v;
X}
X
X/**************************************************************************/
X/* Is this the name of a target, a unit or something else? */
X/* */
X/* For compatibility, we recognize files starting with =, <, ", > and ', */
X/* and files ending with ".how", ".zer", ".mon", ".dya" and ".tar". */
X/* Otherwise, unit names must end in ".cmd", ".zfd", ".mfd", ".dfd", */
X/* ".zpd", ".mpd" or ".dpd", */
X/* and target names must end in ".cts" (all ignoring case). */
X/**************************************************************************/
X
X#define DumClass '\0'
X
XHidden struct class { char *suffix; literal type; };
X
XHidden struct class classes[]= {
X {".cmd", Cmd},
X {".zfd", Zfd},
X {".mfd", Mfd},
X {".dfd", Dfd},
X {".zpd", Zpd},
X {".mpd", Mpd},
X {".dpd", Dpd},
X {".cts", Tar},
X
X {".CMD", Cmd},
X {".ZFD", Zfd},
X {".MFD", Mfd},
X {".DFD", Dfd},
X {".ZPD", Zpd},
X {".MPD", Mpd},
X {".DPD", Dpd},
X {".CTS", Tar},
X
X {".how", OldHow},
X {".zer", OldHow},
X {".mon", OldHow},
X {".dya", OldHow},
X {".tar", OldTar},
X
X {".HOW", OldHow},
X {".ZER", OldHow},
X {".MON", OldHow},
X {".DYA", OldHow},
X {".TAR", OldTar}
X};
X
X#define NCLASSES (sizeof classes / sizeof classes[0])
X
XHidden literal classfile(fname) value fname; {
X char *sfname, *end;
X struct class *cp;
X
X sfname= strval(fname);
X switch (sfname[0]) {
X case '\'': case '<': case '"': case '>':
X return OldHow;
X case '=':
X return OldTar;
X default:
X break;
X }
X end= sfname + strlen(sfname);
X for (cp= classes; cp < &classes[NCLASSES]; ++cp) {
X if (end-strlen(cp->suffix) >= sfname
X && strcmp(end-strlen(cp->suffix), cp->suffix) == 0)
X return cp->type;
X }
X return DumClass;
X}
X
XVisible bool abcfile(path, name) char *path, *name; {
X /* path argument needed, but not used */
X bool isfile;
X value f= mk_text(name);
X
X isfile= classfile(f) != DumClass ? Yes : No;
X release(f);
X return isfile;
X}
X
XVisible bool abcworkspace(path, name) char *path, *name; {
X struct stat statbuf;
X char *path1, *path2;
X bool isws= No;
X
X path1= makepath(path, name);
X if (stat(path1, &statbuf) == 0 &&
X ((statbuf.st_mode & S_IFMT) == S_IFDIR) &&
X (strcmp(name, CURDIR) != 0) &&
X (strcmp(name, PARENTDIR) != 0)
X ) {
X path2= makepath(path1, permfile);
X isws= F_exists(path2) ? Yes : No;
X freepath(path2);
X }
X freepath(path1);
X return isws;
X}
X
XVisible bool targetfile(fname) value fname; {
X switch (classfile(fname)) {
X case Tar: case OldTar:
X return Yes;
X default:
X return No;
X }
X}
X
XVisible bool unitfile(fname) value fname; {
X switch (classfile(fname)) {
X case Tar: case OldTar: case DumClass:
X return No;
X default:
X return Yes;
X }
X}
X
XVisible char *base_fname(fname) value fname; {
X char *sname;
X char *base;
X char *pext;
X
X sname= strval(fname);
X switch (*sname) {
X case '\'': case '<': case '"': case '>': case '=':
X ++sname;
X default:
X break;
X }
X base= savestr(sname);
X if ((pext= strrchr(base, '.')) != NULL)
X *pext= '\0';
X return base;
X}
X
XVisible bool typeclash(pname, fname) value pname, fname; {
X return classfile(fname) != Permtype(pname) ? Yes : No;
X}
END_OF_FILE
if test 4420 -ne `wc -c <'abc/bio/i4fil.c'`; then
echo shar: \"'abc/bio/i4fil.c'\" unpacked with wrong size!
fi
# end of 'abc/bio/i4fil.c'
fi
if test -f 'abc/boot/Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/boot/Makefile'\"
else
echo shar: Extracting \"'abc/boot/Makefile'\" \(4701 characters\)
sed "s/^X//" >'abc/boot/Makefile' <<'END_OF_FILE'
X# EDIT MY ANCESTOR Makefile.bsd
X# AND SAY 'make -f Makefile.bsd Makefile'
X#
X# BSD Makefile for booting grammar tables with mktable from grammar file.
X#
X
X# --- Where to install the stuff ---
X
XCFILE=../bed/e1tabl.c
XHFILE=../ehdrs/tabl.h
X
X# --- What is the C preprocessor called ---
X#
X# ../scripts/mkdep has the right CPP if Setup succeeded and your UNIX ain't BSD
X
XCPP= /bin/cc -E
X
X# --- Flags to the C compiler ---
X
XBINCL= -I../bhdrs -I../ehdrs -I../uhdrs
XDEFS= -DNDEBUG -DBSD
XCFLAGS= -O $(DEFS) $(BINCL)
XLDFLAGS=-s
XLIBS=
XGDEFS=
X
X# --- Stuff for lint ---
X
XLINT= lint
XLINTFLAGS= -abh
XLBINCL= $(BINCL)
X
X# --- Relevant files ---
X
XOBJS= main.o alloc.o read.o fill.o comp.o dump.o code.o
X
XSRCS= main.c alloc.c read.c fill.c comp.c dump.c ../bed/e1code.c
X
XHDRS= ../bhdrs/b.h main.h ../ehdrs/code.h lang.h
X
X# --- Main entries of the makefile ---
X
Xall: tabl.c.out tabl.h.out
X
Xtabl.c.out tabl.h.out: grammar mktable
X mktable -g grammar -h tabl.h -t tabl.c.out -i tabl.h.out
X
Xgrammar: grammar.abc lang.h
X $(CPP) $(GDEFS) grammar.abc 2>/dev/null | sed -e "/^$$/d" -e "/^#/d" >grammar
X
Xmktable: $(OBJS)
X $(CC) $(LDFLAGS) $(OBJS) $(LIBS) -o mktable
X
Xinstall: $(CFILE) $(HFILE)
X
X$(CFILE): tabl.c.out
X cp tabl.c.out $(CFILE)
X
X$(HFILE): tabl.h.out
X cp tabl.h.out $(HFILE)
X
Xclean:
X rm -f *.o mktable grammar tabl.c.out tabl.h.out tabl.c tabl.h
X
Xclobber: clean
X rm -f lint tags
X
Xcode.o: ../bed/e1code.c
X $(CC) -c $(CFLAGS) ../bed/e1code.c -o code.o
X
X# --- Utilities for the programmer ---
X
Xmflags:
X echo MFLAGS=\"$(MFLAGS)\", MAKEFLAGS=\"$(MAKEFLAGS)\"
X
X# If your UNIX isn't BSD4.2 or higher, use:
X# MKDEP=../scripts/mkdep
XMKDEP=$(CC) -M
X
XMakefile: ALWAYS
X rm -f Makefile
X (echo "# EDIT MY ANCESTOR Makefile.bsd"; \
X echo "# AND SAY 'make -f Makefile.bsd Makefile'"; \
X cat Makefile.bsd; \
X $(MKDEP) $(DEFS) $(BINCL) $(SRCS); \
X ) >Makefile
X
Xlint: $(SRCS) $(HDRS)
X $(LINT) $(LINTFLAGS) $(DEFS) $(LBINCL) $(SRCS) >lint
X
Xtags: $(HDRS) $(SRCS)
X rm -f tags
X ctags $(HDRS) $(SRCS)
X
Xtest: all
X cp tabl.h.out tabl.h
X cp tabl.c.out tabl.c
X cc -c $(CFLAGS) tabl.c
X
XALWAYS: #dummy
X
X###
Xmain.o: main.c
Xmain.o: ../bhdrs/b.h
Xmain.o: ../uhdrs/osconf.h
Xmain.o: /usr/include/stdio.h
Xmain.o: ../uhdrs/os.h
Xmain.o: /usr/include/math.h
Xmain.o: /usr/include/ctype.h
Xmain.o: /usr/include/strings.h
Xmain.o: /usr/include/sys/types.h
Xmain.o: /usr/include/sys/stat.h
Xmain.o: /usr/include/sys/file.h
Xmain.o: ../uhdrs/conf.h
Xmain.o: ../uhdrs/config.h
Xmain.o: ./main.h
Xalloc.o: alloc.c
Xalloc.o: ../bhdrs/b.h
Xalloc.o: ../uhdrs/osconf.h
Xalloc.o: /usr/include/stdio.h
Xalloc.o: ../uhdrs/os.h
Xalloc.o: /usr/include/math.h
Xalloc.o: /usr/include/ctype.h
Xalloc.o: /usr/include/strings.h
Xalloc.o: /usr/include/sys/types.h
Xalloc.o: /usr/include/sys/stat.h
Xalloc.o: /usr/include/sys/file.h
Xalloc.o: ../uhdrs/conf.h
Xalloc.o: ../uhdrs/config.h
Xalloc.o: ./main.h
Xread.o: read.c
Xread.o: ../bhdrs/b.h
Xread.o: ../uhdrs/osconf.h
Xread.o: /usr/include/stdio.h
Xread.o: ../uhdrs/os.h
Xread.o: /usr/include/math.h
Xread.o: /usr/include/ctype.h
Xread.o: /usr/include/strings.h
Xread.o: /usr/include/sys/types.h
Xread.o: /usr/include/sys/stat.h
Xread.o: /usr/include/sys/file.h
Xread.o: ../uhdrs/conf.h
Xread.o: ../uhdrs/config.h
Xread.o: ./main.h
Xfill.o: fill.c
Xfill.o: ../bhdrs/b.h
Xfill.o: ../uhdrs/osconf.h
Xfill.o: /usr/include/stdio.h
Xfill.o: ../uhdrs/os.h
Xfill.o: /usr/include/math.h
Xfill.o: /usr/include/ctype.h
Xfill.o: /usr/include/strings.h
Xfill.o: /usr/include/sys/types.h
Xfill.o: /usr/include/sys/stat.h
Xfill.o: /usr/include/sys/file.h
Xfill.o: ../uhdrs/conf.h
Xfill.o: ../uhdrs/config.h
Xfill.o: ./main.h
Xcomp.o: comp.c
Xcomp.o: ../bhdrs/b.h
Xcomp.o: ../uhdrs/osconf.h
Xcomp.o: /usr/include/stdio.h
Xcomp.o: ../uhdrs/os.h
Xcomp.o: /usr/include/math.h
Xcomp.o: /usr/include/ctype.h
Xcomp.o: /usr/include/strings.h
Xcomp.o: /usr/include/sys/types.h
Xcomp.o: /usr/include/sys/stat.h
Xcomp.o: /usr/include/sys/file.h
Xcomp.o: ../uhdrs/conf.h
Xcomp.o: ../uhdrs/config.h
Xcomp.o: ./main.h
Xcomp.o: ../ehdrs/code.h
Xdump.o: dump.c
Xdump.o: ../bhdrs/b.h
Xdump.o: ../uhdrs/osconf.h
Xdump.o: /usr/include/stdio.h
Xdump.o: ../uhdrs/os.h
Xdump.o: /usr/include/math.h
Xdump.o: /usr/include/ctype.h
Xdump.o: /usr/include/strings.h
Xdump.o: /usr/include/sys/types.h
Xdump.o: /usr/include/sys/stat.h
Xdump.o: /usr/include/sys/file.h
Xdump.o: ../uhdrs/conf.h
Xdump.o: ../uhdrs/config.h
Xdump.o: ./main.h
Xe1code.o: ../bed/e1code.c
Xe1code.o: ../bhdrs/b.h
Xe1code.o: ../uhdrs/osconf.h
Xe1code.o: /usr/include/stdio.h
Xe1code.o: ../uhdrs/os.h
Xe1code.o: /usr/include/math.h
Xe1code.o: /usr/include/ctype.h
Xe1code.o: /usr/include/strings.h
Xe1code.o: /usr/include/sys/types.h
Xe1code.o: /usr/include/sys/stat.h
Xe1code.o: /usr/include/sys/file.h
Xe1code.o: ../uhdrs/conf.h
Xe1code.o: ../uhdrs/config.h
Xe1code.o: ../ehdrs/code.h
END_OF_FILE
if test 4701 -ne `wc -c <'abc/boot/Makefile'`; then
echo shar: \"'abc/boot/Makefile'\" unpacked with wrong size!
fi
# end of 'abc/boot/Makefile'
fi
if test -f 'abc/ihdrs/i1num.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/ihdrs/i1num.h'\"
else
echo shar: Extracting \"'abc/ihdrs/i1num.h'\" \(4302 characters\)
sed "s/^X//" >'abc/ihdrs/i1num.h' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/************************************************************************/
X/* Full numeric package: private definitions */
X/* */
X/* A number is modelled as one of zero, unbounded integer, */
X/* unbounded rational or approximate. */
X/* Zero has a 'length' field of zero, and nothing else. */
X/* A length field of +n means the number is an n digit integer, */
X/* (with digits to some large base). */
X/* A length of -1 means there follow two floating point numbers, */
X/* one the fraction (zero or .5 <= frac <= 1), one the exponent */
X/* with respect to base 2 (should be an integral value). */
X/* (This is so when EXT_RANGE is defined. Otherwise, there is */
X/* only one field, frac, which is not normalized. This saves */
X/* code and data space on e.g. the IBM PC, where the natural */
X/* range of double's is sufficient (~1E307).) */
X/* A length of -2 means there follow two values, pointers to two */
X/* unbounded integers, ie a rational number. */
X/* A length of -n, n>2, means it is a rational with a print width */
X/* of n-2. */
X/* */
X/************************************************************************/
X
X/*************** Definitions exported for integers *****************/
X
X/* typedef int digit; or short; calculated in mkconfig -> config.h */
X
Xtypedef struct integer {
X HEADER;
X digit dig[1];
X} *integer;
X
X#define FreezeSmallInt(v, vv) \
X (IsSmallInt(v) && (Freeze1(v, vv), Freeze2(v, vv)))
X#define Freeze1(v, vv) ((vv).type= Num, (vv).refcnt= Maxrefcnt)
X#define Freeze2(v, vv) \
X ((vv).len= (v) != 0, (vv).dig[0]= SmallIntVal(v), (v)= &(vv))
X
Xinteger int_gadd();
Xinteger int_canon();
Xinteger int_sum();
Xinteger int_prod();
Xinteger int_diff();
Xinteger int_quot();
Xinteger int_neg();
Xinteger int_gcd();
Xinteger mk_int();
Xinteger int1mul();
Xinteger int_tento();
Xinteger int_half();
Xinteger int_mod();
Xdigit int_ldiv();
X
X#define int_0 ((integer) MkSmallInt(0))
X#define int_1 ((integer) MkSmallInt(1))
X#define int_2 ((integer) MkSmallInt(2))
X#define int_5 ((integer) MkSmallInt(5))
X#define int_10 ((integer) MkSmallInt(10))
X#define int_min1 ((integer) MkSmallInt(-1))
X
X#define Integral(v) (IsSmallInt(v) || Length(v)>=0)
X#define Modulo(a,b) (((a)%(b)+(b))%(b))
X#define Digit(v,n) ((v)->dig[n])
X#define Msd(v) (IsSmallInt(v) ? SmallIntVal(v) : Digit(v,Length(v)-1))
X#define Lsd(v) (IsSmallInt(v) ? SmallIntVal(v) : Digit(v,0))
X
X#define Odd(x) ((x)&1)
X#define Even(x) (!Odd(x))
X
X/* Provisional definitions */
X
X#define Copy(x) copy((value)(x))
X#define Release(x) release((value)(x))
X
X/***************** Definitions exported for rationals *****************/
X
Xtypedef struct {
X HEADER;
X integer num, den;
X} *rational;
X
X
X#define Numerator(a) ((a)->num)
X#define Denominator(a) ((a)->den)
X#define Rational(a) (!IsSmallInt(a) && Length(a)<-1)
X#define Roundsize(a) (-2-Length(a))
X
Xrational mk_rat();
Xrational rat_sum();
Xrational rat_diff();
Xrational rat_neg();
Xrational rat_prod();
Xrational rat_quot();
Xrational rat_power();
Xrational rat_zero();
X
Xextern rational rat_half;
X
Xvalue tento();
Xvalue mk_exact();
X
X/***************** Definitions exported for approximate numbers *************/
X
Xtypedef struct real {
X HEADER;
X double frac;
X#ifdef EXT_RANGE
X double expo;
X#endif /* EXT_RANGE */
X} *real;
X
X#define Frac(v) ((v)->frac)
X#ifdef EXT_RANGE
X#define Expo(v) ((v)->expo)
X#else
X#define Expo(v) 0.0
X#endif
X
X#define Approximate(v) (!IsSmallInt(v) && Length(v)==-1)
X#define Exact(v) (!Approximate(v))
X
Xextern real app_0;
X
Xreal mk_approx();
X
Xreal app_sum();
Xreal app_diff();
Xreal app_prod();
Xreal app_quot();
Xreal app_neg();
X
Xreal app_exp();
Xreal app_log();
Xreal app_power();
X
Xvalue app_frexp();
Xinteger app_floor();
Xvalue app_exactly();
X
Xvalue prod2n();
Xvalue prod10n();
Xrational ratsumhalf();
X
Xvalue grab_num();
Xvalue regrab_num();
Xvalue grab_rat();
X
Xdouble frexp(), ldexp();
END_OF_FILE
if test 4302 -ne `wc -c <'abc/ihdrs/i1num.h'`; then
echo shar: \"'abc/ihdrs/i1num.h'\" unpacked with wrong size!
fi
# end of 'abc/ihdrs/i1num.h'
fi
if test -f 'abc/keys/keyhlp.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/keys/keyhlp.c'\"
else
echo shar: Extracting \"'abc/keys/keyhlp.c'\" \(4623 characters\)
sed "s/^X//" >'abc/keys/keyhlp.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1989. */
X
X/*
X * ABC keys -- Print the bindings.
X */
X
X#include "b.h"
X#include "feat.h"
X#include "bmem.h"
X#include "keys.h"
X#include "getc.h"
X
X/*
X The following array determines the order of the editor operations
X in the helpblurb.
X The names and keyrepresentations are taken from deftab in e1getc.c
X and ?1keys.c.
X Printing is done in two columns.
X Code NOTHING is used to produce an empty place in the second column.
X */
X
Xint helpcode[]= {
X WIDEN, EXTEND,
X FIRST, LAST,
X PREVIOUS, NEXT,
X UPLINE, DOWNLINE,
X UPARROW, DOWNARROW,
X LEFTARROW, RITEARROW,
X#ifdef GOTOCURSOR
X GOTO, NOTHING,
X#endif
X ACCEPT, NEWLINE,
X UNDO, REDO,
X COPY, DELETE,
X RECORD, PLAYBACK,
X LOOK, HELP,
X#ifdef CANSUSPEND
X EXIT, NOTHING,
X CANCEL, SUSPEND,
X#else
X EXIT, CANCEL,
X#endif
X TERMINIT, TERMDONE,
X IGNORE, NOTHING
X};
X
XHidden struct helpitem {
X string data; /* "[name] repr's string" */
X int bindmark; /* position in data of more bindings marker */
X bool changed; /* status of item */
X} helpitem[(sizeof(helpcode))/(sizeof(int))];
X
XHidden int nitems= 0;
X
XHidden int namewidth; /* width of name field */
X#define GAP_FIELDS 1 /* nr of spaces between two fields */
X/*Hidden int bindwidth;*/ /* width of bindings field */
X
XHidden int helpwidth; /* width of a column */
X#define GAP_COLUMNS 1 /* nr of spaces between the two columns */
X
X#define BINDMARK '*' /* set after name if too many bindings */
XHidden int bindstart; /* offset bindings field */
X#define BINDSEP ", " /* separator bindings */
X
X/*
X * Print the bindings.
X */
X
XVisible Procedure putbindings(yfirst) int yfirst; {
X int h;
X bool h_changed;
X
X for (h= 0; h < nitems; h+= 2, yfirst++) {
X
X if (h_changed= helpitem[h].changed) {
X getbindings(h);
X trmputdata(yfirst, yfirst, 0, helpitem[h].data);
X }
X if (h+1 < nitems) {
X if (helpitem[h+1].changed)
X getbindings(h+1);
X else if (!h_changed)
X continue;
X trmputdata(yfirst, yfirst,
X helpwidth+GAP_COLUMNS, helpitem[h+1].data);
X }
X }
X trmsync(yfirst, 0);
X}
X
XVisible Procedure setup_bindings(width, nlines) int width, *nlines; {
X int h;
X int code;
X int len;
X string buffer;
X string name;
X string getname();
X
X helpwidth= (width - GAP_COLUMNS)/2;
X nitems= ((sizeof(helpcode))/(sizeof(int)));
X namewidth= 0;
X
X for (h= 0; h < nitems; h++) {
X buffer= (string) getmem((unsigned) helpwidth+1);
X code= helpcode[h];
X name= getname(code);
X strcpy(buffer, name);
X len= strlen(buffer);
X if (len > namewidth) /* find max name length */
X namewidth= len;
X helpitem[h].data= buffer;
X helpitem[h].bindmark= len;
X helpitem[h].changed= Yes;
X confirm_operation(code, name);
X }
X
X namewidth++;
X /* one extra space for a marker after the name
X * if there are too many bindings to show
X */
X bindstart= namewidth + GAP_FIELDS;
X/* bindwidth= helpwidth - bindstart; */
X
X /* extend with spaces */
X for (h= 0; h < nitems; h++)
X extendwithspaces(helpitem[h].data, bindstart);
X
X /* set nlines */
X
X *nlines= (nitems+1)/2;
X}
X
X#ifdef MEMTRACE
X
XVisible Procedure fini_bindings() {
X int h;
X
X for (h= 0; h < nitems; h++) {
X free(helpitem[h].data);
X }
X}
X
X#endif /* MEMTRACE */
X
XHidden string getname(code) int code; {
X tabent *d;
X
X for (d= deftab; d < deftab+ndefs; d++) {
X if (code == d->code)
X return d->name;
X }
X return "";
X}
X
XHidden Procedure extendwithspaces(buffer, bound) string buffer; int bound; {
X int len= strlen(buffer);
X string pbuf= buffer+len;
X
X for (; len < bound; len++)
X *pbuf++= ' ';
X *pbuf= '\0';
X}
X
XVisible Procedure bind_changed(code) int code; {
X int h;
X
X for (h= 0; h < nitems; h++) {
X if (code == helpcode[h]) {
X helpitem[h].changed= Yes;
X break;
X }
X }
X}
X
XVisible Procedure bind_all_changed() { /* for redrawing the screen */
X int h;
X
X for (h= 0; h < nitems; h++) {
X helpitem[h].changed= Yes;
X }
X}
X
X
X#define Def(d) ((d)->def != NULL && (d)->def[0] != '\0')
X#define Rep(d) ((d)->rep != NULL && (d)->rep[0] != '\0')
X
XHidden Procedure getbindings(h) int h; {
X tabent *d;
X int code= helpcode[h];
X string buffer= helpitem[h].data;
X bool all_showed= Yes;
X string repr;
X
X buffer[bindstart]= '\0';
X for (d= deftab+ndefs-1; d >= deftab; d--) {
X
X if (code != d->code || !Def(d) || !Rep(d))
X continue;
X if (!addbinding(d->rep, buffer))
X all_showed= No;
X }
X /* set marker */
X buffer[helpitem[h].bindmark]= !all_showed ? BINDMARK : ' ';
X
X helpitem[h].changed= No;
X}
X
XHidden bool addbinding(repr, buffer) string repr, buffer; {
X string sep= buffer[bindstart] == '\0' ? "" : BINDSEP;
X
X if (strlen(buffer) + strlen(sep) + strlen(repr) > helpwidth)
X return No;
X strcat(buffer, sep);
X strcat(buffer, repr);
X return Yes;
X}
END_OF_FILE
if test 4623 -ne `wc -c <'abc/keys/keyhlp.c'`; then
echo shar: \"'abc/keys/keyhlp.c'\" unpacked with wrong size!
fi
# end of 'abc/keys/keyhlp.c'
fi
if test -f 'abc/stc/i2tcu.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/stc/i2tcu.c'\"
else
echo shar: Extracting \"'abc/stc/i2tcu.c'\" \(4424 characters\)
sed "s/^X//" >'abc/stc/i2tcu.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* unification of polytypes */
X
X#include "b.h"
X#include "bobj.h"
X#include "i2stc.h"
X
XHidden bool bad;
X
XVisible Procedure unify(a, b, pu)
Xpolytype a, b, *pu;
X{
X bad = No;
X setreprtable();
X starterrvars();
X#ifdef TYPETRACE
X s_unify(a, b);
X#endif
X u_unify(a, b, pu);
X#ifdef TYPETRACE
X e_unify(a, b, *pu);
X#endif
X if (bad) badtyperr(a, b);
X enderrvars();
X delreprtable();
X}
X
XHidden Procedure u_unify(a, b, pu)
Xpolytype a, b, *pu;
X{
X typekind a_kind, b_kind;
X polytype res;
X
X a_kind = kind(a);
X b_kind = kind(b);
X
X if (are_same_types(a, b)) {
X *pu = p_copy(a);
X }
X else if (t_is_var(a_kind) || t_is_var(b_kind)) {
X substitute_for(a, b, pu);
X }
X else if (have_same_structure(a, b)) {
X unify_subtypes(a, b, pu);
X }
X else if (has_number(a_kind) && has_number(b_kind)) {
X *pu = mkt_number();
X }
X else if (has_text(a_kind) && has_text(b_kind)) {
X *pu = mkt_text();
X }
X else if (has_text(a_kind) && t_is_tlt(b_kind)) {
X u_unify(asctype(b), (res = mkt_text()), pu);
X p_release(res);
X }
X else if (has_text(b_kind) && t_is_tlt(a_kind)) {
X u_unify(asctype(a), (res = mkt_text()), pu);
X p_release(res);
X }
X else if ((t_is_list(a_kind) && has_lt(b_kind))
X ||
X (t_is_list(b_kind) && has_lt(a_kind))
X )
X {
X u_unify(asctype(a), asctype(b), &res);
X *pu = mkt_list(res);
X }
X else if (t_is_table(a_kind) && has_lt(b_kind)) {
X u_unify(asctype(a), asctype(b), &res);
X *pu = mkt_table(p_copy(keytype(a)), res);
X }
X else if (t_is_table(b_kind) && has_lt(a_kind)) {
X u_unify(asctype(a), asctype(b), &res);
X *pu = mkt_table(p_copy(keytype(b)), res);
X }
X else if ((t_is_tlt(a_kind) && t_is_lt(b_kind))
X ||
X (t_is_lt(a_kind) && t_is_tlt(b_kind)))
X {
X u_unify(asctype(a), asctype(b), &res);
X *pu = mkt_lt(res);
X }
X else if (t_is_error(a_kind) || t_is_error(b_kind)) {
X *pu = mkt_error();
X }
X else {
X *pu = mkt_error();
X bad = Yes;
X }
X if (t_is_var(a_kind) && t_is_error(kind(bottomtype(*pu))))
X adderrvar(a);
X if (t_is_var(b_kind) && t_is_error(kind(bottomtype(*pu))))
X adderrvar(b);
X}
X
XHidden Procedure unify_subtypes(a, b, pu)
Xpolytype a, b, *pu;
X{
X polytype sa, sb, s;
X intlet nsub, is;
X bool err = No;
X
X nsub = nsubtypes(a);
X *pu = mkt_polytype(kind(a), nsub);
X for (is = 0; is < nsub; is++) {
X sa = subtype(a, is);
X sb = subtype(b, is);
X u_unify(sa, sb, &s);
X putsubtype(s, *pu, is);
X if (t_is_error(kind(s)))
X err = Yes;
X }
X if (err == Yes) {
X p_release(*pu);
X *pu = mkt_error();
X }
X}
X
XForward bool contains();
XForward bool equal_vars();
X
XHidden Procedure substitute_for(a, b, pu)
Xpolytype a, b, *pu;
X{
X typekind a_kind, b_kind;
X polytype ta, tb, tu, tt;
X
X a_kind = kind(a);
X b_kind = kind(b);
X
X ta = bottomtype(a);
X tb = bottomtype(b);
X
X if (!t_is_var(kind(ta)) && !t_is_var(kind(tb)))
X u_unify(ta, tb, &tu);
X else if (!t_is_var(kind(ta)))
X tu = p_copy(ta);
X else
X tu = p_copy(tb);
X
X if (t_is_var(a_kind)) {
X if (contains(tu, bottomvar(a)))
X textify(a, &tu);
X }
X if (t_is_var(b_kind)) {
X if (contains(tu, bottomvar(b)))
X textify(b, &tu);
X }
X
X if (t_is_var(a_kind) && t_is_var(b_kind)
X && !are_same_types(bottomvar(a), bottomvar(b)))
X {
X repl_type_of(bottomvar(a), bottomvar(b));
X }
X
X tt= bottomtype(tu);
X
X if (t_is_var(a_kind)) {
X if (!are_same_types(tt, bottomtype(a)))
X repl_type_of(bottomvar(a), tt);
X *pu= p_copy(a);
X }
X else { /* t_is_var(b_kind) */
X if (!are_same_types(tt, bottomtype(b)))
X repl_type_of(bottomvar(b), tt);
X *pu= p_copy(b);
X }
X
X p_release(tu);
X}
X
XHidden Procedure textify(a, pu)
Xpolytype a, *pu;
X{
X polytype ttext, text_hopefully;
X
X ttext = mkt_text();
X u_unify(*pu, ttext, &text_hopefully);
X if (bad == No) {
X p_release(text_hopefully);
X u_unify(a, ttext, &text_hopefully);
X }
X p_release(*pu);
X if (bad == No) {
X *pu = ttext;
X }
X else {
X *pu = mkt_error();
X /* cyclic type errors now reported through normal mechanism */
X p_release(ttext);
X }
X p_release(text_hopefully);
X}
X
XVisible bool contains(u, a) polytype u, a; {
X bool result;
X
X result = No;
X if (t_is_var(kind(u))) {
X if (table_has_type_of(u)) {
X result = contains(bottomtype(u), a);
X }
X }
X else {
X polytype s;
X intlet is, nsub;
X nsub = nsubtypes(u);
X for (is = 0; is < nsub; is++) {
X s = subtype(u, is);
X if (equal_vars(s, a) || contains(s, a)) {
X result = Yes;
X break;
X }
X }
X }
X return (result);
X}
X
XVisible bool equal_vars(s, a) polytype s, a; {
X return (are_same_types(bottomvar(s), a));
X}
END_OF_FILE
if test 4424 -ne `wc -c <'abc/stc/i2tcu.c'`; then
echo shar: \"'abc/stc/i2tcu.c'\" unpacked with wrong size!
fi
# end of 'abc/stc/i2tcu.c'
fi
if test -f 'abc/unix/u1file.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/unix/u1file.c'\"
else
echo shar: Extracting \"'abc/unix/u1file.c'\" \(1744 characters\)
sed "s/^X//" >'abc/unix/u1file.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */
X
X#include "b.h"
X#include "bmem.h"
X#include "dest.h"
X#include "bfil.h"
X
Xextern char *getenv();
Xextern char *getwd();
X
XVisible char *curdir() {
X static char buffer[SIZE_PATH];
X return getwd(buffer);
X}
X
XHidden string searchfile(base, abclib) string base; string abclib; {
X char *file;
X
X /* search first in startup directory */
X file= makepath(startdir, base);
X if (F_readable(file))
X return (string) file;
X freepath(file);
X
X /* then in bwsdefault */
X if (bwsdefault != NULL) {
X file= makepath(bwsdefault, base);
X if (F_readable(file))
X return (string) file;
X freepath(file);
X }
X
X /* next first in abclib */
X file= makepath(abclib, base);
X if (F_readable(file))
X return (string) file;
X freepath(file);
X
X /* else fail */
X return (string) NULL;
X}
X
XVisible Procedure initfile() {
X char *homedir= getenv("HOME");
X char *termname;
X string termfile;
X
X startdir= savepath(curdir());
X bwsdefault= homedir ? makepath(homedir, BWSNAME) : (char *) NULL;
X messfile= searchfile(MESSFILE, ABCLIB);
X helpfile= searchfile(HELPFILE, ABCLIB);
X buffile= homedir ? makepath(homedir, BUFFILE) : savepath(BUFFILE);
X
X if (editor != (string) NULL)
X return; /* we don't need the keydefinitions file */
X
X if ((termname= getenv("TERM")) != NULL) {
X termfile= (string) getmem((unsigned) strlen(KEYSPREFIX)+strlen(termname));
X strcpy(termfile, KEYSPREFIX);
X strcat(termfile, termname);
X keysfile= searchfile(termfile, ABCLIB);
X freemem(termfile);
X }
X if (keysfile == (string)NULL) {
X keysfile= searchfile(KEYSFILE, ABCLIB);
X }
X}
X
XVisible Procedure endfile() {
X freepath(startdir);
X freepath(bwsdefault);
X freepath(messfile);
X freepath(keysfile);
X freepath(helpfile);
X freepath(buffile);
X}
END_OF_FILE
if test 1744 -ne `wc -c <'abc/unix/u1file.c'`; then
echo shar: \"'abc/unix/u1file.c'\" unpacked with wrong size!
fi
# end of 'abc/unix/u1file.c'
fi
echo shar: End of archive 20 \(of 25\).
cp /dev/null ark20isdone
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...
