v23i100: ABC interactive programming environment, Part21/25
Rich Salz
rsalz at bbn.com
Thu Dec 20 04:55:18 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 100
Archive-name: abc/part21
#! /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/b/b1grab.c abc/b/b1outp.c abc/bed/e1comm.c
# abc/bed/e1spos.c abc/bhdrs/bobj.h abc/bint2/i2fix.c
# abc/bint2/i2tes.c abc/bint3/i3env.c abc/boot/comp.c
# abc/btr/i1btr.c abc/lin/i1tex.c abc/tc/tgoto.c
# abc/ukeys/abckeys_924
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:28:21 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 21 (of 25)."'
if test -f 'abc/b/b1grab.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/b/b1grab.c'\"
else
echo shar: Extracting \"'abc/b/b1grab.c'\" \(4068 characters\)
sed "s/^X//" >'abc/b/b1grab.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */
X
X/* memory handling for ABC values: grabbing, copying and releasing */
X
X#include "b.h"
X#include "bint.h"
X#include "bedi.h"
X#include "bmem.h"
X#include "bobj.h"
X
X#define Adj(s) (unsigned) (Hdrsize+(s))
X#define Unadj(s) (unsigned) ((s)-Hdrsize)
X
X#define Grabber() {if(len>Maxintlet)syserr(MESS(1500, "big grabber"));}
X#define Regrabber() {if(len>Maxintlet)syserr(MESS(1501, "big regrabber"));}
X
X#define Offset(type) (type == Nod ? NodOffset : 0)
X
X/******************************* Grabbing **********************************/
X
XHidden unsigned getsyze(type, len, pnptrs) literal type; intlet len;
X int *pnptrs; {
X register unsigned syze= 0;
X int nptrs= 0;
X switch (type) {
X case Tex:
X case ELT:
X case Lis:
X case Ran:
X case Tab:
X syze= tltsyze(type, len, &nptrs);
X break;
X case Num:
X syze= numsyze(len, &nptrs);
X break;
X case Ptn:
X syze= ptnsyze(len, &nptrs);
X break;
X case Rangebounds:
X case Com:
X syze= len*sizeof(value); nptrs= len;
X break;
X case Sim:
X syze= sizeof(simploc); nptrs= 1;
X break;
X case Tri:
X syze= sizeof(trimloc); nptrs= 3;
X break;
X case Tse:
X syze= sizeof(tbseloc); nptrs= 2;
X break;
X case How:
X syze= sizeof(how); nptrs= 1;
X break;
X case Ind:
X syze= sizeof(indirect); nptrs= 1;
X break;
X case Fun:
X case Prd:
X syze= sizeof(funprd); nptrs= 1;
X break;
X case Ref:
X syze= sizeof(ref); nptrs= 1;
X break;
X case Nod:
X syze= sizeof(struct node) - Hdrsize - sizeof(node)
X + len*sizeof(node);
X nptrs= len;
X break;
X case Pat:
X syze= sizeof(struct path) - Hdrsize; nptrs= 2;
X break;
X case Etex:
X syze= (len+1)*sizeof(char); nptrs= 0;
X break;
X default:
X#ifndef NDEBUG
X putCstr(stdout, "\ngetsyze{%c}\n", type);
X#endif
X syserr(MESS(1502, "getsyze called with unknown type"));
X }
X if (pnptrs != NULL) *pnptrs= nptrs;
X return syze;
X}
X
XVisible value grab(type, len) literal type; intlet len; {
X unsigned syze= getsyze(type, len, (int*)NULL);
X value v;
X Grabber();
X v= (value) getmem(Adj(syze));
X v->type= type; v->len= len; v->refcnt= 1;
X return v;
X}
X
XVisible Procedure regrab(v, len) value *v; intlet len; {
X literal type= (*v)->type;
X unsigned syze= getsyze(type, len, (int*)NULL);
X Regrabber();
X regetmem((ptr *) v, Adj(syze));
X (*v)->len= len;
X}
X
X/******************************* Copying and releasing *********************/
X
XVisible value copy(v) value v; {
X if (v != Vnil && !IsSmallInt(v) && Refcnt(v) < Maxrefcnt)
X ++Refcnt(v);
X return v;
X}
X
XVisible Procedure release(v) value v; {
X if (v == Vnil || IsSmallInt(v)) return;
X if (Refcnt(v) == 0)
X syserr(MESS(1503, "releasing unreferenced value"));
X if (Refcnt(v) < Maxrefcnt && --Refcnt(v) == 0)
X rel_subvalues(v);
X}
X
XHidden value ccopy(v) value v; {
X literal type= v->type; intlet len; value w;
X int nptrs; unsigned syze; register string from, to, end;
X register value *pp, *pend;
X len= Length(v);
X syze= getsyze(type, len, &nptrs);
X Grabber();
X w= (value) getmem(Adj(syze));
X w->type= type; w->len= len; w->refcnt= 1;
X from= Str(v); to= Str(w); end= to+syze;
X while (to < end) *to++ = *from++;
X pp= (value*) ((char*)Ats(w) + Offset(type));
X pend= pp+nptrs;
X for (; pp < pend; pp++) VOID copy(*pp);
X return w;
X}
X
XVisible Procedure uniql(ll) value *ll; {
X if (*ll != Vnil && !IsSmallInt(*ll) && Refcnt(*ll) > 1) {
X value c= ccopy(*ll);
X release(*ll);
X *ll= c;
X }
X}
X
XVisible Procedure rrelease(v) value v; {
X literal type= v->type; intlet len= Length(v);
X int nptrs; register value *pp, *pend;
X VOID getsyze(type, len, &nptrs);
X pp= (value*) ((char*)Ats(v) + Offset(type));
X pend= pp+nptrs;
X while (pp < pend) release(*pp++);
X v->type= '\0';
X freemem((ptr) v);
X}
X
X/************************************************************************/
X
Xchar *malloc();
X
XVisible bool enough_space(type, len) literal type; intlet len; {
X unsigned syze= getsyze(type, len, (int*)NULL);
X char *p= (char *) malloc((unsigned) (Hdrsize + syze));
X bool ok;
X
X ok= p != NULL;
X free(p);
X return ok;
X}
X
X/************************************************************************/
END_OF_FILE
if test 4068 -ne `wc -c <'abc/b/b1grab.c'`; then
echo shar: \"'abc/b/b1grab.c'\" unpacked with wrong size!
fi
# end of 'abc/b/b1grab.c'
fi
if test -f 'abc/b/b1outp.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/b/b1outp.c'\"
else
echo shar: Extracting \"'abc/b/b1outp.c'\" \(3566 characters\)
sed "s/^X//" >'abc/b/b1outp.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1989. */
X
X#include "b.h"
X#include "bmem.h"
X
Xextern bool in_vtrm;
Xextern bool raw_newline;
X
X#ifdef KEYS
X#define f_interactive(file) (isatty(fileno(file)))
X#endif
X
X#define LINELENGTH 200
X
XVisible Procedure putstr(file, s) FILE *file; string s; {
X char buf[LINELENGTH];
X char *nl;
X char *line;
X int len;
X
X if (!f_interactive(file) || !raw_newline) {
X fputs(s, file);
X return;
X }
X for (; *s; s= ++nl) {
X if ((nl= strchr(s, '\n')) == NULL) {
X fputs(s, file);
X break;
X }
X len= nl-s;
X if (len > 0) {
X if (len >= LINELENGTH)
X line= (char *) getmem((unsigned) (len+1));
X else
X line= buf;
X strncpy(line, s, len);
X line[len]= '\0';
X fputs(line, file);
X if (len >= LINELENGTH)
X freestr(line);
X }
X fputs("\n\r", file);
X }
X}
X
XVisible Procedure putchr(file, c) FILE *file; char c; {
X if (c == '\n')
X putnewline(file);
X else
X putc(c, file);
X}
X
XVisible Procedure putnewline(file) FILE *file; {
X putc('\n', file);
X if (f_interactive(file) && raw_newline)
X putc('\r', file);
X}
X
X/***************************************************************************/
X
X#define FMTLENGTH 600
X
XHidden char *fmtbuf;
X
XVisible Procedure initfmt() {
X fmtbuf= (char *) getmem(FMTLENGTH);
X}
X
X#define FMTINTLEN 100 /* space allocated for int's in formats */
X
XHidden char *getfmtbuf(fmt, n) string fmt; int n; {
X static char *fmtstr= NULL;
X
X n+= strlen(fmt);
X if (fmtstr != NULL)
X freestr(fmtstr);
X if (n >= FMTLENGTH)
X return fmtstr= (char *) getmem((unsigned) n+1);
X return fmtbuf;
X}
X
X/***************************************************************************/
X
XVisible Procedure putSstr(file, fmt, s) FILE *file; string fmt, s; {
X char *str= getfmtbuf(fmt, strlen(s));
X sprintf(str, fmt, s);
X putstr(file, str);
X}
X
XVisible Procedure putSDstr(file, fmt, s, d) FILE *file; string fmt, s; int d; {
X char *str= getfmtbuf(fmt, strlen(s)+FMTINTLEN);
X sprintf(str, fmt, s, d);
X putstr(file, str);
X}
X
XVisible Procedure putDSstr(file, fmt, d, s) FILE *file; string fmt, s; int d; {
X char *str= getfmtbuf(fmt, FMTINTLEN+strlen(s));
X sprintf(str, fmt, d, s);
X putstr(file, str);
X}
X
XVisible Procedure putDstr(file, fmt, d) FILE *file; string fmt; int d; {
X putDSstr(file, fmt, d, "");
X}
X
XVisible Procedure put3DSstr(file, fmt, d1, d2, d3, s)
X FILE *file; string fmt; int d1, d2, d3; string s; {
X char *str= getfmtbuf(fmt, 3*FMTINTLEN+strlen(s));
X sprintf(str, fmt, d1, d2, d3, s);
X putstr(file, str);
X}
X
XVisible Procedure put3Dstr(file, fmt, d1, d2, d3)
X FILE *file; string fmt; int d1, d2, d3; {
X put3DSstr(file, fmt, d1, d2, d3, "");
X}
X
XVisible Procedure put2Dstr(file, fmt, d1, d2)
X FILE *file; string fmt; int d1, d2; {
X put3DSstr(file, fmt, d1, d2, 0, "");
X}
X
XVisible Procedure put2Cstr(file, fmt, c1, c2)
X FILE *file; string fmt; char c1, c2; {
X char *str= getfmtbuf(fmt, 1+1);
X sprintf(str, fmt, c1, c2);
X putstr(file, str);
X}
X
XVisible Procedure putCstr(file, fmt, c) FILE *file; string fmt; char c; {
X put2Cstr(file, fmt, c, '\0');
X}
X
X/***************************************************************************/
X
XVisible Procedure putmess(file, m) FILE *file; int m; {
X putstr(file, getmess(m));
X fflush(file);
X}
X
XVisible Procedure putSmess(file, m, s) FILE *file; int m; string s; {
X putSstr(file, getmess(m), s);
X fflush(file);
X}
X
XVisible Procedure putDSmess(file, m, d, s) FILE *file; int m; int d; string s; {
X putDSstr(file, getmess(m), d, s);
X fflush(file);
X}
X
XVisible Procedure put2Cmess(file, m, c1, c2) FILE *file; int m; char c1, c2; {
X put2Cstr(file, getmess(m), c1, c2);
X fflush(file);
X}
X
END_OF_FILE
if test 3566 -ne `wc -c <'abc/b/b1outp.c'`; then
echo shar: \"'abc/b/b1outp.c'\" unpacked with wrong size!
fi
# end of 'abc/b/b1outp.c'
fi
if test -f 'abc/bed/e1comm.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1comm.c'\"
else
echo shar: Extracting \"'abc/bed/e1comm.c'\" \(3288 characters\)
sed "s/^X//" >'abc/bed/e1comm.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/*
X * B editor -- Editor command processor.
X */
X
X#include "b.h"
X#include "bedi.h"
X#include "feat.h" /* for SAVEBUF, SAVEPOS, USERSUGG */
X#include "bfil.h"
X#include "bcom.h"
X#include "node.h"
X#include "supr.h" /* for environ */
X#include "tabl.h"
X#ifdef GFX
X#include "bgfx.h"
X#endif
X#ifdef MENUS
X#include "abcmenus.h"
X#endif
X
X#ifdef SIGNAL
X#include <signal.h>
X#endif
X
Xvalue editqueue();
X
XVisible int doctype;
X
XVisible environ *tobesaved;
XVisible string savewhere;
X
Xenviron top_env, *top_ep;
X
XVisible Procedure initbed() {
X top_ep= &top_env;
X
X savewhere = (string)NULL;
X tobesaved = (environ*)NULL;
X clrenv(top_ep);
X#ifdef SAVEBUF
X top_ep->copybuffer = editqueue(buffile);
X if (top_ep->copybuffer)
X top_ep->copyflag = Yes;
X#endif /* SAVEBUF */
X}
X
XVisible Procedure endbed() {
X register environ *ep = tobesaved;
X
X tobesaved = (environ*)NULL;
X /* To avoid loops if saving is cancelled. */
X if (savewhere && ep) {
X if (ep->generation > 0) {
X VOID save(ep->focus, savewhere);
X#ifdef USERSUGG
X writesugg(ep->focus);
X#endif /* USERSUGG */
X }
X#ifdef SAVEBUF
X if (ep->copyflag)
X VOID savequeue(ep->copybuffer, buffile);
X else
X VOID savequeue(Vnil, buffile);
X#endif /* SAVEBUF */
X#ifdef SAVEPOS
X savpos(savewhere, ep);
X#endif /* SAVEPOS */
X }
X#ifdef SAVEBUF
X if (top_ep->copyflag)
X VOID savequeue(top_ep->copybuffer, buffile);
X else
X VOID savequeue(Vnil, buffile);
X#endif /* SAVEBUF */
X Erelease(*top_ep);
X}
X
XVisible bool intrflag= No; /* interrupt flag editor */
X#ifdef SIGTSTP
XVisible bool suspflag= No;
X#endif
X
XHidden Procedure initintr() {
X intrflag= No;
X#ifdef SIGTSTP
X suspflag= No; /* do not propagate suspend from interpreter */
X#endif
X#ifdef SIGNAL
X setintrhandler();
X#endif
X}
X
X#define INTRMESS MESS(4700, "*** Interrupted\n")
X
XHidden Procedure endintr() {
X#ifdef SIGNAL
X resetintrhandler();
X#endif
X if (interrupted)
X putmess(errfile, INTRMESS);
X}
X
XVisible Procedure abced_file(filename, errline, kind, creating)
X string filename; intlet errline; literal kind; bool creating; {
X environ *ep= top_ep;
X
X initintr();
X#ifdef GFX
X if (gfx_mode != TEXT_MODE)
X exit_gfx();
X#endif
X setindent(0);
X doctype= D_perm;
X VOID dofile(ep, filename, errline, kind, creating);
X endshow();
X top(&ep->focus);
X ep->mode = WHOLE;
X VOID deltext(ep);
X if (!ep->copyflag) {
X release(ep->copybuffer);
X ep->copybuffer = Vnil;
X }
X endintr();
X}
X
XVisible char *ed_line(kind, indent) literal kind; int indent; {
X char *buf= (char *) NULL;
X environ *ep= top_ep;
X#ifdef MENUS
X int savemenusstat;
X#endif
X char *send();
X
X initintr();
X
X if (kind == R_cmd)
X setroot(Imm_cmd);
X else if (kind == R_expr)
X setroot(Expression);
X else
X setroot(Raw_input);
X delfocus(&ep->focus);
X if (kind == R_cmd) {
X cmdprompt(CMDPROMPT);
X doctype= D_immcmd;
X }
X else if (kind == R_expr || kind == R_raw || kind == R_ioraw)
X setindent(indent);
X else
X setindent(0);
X if (kind != R_cmd) {
X doctype= D_input;
X#ifdef MENUS
X savemenusstat= curmenusstat;
X adjust_menus(Editor_menus);
X#endif
X }
X VOID editdocument(ep, No);
X#ifdef MENUS
X if (doctype == D_input)
X adjust_menus(savemenusstat);
X#endif
X endshow();
X top(&ep->focus);
X ep->mode = WHOLE;
X if (!interrupted)
X buf= send(ep->focus);
X VOID deltext(ep);
X
X endintr();
X
X return buf;
X}
X
X
END_OF_FILE
if test 3288 -ne `wc -c <'abc/bed/e1comm.c'`; then
echo shar: \"'abc/bed/e1comm.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1comm.c'
fi
if test -f 'abc/bed/e1spos.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1spos.c'\"
else
echo shar: Extracting \"'abc/bed/e1spos.c'\" \(3439 characters\)
sed "s/^X//" >'abc/bed/e1spos.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1987. */
X
X/*
X * B editor -- Save focus position.
X */
X
X#include "b.h"
X#include "feat.h"
X
X#ifdef SAVEPOS
X
X#include "bedi.h"
X#include "bobj.h"
X#include "bfil.h"
X#include "node.h"
X#include "supr.h"
X#include "bmem.h"
X
X/*
X * Keep a simple database of file name vs. line number.
X * The database is kept in most-recently-used-first order.
X */
X
Xtypedef struct pc { char *fname; int line; struct pc *next; } poschain;
Xtypedef poschain *pos;
X
X#define PNULL ((pos) NULL)
X
XHidden pos poshead= PNULL;
X
XHidden bool poschanges;
X
XHidden pos new_pos(fname, line) char *fname; int line; {
X pos new= (pos) getmem((unsigned) sizeof(poschain));
X new->fname= (char *) savestr(fname);
X new->line= line;
X new->next= PNULL;
X return new;
X}
X
XHidden Procedure free_pos(filpos) pos filpos; {
X freestr(filpos->fname);
X freemem((ptr) filpos);
X}
X
XHidden int del_pos(fname) char *fname; {
X pos filpos= poshead;
X pos prev= PNULL;
X int line= 1;
X
X while (filpos != PNULL) {
X if (strcmp(fname, filpos->fname) == 0) {
X line= filpos->line;
X if (prev)
X prev->next= filpos->next;
X else
X poshead= filpos->next;
X free_pos(filpos);
X poschanges= Yes;
X break;
X }
X prev= filpos;
X filpos= filpos->next;
X }
X return line;
X}
X
XHidden Procedure sav_pos(fname, line) char *fname; int line; {
X pos new;
X
X VOID del_pos(fname);
X new= new_pos(fname, line);
X new->next= poshead;
X poshead= new;
X poschanges= Yes;
X}
X
XHidden char *filebase(fname) char *fname; {
X char *base= strrchr(fname, DELIM);
X
X return base != NULL ? ++base : fname;
X}
X
XVisible Procedure initpos() {
X FILE *file;
X char *buffer, *name;
X char *fname;
X int line;
X pos tail, new;
X
X poshead= tail= PNULL;
X poschanges= No;
X file= fopen(posfile, "r");
X if (!file)
X return;
X while ((buffer= f_getline(file)) != NULL) {
X name= (char *) getmem((unsigned) (strlen(buffer) + 1));
X
X if (sscanf(buffer, "%s\t%d", name, &line) == 2) {
X fname= filebase(name);
X if (F_exists(fname)) {
X new= new_pos(fname, line);
X if (!tail)
X poshead= tail= new;
X else {
X tail->next= new;
X tail= new;
X }
X }
X }
X freemem((ptr) name);
X freemem((ptr) buffer);
X }
X fclose(file);
X}
X
XHidden Procedure wripos() {
X FILE *fp;
X pos filpos;
X
X if (!poschanges)
X return;
X poschanges= No;
X if (poshead == PNULL) {
X unlink(posfile);
X return;
X }
X fp= fopen(posfile, "w");
X if (!fp)
X return;
X filpos= poshead;
X while (filpos != PNULL) {
X fprintf(fp, "%s\t%d\n", filpos->fname, filpos->line);
X filpos= filpos->next;
X }
X fclose(fp);
X}
X
XVisible Procedure endpos() {
X pos prev;
X
X wripos();
X while (poshead != PNULL) {
X prev= poshead;
X poshead= poshead->next;
X free_pos(prev);
X }
X}
X
X/* getpos() is called from editor */
X
XVisible int getpos(fname) char *fname; {
X pos filpos= poshead;
X
X fname= filebase(fname);
X while (filpos != PNULL) {
X if (strcmp(fname, filpos->fname) == 0)
X return filpos->line;
X filpos= filpos->next;
X }
X return 0; /* editor expects 0 as default */
X}
X
X/* savpos() is called from editor */
X
XVisible bool savpos(fname, ep) char *fname; environ *ep; {
X sav_pos(filebase(fname), lineno(ep) + 1);
X}
X
X/* delpos() is called from interpreter */
X
XVisible Procedure delpos(fname) char *fname; {
X VOID del_pos(filebase(fname));
X}
X
X/* movpos() is called from interpreter */
X
XVisible Procedure movpos(ofname, nfname) char *ofname, *nfname; {
X int n_line= del_pos(filebase(ofname));
X sav_pos(filebase(nfname), n_line);
X}
X
X#endif /* SAVEPOS */
END_OF_FILE
if test 3439 -ne `wc -c <'abc/bed/e1spos.c'`; then
echo shar: \"'abc/bed/e1spos.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1spos.c'
fi
if test -f 'abc/bhdrs/bobj.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bhdrs/bobj.h'\"
else
echo shar: Extracting \"'abc/bhdrs/bobj.h'\" \(3659 characters\)
sed "s/^X//" >'abc/bhdrs/bobj.h' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* B values, locations, environments: the B abstract machine */
X
X/* Avoid name conflicts with standard header files: */
X#define power b_power
X#define exp1 b_exp1
X#define log1 b_log1
X#define log2 b_log2
X#define pi b_pi
X#define random b_random
X
X/****************************** general ******************************/
X
Xtypedef int relation; /* < 0, == 0, > 0 */
Xrelation compare();
X
X/*************************************************************************/
X
Xvalue grab();
Xunsigned tltsyze();
Xunsigned numsyze();
Xunsigned ptnsyze();
Xbool enough_space();
X
Xdouble hash();
X
Xbool is_abcname();
X
X/****************************** Texts ******************************/
X
Xbool character();
X
Xvalue mkchar();
Xvalue mk_text();
Xchar charval();
Xchar ncharval();
Xstring strval();
Xstring sstrval();
X
Xvalue concat();
Xvalue behead();
Xvalue curtail();
Xvalue repeat();
X
Xvalue stripped();
Xvalue split();
Xvalue upper();
Xvalue lower();
X
Xvalue adjleft();
Xvalue centre();
Xvalue adjright();
X
Xvalue convert();
X
X/****************************** Numbers ******************************/
X
X/* Predicates */
Xbool integral(); /* is the value an integer? */
Xbool large(); /* can a number be represented by a C int? */
X#ifdef RANGEPRINT
Xbool is_increment(); /* a = b+1 ? */
X#endif
X
X/* Constants */
X#define zero MkSmallInt(0)
X#define one MkSmallInt(1)
X
X/* Conversion of abstract values to concrete objects */
Xdouble numval(); /* numeric value of any number */
Xint intval(); /* numeric value of integral number */
Xint propintlet(); /* checks int for fitting in intlet */
Xstring convnum(); /* character string approximation of any number */
Xrelation numcomp(); /* comparison of two numbers: yields -1, 0 or 1 */
Xdouble numhash(); /* hashes any abstract number to a 'double' */
X
X/* Conversion of concrete objects to abstract numbers */
Xvalue numconst(); /* string argument */
Xvalue mk_integer(); /* int argument */
X
X/* Functions on numbers */
Xvalue sum();
Xvalue diff();
Xvalue negated();
Xvalue prod();
Xvalue quot();
Xvalue modulo();
Xvalue floorf();
Xvalue ceilf();
Xvalue round1();
Xvalue round2();
Xvalue mod();
Xvalue power();
Xvalue absval();
Xvalue signum();
Xvalue numerator();
Xvalue denominator();
Xvalue approximate();
Xvalue random();
Xvalue root1();
Xvalue sin1();
Xvalue cos1();
Xvalue tan1();
Xvalue arctan1();
Xvalue angle1();
Xvalue sin2();
Xvalue cos2();
Xvalue tan2();
Xvalue arctan2();
Xvalue angle2();
Xvalue radius();
Xvalue exp1();
Xvalue log1();
Xvalue root2();
Xvalue log2();
Xvalue pi();
Xvalue e();
Xvalue nowisthetime();
Xvalue exactly();
Xbool exact();
X
X/****************************** Compounds ******************************/
X#define Nfields(c) Length(c)
X#define Field(c, i) ((Ats(c)+(i)))
X#define k_Overfields for (k= 0; k < len; k++)
X#define Lastfield(k) ((k) == len-1)
X
X#define mk_compound(len) grab(Com, len)
X
X/****************************** Lists ******************************/
Xvalue mk_range();
Xbool is_rangelist();
X
X/* Procedure insert(); */
X/* Procedure remove(); */
X
X/****************************** Tables ******************************/
X
Xvalue keys();
Xbool in_keys();
Xvalue associate();
X
X/* Procedure replace(); */
X/* Procedure delete(); */
X
Xvalue* adrassoc();
Xvalue* key();
Xvalue* assoc();
X
X/****************************** Texts, Lists, and Tables *******************/
Xvalue mk_elt();
X
Xbool in();
X
Xvalue size();
Xvalue size2();
Xvalue min1();
Xvalue min2();
Xvalue max1();
Xvalue max2();
X#ifdef B_COMPAT
Xvalue th_of();
X#endif
Xvalue thof();
Xvalue item();
Xvalue choice();
X
Xint length(); /* The same as size, temporary until part2 is written in B */
Xbool empty(); /* whether #v=0: also temporary */
X
X
X
END_OF_FILE
if test 3659 -ne `wc -c <'abc/bhdrs/bobj.h'`; then
echo shar: \"'abc/bhdrs/bobj.h'\" unpacked with wrong size!
fi
# end of 'abc/bhdrs/bobj.h'
fi
if test -f 'abc/bint2/i2fix.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint2/i2fix.c'\"
else
echo shar: Extracting \"'abc/bint2/i2fix.c'\" \(3651 characters\)
sed "s/^X//" >'abc/bint2/i2fix.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Fix unparsed expr/test */
X
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i0err.h"
X#include "i2exp.h"
X#include "i2nod.h"
X#include "i2gen.h" /* Must be after i2nod.h */
X#include "i2par.h"
X#include "i3env.h"
X
X#define S_elmt '1'
X#define S_dya '2'
X#define S_mon '3'
X
XHidden Procedure f_unparsed(pt, fct) parsetree *pt, (*fct)(); {
X parsetree t= *pt;
X expadm adm;
X struct state v;
X
X /* Ignore visits done during resolving UNPARSED: */
X hold(&v);
X initexp(&adm, N_EXP_STACK, FIXER);
X t= (*fct)(&adm, *Branch(t, UNP_SEQ));
X release(*pt);
X *pt= t;
X endstack(&adm);
X jumpto(NilTree);
X let_go(&v);
X}
X
XHidden parsetree fix_expr(adm, root) expadm *adm; parsetree root; {
X parsetree w;
X value *p_i, i, f;
X int state= S_dya;
X
X for (; Nfld(adm) < Nfields(root); ++Nfld(adm)) {
X p_i= Field(root, Nfld(adm));
X i= copy(*p_i);
X if (!Valid(i)) {
X if (state == S_dya || state == S_mon)
X fixerr(NO_EXPR);
X else if (Prop(adm))
X break;
X else
X fixerr(UPTO_EXPR);
X return NilTree;
X }
X else if (state == S_dya || state == S_mon) {
X if (Is_parsetree(i)) {
X f_expr(p_i);
X release(i); i= copy(*p_i);
X push_item(adm, (parsetree) i);
X state= S_elmt;
X }
X else if (modify_tag(i, &w)) {
X push_item(adm, w);
X state= S_elmt;
X }
X else if (is_monfun(i, &f)) {
X push_item(adm, (parsetree) i);
X state= S_mon;
X }
X else {
X if (is_name(i))
X fixerrV(NO_INIT_OR_DEF, i);
X else
X fixerr(NO_EXPR);
X release(i);
X return NilTree;
X }
X }
X else { /* state == S_elmt */
X if (Dya_opr(i)) {
X release(i);
X i= copy(*Field(i, 0));
X }
X if (is_dyafun(i, &f)) {
X do_dya(adm, i);
X state= S_dya;
X }
X else {
X release(i);
X if (Prop(adm)) break;
X else {
X fixerr(UPTO_EXPR);
X return NilTree;
X }
X }
X }
X }
X if (state == S_dya || state == S_mon) {
X fixerr(NO_EXPR);
X return NilTree;
X }
X while ((Sp(adm) - Stack(adm)) > 2)
X reduce(adm);
X return Pop(adm);
X}
X
XHidden parsetree fix_test(adm, root) expadm *adm; parsetree root; {
X parsetree v, w;
X value i, f, *aa;
X int lastn= Nfields(root) - 1;
X
X if (Nfld(adm) > lastn) {
X fixerr(NO_TEST);
X return NilTree;
X }
X i= *Field(root, Nfld(adm));
X if (!Valid(i))
X ;
X else if (is_zerprd(i, &f)) {
X if (Nfld(adm) < lastn) {
X fixerr(UPTO_TEST);
X return NilTree;
X }
X return node3(TAGzerprd, copy(i), copydef(f));
X }
X else if (Is_text(i) && (aa= envassoc(refinements, i))) {
X if (Nfld(adm) == lastn)
X return node3(TAGrefinement, copy(i), copy(*aa));
X }
X else if (is_monprd(i, &f)) {
X ++Nfld(adm);
X v= fix_expr(adm, root);
X return node4(MONPRD, copy(i), v, copydef(f));
X }
X Prop(adm)= Yes;
X v= fix_expr(adm, root);
X Prop(adm)= No;
X i= Nfld(adm) <= lastn ? *Field(root, Nfld(adm)) : Vnil;
X if (!Valid(i)) {
X fixerr(NO_TEST);
X release(v);
X return NilTree;
X }
X if (Dya_opr(i))
X i= *Field(i, 0);
X if (!is_dyaprd(i, &f)) {
X if (is_name(i))
X fixerrV(NO_DEFINITION, i);
X else
X fixerr(NO_TEST);
X release(v);
X return NilTree;
X }
X ++Nfld(adm);
X w= fix_expr(adm, root);
X return node5(DYAPRD, v, copy(i), w, copydef(f));
X}
X
XVisible Procedure f_eunparsed(pt) parsetree *pt; {
X f_unparsed(pt, fix_expr);
X}
X
XVisible Procedure f_cunparsed(pt) parsetree *pt; {
X f_unparsed(pt, fix_test);
X}
X
XVisible Procedure f_trim_target(v, trim) parsetree v; char trim; {
X parsetree w= *Branch(v, TRIM_RIGHT);
X struct prio *ptrim, *pdya;
X value name;
X
X if (nodetype(w) == DYAF) {
X pdya= dprio(*Branch(w, DYA_NAME));
X name= mk_text(trim == '@' ? S_BEHEAD : S_CURTAIL);
X ptrim= dprio(name);
X if (!(pdya->L > ptrim->H))
X fixerr(NO_TRIM_TARG);
X release(name);
X }
X}
END_OF_FILE
if test 3651 -ne `wc -c <'abc/bint2/i2fix.c'`; then
echo shar: \"'abc/bint2/i2fix.c'\" unpacked with wrong size!
fi
# end of 'abc/bint2/i2fix.c'
fi
if test -f 'abc/bint2/i2tes.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint2/i2tes.c'\"
else
echo shar: Extracting \"'abc/bint2/i2tes.c'\" \(3883 characters\)
sed "s/^X//" >'abc/bint2/i2tes.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i0err.h"
X#include "b0lan.h"
X#include "i2par.h"
X#include "i2nod.h"
X
X#ifdef macintosh
X/* Avoid name conflict with standard header files: */
X#define relop b_relop
X#endif
X
XForward parsetree right_test();
X
XVisible parsetree test(q) txptr q; {
X parsetree v;
X skipsp(&tx);
X if (!(conjunction(q, &v) || disjunction(q, &v))) v= right_test(q);
X return v;
X}
X
XForward parsetree tight_test();
X
XHidden parsetree right_test(q) txptr q; {
X parsetree v;
X char *kw;
X txptr tx0= tx;
X
X skipsp(&tx);
X if (Text(q) && is_keyword(&kw)) {
X if (negation(kw, q, &v) || quantification(kw, q, &v))
X return v;
X else tx= tx0;
X }
X return tight_test(q);
X}
X
XHidden bool conjunction(q, v) txptr q; parsetree *v; {
X txptr ftx, ttx;
X if (find(K_AND, q, &ftx, &ttx)) {
X parsetree t;
X t= tight_test(ftx); tx= ttx;
X if (!conjunction(q, v)) *v= right_test(q);
X *v= node3(AND, t, *v);
X return Yes;
X }
X return No;
X}
X
XHidden bool disjunction(q, v) txptr q; parsetree *v; {
X txptr ftx, ttx;
X if (find(K_OR, q, &ftx, &ttx)) {
X parsetree t;
X t= tight_test(ftx); tx= ttx;
X if (!disjunction(q, v)) *v= right_test(q);
X *v= node3(OR, t, *v);
X return Yes;
X }
X return No;
X}
X
XHidden bool negation(kw, q, v) char *kw; txptr q; parsetree *v; {
X if (not_keyword(kw)) {
X *v= node2(NOT, right_test(q));
X return Yes;
X }
X return No;
X}
X
XHidden bool quantification(kw, q, v) char *kw; txptr q; parsetree *v; {
X bool some, each;
X if ((some= some_keyword(kw)) || (each= each_keyword(kw)) ||
X no_keyword(kw)) {
X parsetree t, w;
X typenode type;
X txptr utx, vtx, ftx, ttx;
X
X req(K_HAS, ceol, &utx, &vtx);
X if (utx > q) {
X parerr(MESS(2700, "HAS follows colon"));
X /* as in: SOME i IN x: SHOW i HAS a */
X utx= tx; vtx= q;
X }
X req(K_IN_quant, utx, &ftx, &ttx);
X idf_cntxt= In_ranger;
X t= idf(ftx); tx= ttx;
X w= expr(utx); tx= vtx;
X type= some ? SOME_IN : each ? EACH_IN : NO_IN;
X *v= node4(type, t, w, right_test(q));
X return Yes;
X }
X return No;
X}
X
XForward parsetree ref_or_prop();
X
XHidden parsetree tight_test(q) txptr q; {
X parsetree v;
X skipsp(&tx);
X if (nothing(q, MESS(2701, "nothing instead of expected test")))
X v= NilTree;
X else if (!(cl_test(q, &v) || order_test(q, &v))) {
X if (Isexpr(Char(tx))) v= ref_or_prop(q);
X else {
X parerr(NO_TEST);
X v= NilTree;
X }
X }
X upto_test(q);
X return v;
X}
X
XHidden bool cl_test(q, v) txptr q; parsetree *v; {
X txptr tx0= tx;
X if (open_sign) { /* (expr) or (test) */
X txptr ftx, ttx, tx1;
X tx1= tx;
X req(S_CLOSE, q, &ftx, &ttx); tx= ttx;
X skipsp(&tx);
X if (!Text(q)) {
X tx= tx1;
X *v= compound(ttx, test);
X return Yes;
X }
X }
X tx= tx0;
X return No;
X}
X
XForward typenode relop();
X
XHidden bool order_test(q, v) txptr q; parsetree *v; {
X txptr ftx;
X if (findrel(q, &ftx)) {
X typenode r;
X *v= singexpr(ftx);
X do {
X r= relop();
X if (!findrel(q, &ftx)) ftx= q;
X *v= node3(r, *v, singexpr(ftx));
X }
X while (ftx < q);
X return Yes;
X }
X return No;
X}
X
XHidden typenode relop() {
X skipsp(&tx);
X return
X at_most_sign ? AT_MOST :
X unequal_sign ? UNEQUAL :
X at_least_sign ? AT_LEAST :
X equals_sign ? EQUAL :
X less_than_sign ? LESS_THAN :
X greater_than_sign ? GREATER_THAN :
X /* psyserr */ Nonode;
X}
X
X/* refined_test or proposition */
X
XHidden parsetree ref_or_prop(q) txptr q; {
X value t1, t2;
X txptr tx0= tx;
X
X if (tag_operator(q, &t1)) {
X skipsp(&tx);
X if (!Text(q))
X return node2(TAG, t1);
X if (tag_operator(q, &t2)) {
X skipsp(&tx);
X if (!Text(q))
X return node4(MONPRD, t1, node2(TAG, t2), Vnil);
X release(t2);
X }
X release(t1);
X }
X tx= tx0;
X return unp_test(q);
X}
X
XHidden Procedure upto_test(q) txptr q; {
X skipsp(&tx);
X if (Text(q)) {
X txptr ftx, ttx;
X if (find(K_AND, q, &ftx, &ttx) || find(K_OR, q, &ftx, &ttx)) {
X tx= ftx;
X parerr(PRIO);
X }
X else parerr(UPTO_TEST);
X tx= q;
X }
X}
END_OF_FILE
if test 3883 -ne `wc -c <'abc/bint2/i2tes.c'`; then
echo shar: \"'abc/bint2/i2tes.c'\" unpacked with wrong size!
fi
# end of 'abc/bint2/i2tes.c'
fi
if test -f 'abc/bint3/i3env.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3env.c'\"
else
echo shar: Extracting \"'abc/bint3/i3env.c'\" \(3806 characters\)
sed "s/^X//" >'abc/bint3/i3env.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Environments */
X
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i3env.h" /* for curline, curlino */
X
XVisible envtab prmnvtab;
XVisible envchain prmnvchain;
XVisible env prmnv;
X
X/* context: */
X/* The bound tags for the current environment are stored in *bndtgs */
X/* A new bound tag list is created on evaluating a refined test or expression */
X
XVisible env curnv;
XVisible value *bndtgs;
XHidden value bndtglist;
XVisible literal cntxt, resexp;
XVisible value uname= Vnil;
XVisible intlet lino;
XVisible intlet f_lino;
XVisible intlet i_lino;
X
XVisible context read_context;
X
XVisible Procedure sv_context(sc) context *sc; {
X sc->curnv= curnv;
X sc->bndtgs= bndtgs;
X sc->cntxt= cntxt;
X sc->resexp= resexp;
X sc->uname= copy(uname);
X sc->cur_line= curline;
X sc->cur_lino= curlino;
X}
X
XVisible Procedure set_context(sc) context *sc; {
X curnv= sc->curnv;
X bndtgs= sc->bndtgs;
X cntxt= sc->cntxt;
X resexp= sc->resexp;
X release(uname); uname= sc->uname;
X curline= sc->cur_line;
X curlino= sc->cur_lino;
X}
X
XVisible Procedure initprmnv()
X{
X prmnv= &prmnvchain;
X prmnv->tab= Vnil;
X prmnv->inv_env= Enil;
X}
X
XVisible Procedure initenv() {
X /* The following invariant must be maintained:
X EITHER:
X the original permanent-environment table resides in prmnv->tab
X and prmnvtab == Vnil
X OR:
X the original permanent-environment table resides in prmnvtab
X and prmnv->tab contains a scratch-pad copy.
X */
X prmnv->tab= mk_elt(); prmnvtab= Vnil;
X prmnv->inv_env= Enil;
X bndtglist= mk_elt();
X}
X
XVisible Procedure endenv() {
X release(prmnv->tab); prmnv->tab= Vnil;
X release(bndtglist); bndtglist= Vnil;
X release(uname); uname= Vnil;
X}
X
XVisible Procedure re_env() {
X setprmnv(); bndtgs= &bndtglist;
X}
X
XVisible Procedure setprmnv() {
X /* the current and permanent environment are reset
X to the original permanent environment */
X if (prmnvtab != Vnil) {
X prmnv->tab= prmnvtab;
X prmnvtab= Vnil;
X }
X curnv= prmnv;
X}
X
XVisible Procedure e_replace(v, t, k) value v, *t, k; {
X if (Is_compound(*t)) {
X int n= SmallIntVal(k);
X uniql(t);
X if (*Field(*t, n) != Vnil) release(*Field(*t, n));
X *Field(*t, n)= copy(v);
X }
X else if (!Is_table(*t)) syserr(MESS(3000, "replacing in non-environment"));
X else replace(v, t, k);
X}
X
XVisible Procedure e_delete(t, k) value *t, k; {
X if (Is_compound(*t) && IsSmallInt(k)) {
X int n= SmallIntVal(k);
X if (*Field(*t, n) != Vnil) {
X uniql(t); release(*Field(*t, n));
X *Field(*t, n)= Vnil;
X }
X }
X else if (!Is_table(*t)) syserr(MESS(3001, "deleting from non-environment"));
X else if (in_keys(k, *t)) delete(t, k);
X}
X
XVisible value* envassoc(t, ke) value t, ke; {
X if (Is_compound(t) && IsSmallInt(ke)) {
X int n= SmallIntVal(ke);
X if (*Field(t, n) == Vnil) return Pnil;
X return Field(t, n);
X }
X if (!Is_table(t)) syserr(MESS(3002, "selection on non-environment"));
X return adrassoc(t, ke);
X}
X
XVisible bool in_env(tab, ke, aa) value tab, ke, **aa; {
X /* IF ke in keys tab:
X PUT tab[ke] IN aa
X SUCCEED
X FAIL
X */
X *aa= envassoc(tab, ke);
X return (*aa != Pnil);
X}
X
XVisible Procedure extbnd_tags(btl, et) value btl; envtab et; {
X /* Copy bound targets to the invoking environment */
X /* FOR tag IN btl: \ btl is the bound tag list
X IF tag in keys et: \ et is the environment we're just leaving
X PUT et[tag] IN curnv[tag] \ curnv is the invoking environment
X */
X value *aa, tag;
X int len= length(btl), k;
X for (k= 1; k <= len; k++) {
X tag= thof(k, btl);
X if (in_env(et, tag, &aa)) {
X e_replace(*aa, &(curnv->tab), tag);
X if (*bndtgs != Vnil) insert(tag, bndtgs);
X }
X release(tag);
X }
X}
X
XVisible Procedure lst_ttgs() {
X int k, len;
X len= length(prmnv->tab);
X for (k= 0; k < len; k++) {
X writ(*key(prmnv->tab, k));
X wri_space();
X }
X if (len > 0)
X newline();
X}
END_OF_FILE
if test 3806 -ne `wc -c <'abc/bint3/i3env.c'`; then
echo shar: \"'abc/bint3/i3env.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3env.c'
fi
if test -f 'abc/boot/comp.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/boot/comp.c'\"
else
echo shar: Extracting \"'abc/boot/comp.c'\" \(4152 characters\)
sed "s/^X//" >'abc/boot/comp.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */
X
X/*
X * Compute classinfo from filled-in tables.
X */
X
X#include "b.h"
X#include "main.h"
X#include "code.h"
X
XVisible Procedure compute_classes() {
X
X initcodes();
X
X comp_classes();
X}
X
X/*
X * Initialization routine for the 'struct classinfo' stuff.
X *
X * Now that the c_syms[] array of each class has been read and replaced
X * by the correct index in the symdef[] table, we can compute the c_insert,
X * c_append and c_join arrays.
X *
X * Classes "suggestion-body" and "sugghowname-body" are skipped:
X * what can be inserted there is not computed from this table.
X */
X
XHidden Procedure comp_classes()
X{
X int iclass;
X struct classinfo *pclass;
X
X for (iclass= 0; iclass < nclass; iclass++) {
X pclass = &classdef[iclass];
X if (iclass == nsuggstnbody || iclass == nsugghowbody)
X continue; /* Dead entry */
X defclass(pclass);
X }
X}
X
XForward int fwidth();
X
XHidden Procedure defclass(pclass) struct classinfo *pclass; {
X itemptr psymbol;
X struct syminfo *psym;
X string rep0;
X item class0;
X string rep1;
X int fw1;
X itemptr psubsym;
X item insert[1024];
X item append[1024];
X item join[1024];
X int inslen = 0;
X int applen = 0;
X int joinlen = 0;
X int c;
X
X
X psymbol= pclass->c_syms;
X
X for (; !Isnilitem(*psymbol); ++psymbol) {
X if (*psymbol == noptional)
X continue;
X if (*psymbol >= nlexical) { /* Insert direct lexical item */
X for (c= 1; c <= lastcode; c++) {
X if (maystart(Invcode(c), *psymbol)) {
X Assert(inslen+3 < sizeof insert / sizeof insert[0]);
X insert[inslen] = c;
X insert[inslen+1] = *psymbol;
X inslen += 2;
X }
X }
X continue;
X }
X /* else: Sym: "rep0", class0, "rep1", class1, ... */
X psym= &symdef[*psymbol];
X rep0= psym->s_repr[0];
X if (rep0 != 0 && strchr("\b\t", rep0[0]) == NULL) {
X /* Insert fixed text */
X c = Code(rep0[0]);
X Assert(inslen+3 < sizeof insert / sizeof insert[0]);
X insert[inslen] = c;
X insert[inslen+1] = *psymbol;
X inslen += 2;
X continue;
X }
X /* else: "rep0" was empty; try start of class0 */
X Assert(!Isnilitem(psym->s_class[0]));
X class0= psym->s_class[0];
X psubsym= classdef[class0].c_syms;
X for (; !Isnilitem(*psubsym); psubsym++) {
X if (*psubsym < nlexical)
X continue;
X for (c= 1; c <= lastcode; ++c) {
X /* Insert indirect lexical items */
X if (maystart(Invcode(c), *psubsym)) {
X Assert(inslen+3 < sizeof insert / sizeof insert[0]);
X insert[inslen]= c;
X insert[inslen+1]= *psymbol;
X inslen += 2;
X }
X }
X }
X rep1= psym->s_repr[1];
X fw1= (rep1 == 0 ? 0 : fwidth(rep1));
X if (fw1) { /* Append */
X c= rep1[0];
X Assert(c > 0 && c < RANGE);
X if (c == ' ') {
X c= rep1[1];
X if (!c || c == '\b' || c == '\t')
X c= ' ';
X else
X c|= 0200;
X }
X Assert(applen+3 < sizeof append / sizeof append[0]);
X append[applen]= c;
X append[applen+1]= *psymbol;
X applen += 2;
X }
X if ((!fw1 || fw1 == 1 && rep1[0] == ' ')
X &&
X !Isnilitem(psym->s_class[1]))
X { /* Join */
X Assert(joinlen+3 < sizeof join / sizeof join[0]);
X join[joinlen]= 1 + fw1;
X join[joinlen+1]= *psymbol;
X joinlen += 2;
X }
X }
X
X Assert(inslen); /* Dead alley */
X insert[inslen]= Nilitem;
X pclass->c_insert= savearray(insert, inslen + 1);
X if (applen) {
X append[applen]= Nilitem;
X pclass->c_append= savearray(append, applen + 1);
X }
X if (joinlen) {
X join[joinlen]= Nilitem;
X pclass->c_join= savearray(join, joinlen + 1);
X }
X}
X
XVisible bool maystart(c, ilex) char c; item ilex; {
X string cp;
X
X ilex -= nlexical;
X Assert(ilex >= 0);
X if (ilex >= nlex || !isascii(c) || c != ' ' && !isprint(c))
X return No;
X cp= lexdef[ilex].l_start;
X if (*cp == '^')
X return !strchr(cp+1, c);
X return strchr(cp, c) != 0;
X}
X
X/*
X * Yield the width of a piece of fixed text, excluding \b or \t.
X * 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
XHidden int fwidth(str) string str; {
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}
END_OF_FILE
if test 4152 -ne `wc -c <'abc/boot/comp.c'`; then
echo shar: \"'abc/boot/comp.c'\" unpacked with wrong size!
fi
# end of 'abc/boot/comp.c'
fi
if test -f 'abc/btr/i1btr.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/btr/i1btr.c'\"
else
echo shar: Extracting \"'abc/btr/i1btr.c'\" \(3536 characters\)
sed "s/^X//" >'abc/btr/i1btr.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X#include "b.h"
X#include "bmem.h"
X#include "i1btr.h"
X#include "i1tlt.h"
X
X/*********************************************************************/
X/* grab, copy, release of btree(node)s
X/*********************************************************************/
X
XVisible btreeptr
Xgrabbtreenode(flag, it)
X literal flag; literal it;
X{
X btreeptr pnode; unsigned syz;
X static intlet isize[]= {
X sizeof(itexnode), sizeof(ilisnode),
X sizeof(itabnode), sizeof(itabnode)};
X static intlet bsize[]= {
X sizeof(btexnode), sizeof(blisnode),
X sizeof(btabnode), sizeof(btabnode)};
X switch (flag) {
X case Inner:
X syz= isize[it];
X break;
X case Bottom:
X syz= bsize[it];
X break;
X case Irange:
X case Crange:
X syz = sizeof(rangenode);
X break;
X }
X pnode = (btreeptr) getmem((unsigned) syz);
X Refcnt(pnode) = 1;
X Flag(pnode) = flag;
X return(pnode);
X}
X
X/* ----------------------------------------------------------------- */
X
XVisible btreeptr copybtree(pnode) btreeptr pnode; {
X if (pnode != Bnil && Refcnt(pnode) < Maxrefcnt) ++Refcnt(pnode);
X return(pnode);
X}
X
XVisible Procedure uniqlbtreenode(pptr, it) btreeptr *pptr; literal it; {
X if (*pptr NE Bnil && Refcnt(*pptr) > 1) {
X btreeptr qnode = *pptr;
X *pptr = ccopybtreenode(*pptr, it);
X relbtree(qnode, it);
X }
X}
X
XVisible btreeptr ccopybtreenode(pnode, it) btreeptr pnode; literal it; {
X intlet limp;
X btreeptr qnode;
X intlet iw;
X
X iw = Itemwidth(it);
X qnode = grabbtreenode(Flag(pnode), it);
X Lim(qnode) = limp = Lim(pnode);
X Size(qnode) = Size(pnode);
X switch (Flag(qnode)) {
X case Inner:
X cpynitms(Piitm(qnode, 0, iw), Piitm(pnode, 0, iw), limp, it);
X cpynptrs(&Ptr(qnode, 0), &Ptr(pnode, 0), limp+1);
X break;
X case Bottom:
X cpynitms(Pbitm(qnode, 0, iw), Pbitm(pnode, 0, iw), limp, it);
X break;
X case Irange:
X case Crange:
X Lwbval(qnode) = copy(Lwbval(pnode));
X Upbval(qnode) = copy(Upbval(pnode));
X break;
X default:
X syserr(MESS(400, "unknown flag in ccopybtreenode"));
X }
X return(qnode);
X}
X
X/* make a new root (after the old ptr0 split) */
X
XVisible btreeptr mknewroot(ptr0, pitm0, ptr1, it)
X btreeptr ptr0, ptr1; itemptr pitm0; literal it;
X{
X int r;
X intlet iw = Itemwidth(it);
X btreeptr qnode = grabbtreenode(Inner, it);
X Ptr(qnode, 0) = ptr0;
X movnitms(Piitm(qnode, 0, iw), pitm0, 1, iw);
X Ptr(qnode, 1) = ptr1;
X Lim(qnode) = 1;
X r= Sincr(Size(ptr0));
X Size(qnode) = Ssum(r, Size(ptr1));
X return(qnode);
X}
X
X/* ----------------------------------------------------------------- */
X
X/* release btree */
X
XVisible Procedure relbtree(pnode, it) btreeptr pnode; literal it; {
X width iw;
X
X iw = Itemwidth(it);
X if (pnode EQ Bnil)
X return;
X if (Refcnt(pnode) EQ 0) {
X syserr(MESS(401, "releasing unreferenced btreenode"));
X return;
X }
X if (Refcnt(pnode) < Maxrefcnt && --Refcnt(pnode) EQ 0) {
X intlet l;
X switch (Flag(pnode)) {
X case Inner:
X for (l = 0; l < Lim(pnode); l++) {
X relbtree(Ptr(pnode, l), it);
X switch (it) {
X case Tt:
X case Kt:
X release(Ascval(Piitm(pnode, l, iw)));
X case Lt:
X release(Keyval(Piitm(pnode, l, iw)));
X }
X }
X relbtree(Ptr(pnode, l), it);
X break;
X case Bottom:
X for (l = 0; l < Lim(pnode); l++) {
X switch (it) {
X case Tt:
X case Kt:
X release(Ascval(Pbitm(pnode, l, iw)));
X case Lt:
X release(Keyval(Pbitm(pnode, l, iw)));
X }
X }
X break;
X case Irange:
X case Crange:
X release(Lwbval(pnode));
X release(Upbval(pnode));
X break;
X default:
X syserr(MESS(402, "wrong flag in relbtree()"));
X }
X freemem((ptr) pnode);
X }
X}
X
END_OF_FILE
if test 3536 -ne `wc -c <'abc/btr/i1btr.c'`; then
echo shar: \"'abc/btr/i1btr.c'\" unpacked with wrong size!
fi
# end of 'abc/btr/i1btr.c'
fi
if test -f 'abc/lin/i1tex.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/lin/i1tex.c'\"
else
echo shar: Extracting \"'abc/lin/i1tex.c'\" \(3957 characters\)
sed "s/^X//" >'abc/lin/i1tex.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* B texts */
X
X#include "b.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "i1tlt.h"
X
X#define CURTAIL_TEX MESS(200, "in t|n, t is not a text")
X#define CURTAIL_NUM MESS(201, "in t|n, n is not a number")
X#define CURTAIL_INT MESS(202, "in t|n, n is not an integer")
X#define CURTAIL_BND MESS(203, "in t|n, n is < 0")
X
X#define BEHEAD_TEX MESS(204, "in t at n, t is not a text")
X#define BEHEAD_NUM MESS(205, "in t at n, n is not a number")
X#define BEHEAD_INT MESS(206, "in t at n, n is not an integer")
X#define BEHEAD_BND MESS(207, "in t at n, n is > #t + 1")
X
X#define CONCAT_TEX MESS(208, "in t^u, t or u is not a text")
X#define CONCAT_LONG MESS(209, "in t^u, the result is too long")
X
X#define REPEAT_TEX MESS(210, "in t^^n, t is not a text")
X#define REPEAT_NUM MESS(211, "in t^^n, n is not a number")
X#define REPEAT_INT MESS(212, "in t^^n, n is not an integer")
X#define REPEAT_NEG MESS(213, "in t^^n, n is negative")
X#define REPEAT_LONG MESS(214, "in t^^n, the result is too long")
X
XVisible value mk_text(m) string m; {
X value v; intlet len= strlen(m);
X v= grab(Tex, len);
X strcpy(Str(v), m);
X return v;
X}
X
XVisible bool character(v) value v; {
X if (Is_text(v) && Length(v) == 1) return Yes;
X else return No;
X}
X
XVisible char charval(v) value v; {
X if (!Is_text(v) || Length(v) != 1)
X interr(MESS(215, "value not a character"));
X return *Str(v);
X}
X
XVisible char ncharval(n, v) int n; value v; {
X return *(Str(v)+n-1);
X}
X
XVisible string strval(v) value v; {
X return Str(v);
X}
X
XVisible string sstrval(v) value v; {
X return savestr((string) Str(v));
X}
X
XVisible Procedure fstrval(s) string s; {
X freestr(s);
X}
X
XVisible value concat(s, t) value s, t; {
X if (Type(s) != Tex || Type(t) != Tex)
X interr(CONCAT_TEX);
X else {
X value c= grab(Tex, Length(s)+Length(t));
X strcpy(Str(c), Str(s)); strcpy(Str(c)+Length(s), Str(t));
X return c;
X }
X return grab(Tex, 0);
X}
X
XVisible Procedure concato(s, t) value *s, t; {
X value v= *s;
X *s= concat(*s, t);
X release(v);
X}
X
XVisible value icurtail(v, k) value v; int k; {
X if (k >= Length(v))
X return copy(v);
X else {
X value w= grab(Tex, k);
X strncpy(Str(w), Str(v), k);
X *(Str(w) + k)= '\0';
X return w;
X }
X}
X
XVisible value curtail(v, n) value v, n; {
X if (!Is_text(v))
X interr(CURTAIL_TEX);
X else if (!Is_number(n))
X interr(CURTAIL_NUM);
X else if (!integral(n))
X interr(CURTAIL_INT);
X else {
X intlet k= intval(n);
X if (k < 0) interr(CURTAIL_BND);
X else return icurtail(v, k);
X }
X return grab(Tex, 0);
X}
X
XVisible value ibehead(v, k) value v; int k; {
X if (k <= 1)
X return copy(v);
X else {
X value w= grab(Tex, Length(v) - (k - 1));
X strcpy(Str(w), Str(v) + k - 1);
X return w;
X }
X}
X
XVisible value behead(v, n) value v, n; {
X if (!Is_text(v))
X interr(BEHEAD_TEX);
X else if (!Is_number(n))
X interr(BEHEAD_NUM);
X else if (!integral(n))
X interr(BEHEAD_INT);
X else {
X intlet b= intval(n);
X if (b > Length(v) + 1) interr(BEHEAD_BND);
X else return ibehead(v, b);
X }
X return grab(Tex, 0);
X}
X
XVisible value repeat(x, y) value x, y; {
X intlet i;
X if (Type(x) != Tex) {
X interr(REPEAT_TEX);
X return grab(Tex, 0);
X }
X if (!Is_number(y)) {
X interr(REPEAT_NUM);
X return grab(Tex, 0);
X }
X i= propintlet(intval(y));
X if (i < 0)
X interr(REPEAT_NEG);
X else {
X value r; string xp, rp; intlet p, q, xl= Length(x);
X intlet ixl= propintlet(i*xl);
X#ifdef IBMPC
X bool enough_space();
X if (!enough_space(Tex, ixl)) {
X interr(REPEAT_LONG);
X return grab(Tex, 0);
X }
X#endif
X r= grab(Tex, ixl);
X rp= Str(r);
X for (p= 0; p < i; p++) {
X xp= Str(x);
X for (q= 0; q < xl; q++) *rp++= *xp++;
X }
X *rp= '\0';
X return r;
X }
X return grab(Tex, 0);
X}
X
XVisible Procedure wrtext(putch, v, quote) int (*putch)(); value v; char quote; {
X char c; int k, len= Length(v);
X if (quote) (*putch)(quote);
X for (k=0; k<len && still_ok; k++) {
X c= ncharval(k+1, v);
X (*putch)(c);
X if (quote && (c == quote || c == '`'))
X (*putch)(c);
X }
X if (quote) (*putch)(quote);
X}
END_OF_FILE
if test 3957 -ne `wc -c <'abc/lin/i1tex.c'`; then
echo shar: \"'abc/lin/i1tex.c'\" unpacked with wrong size!
fi
# end of 'abc/lin/i1tex.c'
fi
if test -f 'abc/tc/tgoto.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/tc/tgoto.c'\"
else
echo shar: Extracting \"'abc/tc/tgoto.c'\" \(3539 characters\)
sed "s/^X//" >'abc/tc/tgoto.c' <<'END_OF_FILE'
X#define CTRL(c) ('c' & 037)
X
X#define MAXRETURNSIZE 64
X
Xchar *UP;
Xchar *BC;
X
X/*
X * Routine to perform cursor addressing.
X * CM is a string containing printf type escapes to allow
X * cursor addressing. We start out ready to print the destination
X * line, and switch each time we print row or column.
X * The following escapes are defined for substituting row/column:
X *
X * %d as in printf
X * %2 like %2d
X * %3 like %3d
X * %. gives %c hacking special case characters
X * %+x like %c but adding x first
X *
X * The codes below affect the state but don't use up a value.
X *
X * %>xy if value > x add y
X * %r reverses row/column
X * %i increments row/column (for one origin indexing)
X * %% gives %
X * %B BCD (2 decimal digits encoded in one byte)
X * %D Delta Data (backwards bcd)
X *
X * all other characters are ``self-inserting''.
X */
Xchar *
Xtgoto(CM, destcol, destline)
X char *CM;
X int destcol, destline;
X{
X static char result[MAXRETURNSIZE];
X static char added[10];
X char *cp = CM;
X register char *dp = result;
X register int c;
X int oncol = 0;
X register int which = destline;
X
X if (cp == 0) {
Xtoohard:
X /*
X * ``We don't do that under BOZO's big top''
X */
X return ("OOPS");
X }
X added[0] = 0;
X while (c = *cp++) {
X if (c != '%') {
X *dp++ = c;
X continue;
X }
X switch (c = *cp++) {
X
X#ifdef CM_N
X case 'n':
X destcol ^= 0140;
X destline ^= 0140;
X goto setwhich;
X#endif
X
X case 'd':
X if (which < 10)
X goto one;
X if (which < 100)
X goto two;
X /* fall into... */
X
X case '3':
X *dp++ = (which / 100) | '0';
X which %= 100;
X /* fall into... */
X
X case '2':
Xtwo:
X *dp++ = which / 10 | '0';
Xone:
X *dp++ = which % 10 | '0';
Xswap:
X oncol = 1 - oncol;
Xsetwhich:
X which = oncol ? destcol : destline;
X continue;
X
X#ifdef CM_GT
X case '>':
X if (which > *cp++)
X which += *cp++;
X else
X cp++;
X continue;
X#endif
X
X case '+':
X which += *cp++;
X /* fall into... */
X
X case '.':
Xcasedot:
X /*
X * This code is worth scratching your head at for a
X * while. The idea is that various weird things can
X * happen to nulls, EOT's, tabs, and newlines by the
X * tty driver, arpanet, and so on, so we don't send
X * them if we can help it.
X *
X * Tab is taken out to get Ann Arbors to work, otherwise
X * when they go to column 9 we increment which is wrong
X * because bcd isn't continuous. We should take out
X * the rest too, or run the thing through more than
X * once until it doesn't make any of these, but that
X * would make termlib (and hence pdp-11 ex) bigger,
X * and also somewhat slower. This requires all
X * programs which use termlib to stty tabs so they
X * don't get expanded. They should do this anyway
X * because some terminals use ^I for other things,
X * like nondestructive space.
X */
X if (which == 0 || which == CTRL(d) || /* which == '\t' || */ which == '\n') {
X if (oncol || UP) /* Assumption: backspace works */
X /*
X * Loop needed because newline happens
X * to be the successor of tab.
X */
X do {
X strcat(added, oncol ? (BC ? BC : "\b") : UP);
X which++;
X } while (which == '\n');
X }
X *dp++ = which;
X goto swap;
X
X case 'r':
X oncol = 1;
X goto setwhich;
X
X case 'i':
X destcol++;
X destline++;
X which++;
X continue;
X
X case '%':
X *dp++ = c;
X continue;
X
X#ifdef CM_B
X case 'B':
X which = (which/10 << 4) + which%10;
X continue;
X#endif
X
X#ifdef CM_D
X case 'D':
X which = which - 2 * (which%16);
X continue;
X#endif
X
X default:
X goto toohard;
X }
X }
X strcpy(dp, added);
X return (result);
X}
END_OF_FILE
if test 3539 -ne `wc -c <'abc/tc/tgoto.c'`; then
echo shar: \"'abc/tc/tgoto.c'\" unpacked with wrong size!
fi
# end of 'abc/tc/tgoto.c'
fi
if test -f 'abc/ukeys/abckeys_924' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/ukeys/abckeys_924'\"
else
echo shar: Extracting \"'abc/ukeys/abckeys_924'\" \(1720 characters\)
sed "s/^X//" >'abc/ukeys/abckeys_924' <<'END_OF_FILE'
X# B key definitions file for Televideo 924.
X#
X# reprogram left arrow as different from BACKSPACE, then rebind LEFT and UNDO
X[term_init] = "\e0C\eKL" = ""
X[term_done] = "\e0C\b\200\200" = ""
X[left] = "\eKL" = "Left-Arrow"
X[undo] = "\b" = "BACKSPACE"
X
X# Define the other arrow keys if not already defined by termcap
X[down] = "\026" = "Down-Arrow"
X[up] = "\013" = "Up-Arrow"
X[right] = "\014" = "Right-Arrow"
X# this last ones overwrites REDRAW; so REDRAW goes to CLEAR/HOME key
X# (unshifted: ^^; shifted is ^Z, so impossible to catch)
X[look] = "\036" = "CLEAR/HOME"
X
X# Unshifted function keys send ^A @ ^M, ^A A ^M through ^A O ^M
X
X[widen] = "\001@\015" = "F1"
X[extend] = "\001A\015" = "F2"
X[first] = "\001B\015" = "F3"
X[last] = "\001C\015" = "F4"
X[previous] = "\001D\015" = "F5"
X[next] = "\001E\015" = "F6"
X[upline] = "\001F\015" = "f7"
X[downline] = "\001G\015" = "f8"
X[copy] = "\001H\015" = "F9"
X[delete] = "\001I\015" = "F10"
X[record] = "\001J\015" = "F11"
X[playback] = "\001K\015" = "F12"
X[ignore] = "\001L\015" = "F13"
X[look] = "\001M\015" = "F14"
X[help] = "\001N\015" = "F15"
X[redo] = "\001O\015" = "F16"
X
X# Shifted function keys send ^A ` ^M through ^A o ^M
X
X[ignore] = "\001`\015" = ""
X[ignore] = "\001a\015" = ""
X[ignore] = "\001b\015" = ""
X[ignore] = "\001c\015" = ""
X[ignore] = "\001d\015" = ""
X[ignore] = "\001e\015" = ""
X[ignore] = "\001f\015" = ""
X[ignore] = "\001g\015" = ""
X[ignore] = "\001h\015" = ""
X[ignore] = "\001i\015" = ""
X[ignore] = "\001j\015" = ""
X[ignore] = "\001k\015" = ""
X[ignore] = "\001l\015" = ""
X[ignore] = "\001m\015" = ""
X[ignore] = "\001n\015" = ""
X[ignore] = "\001o\015" = ""
X
X# unbind GOTO operation
X[ignore] = "\033g" = ""
X[ignore] = "\007" = ""
END_OF_FILE
if test 1720 -ne `wc -c <'abc/ukeys/abckeys_924'`; then
echo shar: \"'abc/ukeys/abckeys_924'\" unpacked with wrong size!
fi
# end of 'abc/ukeys/abckeys_924'
fi
echo shar: End of archive 21 \(of 25\).
cp /dev/null ark21isdone
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