rsalz@bbn.com (Rich Salz) (12/20/90)
Submitted-by: Steven Pemberton <steven@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@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@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@n, t is not a text") X#define BEHEAD_NUM MESS(205, "in t@n, n is not a number") X#define BEHEAD_INT MESS(206, "in t@n, n is not an integer") X#define BEHEAD_BND MESS(207, "in t@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@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.