v23i080: ABC interactive programming environment, Part01/25
Rich Salz
rsalz at bbn.com
Tue Dec 18 05:34:13 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 80
Archive-name: abc/part01
This is a posting of an implementation of ABC, a new interactive
programming language. Versions for Unix, the Atari ST, the Macintosh,
and MS-DOS are being posted this week to the net.
ABC is an imperative language originally designed as a replacement for
BASIC: interactive, very easy to learn, but structured, high-level,
and easy to use.
It is suitable for general everyday programming, the sort of
programming that you would use BASIC, Pascal, or AWK for. It is not a
systems-programming language. It is an excellent teaching language,
and because it is interactive, excellent for prototyping. It is much
faster than 'bc' for doing quick calculations.
ABC programs are typically very compact, around a quarter to a fifth
the size of the equivalent Pascal or C program. However, this is not
at the cost of readability, on the contrary in fact.
ABC is simple to learn due to the small number of types in the
language (five). If you already know Pascal or something similar you
can learn the whole language in an hour or so. It is easy to use
because the data-types are very high-level.
Fuller documentation, including examples, is in the file abcintro.doc
#! /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: MANIFEST abc abc/b abc/bed abc/bhdrs abc/bint1 abc/bint2
# abc/bint3 abc/bint3/i3sou.c abc/bio abc/boot abc/btr abc/doc
# abc/ehdrs abc/ex abc/ex/generate abc/ex/hanoi abc/ex/pi abc/ex/try
# abc/ex/xref abc/ihdrs abc/keys abc/lin abc/lin/i1obj.c abc/scripts
# abc/stc abc/tc abc/uhdrs abc/ukeys abc/unix
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:27:50 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 1 (of 25)."'
if test -f 'MANIFEST' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'MANIFEST'\"
else
echo shar: Extracting \"'MANIFEST'\" \(8839 characters\)
sed "s/^X//" >'MANIFEST' <<'END_OF_FILE'
X File Name Archive # Description
X----------------------------------------------------------
XMANIFEST 1
Xabc 1
Xabc/Makefile.unix 12
Xabc/Problems 11
Xabc/README 23
Xabc/README2 23
Xabc/Setup 9
Xabc/abc.1 4
Xabc/abc.hlp 7
Xabc/abc.msg 10
Xabc/b 1
Xabc/b/DEP 24
Xabc/b/MF 25
Xabc/b/b1file.c 23
Xabc/b/b1grab.c 21
Xabc/b/b1memo.c 22
Xabc/b/b1mess.c 22
Xabc/b/b1outp.c 21
Xabc/b/getopt.c 23
Xabc/bed 1
Xabc/bed/DEP 15
Xabc/bed/MF 25
Xabc/bed/e1cell.c 18
Xabc/bed/e1code.c 24
Xabc/bed/e1comm.c 21
Xabc/bed/e1deco.c 11
Xabc/bed/e1edit.c 19
Xabc/bed/e1edoc.c 10
Xabc/bed/e1erro.c 20
Xabc/bed/e1eval.c 20
Xabc/bed/e1getc.c 8
Xabc/bed/e1goto.c 19
Xabc/bed/e1gram.c 18
Xabc/bed/e1ins2.c 18
Xabc/bed/e1inse.c 17
Xabc/bed/e1lexi.c 24
Xabc/bed/e1line.c 20
Xabc/bed/e1move.c 17
Xabc/bed/e1node.c 14
Xabc/bed/e1outp.c 17
Xabc/bed/e1que1.c 13
Xabc/bed/e1que2.c 6
Xabc/bed/e1save.c 23
Xabc/bed/e1scrn.c 14
Xabc/bed/e1spos.c 21
Xabc/bed/e1sugg.c 9
Xabc/bed/e1supr.c 8
Xabc/bed/e1tabl.c 4
Xabc/bed/e1term.c 25
Xabc/bed/e1wide.c 19
Xabc/bhdrs 1
Xabc/bhdrs/b.h 22
Xabc/bhdrs/b0lan.h 22
Xabc/bhdrs/bcom.h 25
Xabc/bhdrs/bedi.h 24
Xabc/bhdrs/bfil.h 24
Xabc/bhdrs/bgfx.h 25
Xabc/bhdrs/bmem.h 25
Xabc/bhdrs/bobj.h 21
Xabc/bhdrs/getopt.h 25
Xabc/bhdrs/release.h 25
Xabc/bint1 1
Xabc/bint1/DEP 13
Xabc/bint1/MF 25
Xabc/bint1/i1fun.c 10
Xabc/bint1/i1nua.c 14
Xabc/bint1/i1nuc.c 16
Xabc/bint1/i1nug.c 18
Xabc/bint1/i1nui.c 17
Xabc/bint1/i1num.c 2
Xabc/bint1/i1nur.c 20
Xabc/bint1/i1nut.c 22
Xabc/bint2 1
Xabc/bint2/DEP 22
Xabc/bint2/MF 25
Xabc/bint2/i2ana.c 16
Xabc/bint2/i2cmd.c 15
Xabc/bint2/i2dis.c 19
Xabc/bint2/i2exp.c 9
Xabc/bint2/i2fix.c 21
Xabc/bint2/i2gen.c 7
Xabc/bint2/i2syn.c 11
Xabc/bint2/i2tar.c 24
Xabc/bint2/i2tes.c 21
Xabc/bint2/i2uni.c 15
Xabc/bint3 1
Xabc/bint3/MF 25
Xabc/bint3/i3bws.c 7
Xabc/bint3/i3com.c 22
Xabc/bint3/i3env.c 21
Xabc/bint3/i3err.c 16
Xabc/bint3/i3fil.c 20
Xabc/bint3/i3fpr.c 18
Xabc/bint3/i3gfx.c 17
Xabc/bint3/i3imm.c 22
Xabc/bint3/i3in2.c 22
Xabc/bint3/i3ini.c 22
Xabc/bint3/i3int.c 15
Xabc/bint3/i3loc.c 13
Xabc/bint3/i3scr.c 13
Xabc/bint3/i3sou.c 1
Xabc/bint3/i3sta.c 8
Xabc/bint3/i3typ.c 19
Xabc/bio 1
Xabc/bio/DEP 5
Xabc/bio/MF 25
Xabc/bio/i4bio.c 24
Xabc/bio/i4bio.h 24
Xabc/bio/i4fil.c 20
Xabc/bio/i4grp.c 23
Xabc/bio/i4inp.c 25
Xabc/bio/i4lis.c 25
Xabc/bio/i4out.c 24
Xabc/bio/i4rec.c 19
Xabc/boot 1
Xabc/boot/Makefile 20
Xabc/boot/Makefile.bsd 23
Xabc/boot/README 23
Xabc/boot/alloc.c 25
Xabc/boot/comp.c 21
Xabc/boot/dump.c 6
Xabc/boot/grammar.abc 12
Xabc/boot/lang.h 24
Xabc/boot/main.h 22
Xabc/boot/read.c 11
Xabc/btr 1
Xabc/btr/DEP 23
Xabc/btr/MF 25
Xabc/btr/e1etex.c 24
Xabc/btr/etex.h 25
Xabc/btr/i1btr.c 21
Xabc/btr/i1btr.h 19
Xabc/btr/i1lta.c 5
Xabc/btr/i1obj.c 14
Xabc/btr/i1tex.c 12
Xabc/btr/i1tlt.c 14
Xabc/btr/i1tlt.h 25
Xabc/ch_all 24
Xabc/ch_clean 25
Xabc/ch_config 10
Xabc/ch_depend 25
Xabc/ch_install 24
Xabc/ch_makefiles 25
Xabc/ch_messages 24
Xabc/doc 1
Xabc/doc/ABCproject 23
Xabc/doc/BugReport 24
Xabc/doc/Structure 24
Xabc/doc/abcintro.doc 16
Xabc/ehdrs 1
Xabc/ehdrs/cell.h 24
Xabc/ehdrs/code.h 25
Xabc/ehdrs/erro.h 24
Xabc/ehdrs/getc.h 23
Xabc/ehdrs/gram.h 25
Xabc/ehdrs/keys.h 22
Xabc/ehdrs/node.h 22
Xabc/ehdrs/queu.h 25
Xabc/ehdrs/supr.h 23
Xabc/ehdrs/tabl.h 15
Xabc/ehdrs/trm.h 24
Xabc/ex 1
Xabc/ex/DoExamples 25
Xabc/ex/README 24
Xabc/ex/TryEditor 24
Xabc/ex/generate 1
Xabc/ex/generate.in 25
Xabc/ex/generate.out 24
Xabc/ex/generate/analyze.cmd 25
Xabc/ex/generate/enders.cts 25
Xabc/ex/generate/fill.cmd 25
Xabc/ex/generate/follower.cts 23
Xabc/ex/generate/generate.cmd 25
Xabc/ex/generate/perm.abc 25
Xabc/ex/generate/start.cmd 25
Xabc/ex/generate/starters.cts 25
Xabc/ex/generate/suggest.abc 25
Xabc/ex/hanoi 1
Xabc/ex/hanoi.in 25
Xabc/ex/hanoi.out 25
Xabc/ex/hanoi/hanoi.cmd 25
Xabc/ex/hanoi/perm.abc 25
Xabc/ex/hanoi/suggest.abc 2
Xabc/ex/pi 1
Xabc/ex/pi.in 25
Xabc/ex/pi.out 25
Xabc/ex/pi/perm.abc 25
Xabc/ex/pi/pi.cmd 25
Xabc/ex/pi/suggest.abc 25
Xabc/ex/try 1
Xabc/ex/try/analyze.cmd 25
Xabc/ex/try/enders.cts 25
Xabc/ex/try/fill.cmd 25
Xabc/ex/try/follower.cts 23
Xabc/ex/try/generate.cmd 25
Xabc/ex/try/perm.abc 25
Xabc/ex/try/position.abc 7
Xabc/ex/try/start.cmd 25
Xabc/ex/try/starters.cts 25
Xabc/ex/try/suggest.abc 25
Xabc/ex/wsgroup.abc 4
Xabc/ex/xref 1
Xabc/ex/xref.in 25
Xabc/ex/xref.out 25
Xabc/ex/xref/alphabet.mpd 25
Xabc/ex/xref/output.cmd 25
Xabc/ex/xref/perm.abc 25
Xabc/ex/xref/save.cmd 25
Xabc/ex/xref/suggest.abc 25
Xabc/ex/xref/text.cts 25
Xabc/ex/xref/words.mfd 25
Xabc/ex/xref/xref.cmd 25
Xabc/ex/xref/xtab.cts 25
Xabc/ihdrs 1
Xabc/ihdrs/i0err.h 23
Xabc/ihdrs/i1num.h 20
Xabc/ihdrs/i2exp.h 24
Xabc/ihdrs/i2gen.h 25
Xabc/ihdrs/i2nod.h 18
Xabc/ihdrs/i2par.h 16
Xabc/ihdrs/i3bws.h 25
Xabc/ihdrs/i3env.h 24
Xabc/ihdrs/i3in2.h 25
Xabc/ihdrs/i3int.h 24
Xabc/ihdrs/i3scr.h 25
Xabc/ihdrs/i3sou.h 23
Xabc/ihdrs/i3sta.h 25
Xabc/ihdrs/i3typ.h 25
Xabc/keys 1
Xabc/keys/DEP 22
Xabc/keys/Makefile 23
Xabc/keys/keydef.c 3
Xabc/keys/keydef.h 23
Xabc/keys/keyhlp.c 20
Xabc/lin 1
Xabc/lin/etex.h 25
Xabc/lin/i1lta.c 16
Xabc/lin/i1obj.c 1
Xabc/lin/i1tex.c 21
Xabc/lin/i1tlt.c 12
Xabc/lin/i1tlt.h 17
Xabc/mkconfig.c 13
Xabc/scripts 1
Xabc/scripts/Change 24
Xabc/scripts/Collect 24
Xabc/scripts/mkdep.gen 9
Xabc/stc 1
Xabc/stc/DEP 24
Xabc/stc/MF 25
Xabc/stc/i2stc.h 22
Xabc/stc/i2tca.c 3
Xabc/stc/i2tce.c 17
Xabc/stc/i2tcp.c 18
Xabc/stc/i2tcu.c 20
Xabc/tc 1
Xabc/tc/Makefile 24
Xabc/tc/README 23
Xabc/tc/tc1.c 25
Xabc/tc/tc2.c 24
Xabc/tc/tc3.c 23
Xabc/tc/termcap 6
Xabc/tc/termcap.5 5
Xabc/tc/termcap.c 19
Xabc/tc/tgoto.c 21
Xabc/tc/tputs.c 22
Xabc/uhdrs 1
Xabc/uhdrs/args.h 25
Xabc/uhdrs/conf.h 24
Xabc/uhdrs/defs.h 25
Xabc/uhdrs/dir.h 24
Xabc/uhdrs/feat.h 23
Xabc/uhdrs/os.h.gen 23
Xabc/uhdrs/osconf.h 25
Xabc/ukeys 1
Xabc/ukeys/abckeys_2621 24
Xabc/ukeys/abckeys_2640b 25
Xabc/ukeys/abckeys_5620 24
Xabc/ukeys/abckeys_5620-2 24
Xabc/ukeys/abckeys_5620-e 24
Xabc/ukeys/abckeys_924 21
Xabc/ukeys/abckeys_adm31 24
Xabc/unix 1
Xabc/unix/DEP 23
Xabc/unix/MF 25
Xabc/unix/u1dir.c 23
Xabc/unix/u1edit.c 24
Xabc/unix/u1file.c 20
Xabc/unix/u1keys.c 15
Xabc/unix/u1os.c 24
Xabc/unix/u1time.c 23
Xabc/unix/u1trm.c 2
END_OF_FILE
if test 8839 -ne `wc -c <'MANIFEST'`; then
echo shar: \"'MANIFEST'\" unpacked with wrong size!
fi
# end of 'MANIFEST'
fi
if test ! -d 'abc' ; then
echo shar: Creating directory \"'abc'\"
mkdir 'abc'
fi
if test ! -d 'abc/b' ; then
echo shar: Creating directory \"'abc/b'\"
mkdir 'abc/b'
fi
if test ! -d 'abc/bed' ; then
echo shar: Creating directory \"'abc/bed'\"
mkdir 'abc/bed'
fi
if test ! -d 'abc/bhdrs' ; then
echo shar: Creating directory \"'abc/bhdrs'\"
mkdir 'abc/bhdrs'
fi
if test ! -d 'abc/bint1' ; then
echo shar: Creating directory \"'abc/bint1'\"
mkdir 'abc/bint1'
fi
if test ! -d 'abc/bint2' ; then
echo shar: Creating directory \"'abc/bint2'\"
mkdir 'abc/bint2'
fi
if test ! -d 'abc/bint3' ; then
echo shar: Creating directory \"'abc/bint3'\"
mkdir 'abc/bint3'
fi
if test -f 'abc/bint3/i3sou.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3sou.c'\"
else
echo shar: Extracting \"'abc/bint3/i3sou.c'\" \(29957 characters\)
sed "s/^X//" >'abc/bint3/i3sou.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Sources: maintaining units and values on external files */
X
X#include "b.h"
X#include "bint.h"
X#include "feat.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "bfil.h"
X#include "i2par.h"
X#include "i2nod.h"
X#include "i3env.h"
X#include "i3scr.h"
X#include "i3in2.h"
X#include "i3sou.h"
X
X#ifdef TYPE_CHECK
Xvalue stc_code();
X#endif
X#ifdef unix
X#define CK_WS_WRITABLE
X#endif
X
XVisible value b_perm= Vnil;
X /* The table that maps tags to their file names */
XVisible value b_units= Vnil;
X /* The table that maps tags to their internal repr. */
X
X#define Is_filed(v) (Is_indirect(v))
X
X#define t_exists(name, aa) (in_env(prmnv->tab, name, aa))
X
XVisible Procedure def_target(name, t) value name, t; {
X e_replace(t, &prmnv->tab, name);
X}
X
X#define free_target(name) (e_delete(&prmnv->tab, name))
X
X/************************** UNITS ************************************/
X
X#define Is_funprd(u) (Is_function(u) || Is_predicate(u))
X#define Is_predefined(u) (Is_funprd(u) && Funprd(u)->pre != Use)
X
X#define USR_ALL '1'
X#define USR_PARSED '2'
X
XHidden Procedure freeunits(which) literal which; {
X intlet k, len;
X value vkey, vassoc;
X
X len= length(b_units);
X for (k= len-1; k >= 0; --k) {
X /* Reverse loop so deletions don't affect the numbering! */
X vkey= *key(b_units, k);
X vassoc= *assoc(b_units, k);
X switch (which) {
X case USR_ALL:
X if (!Is_predefined(vassoc)) free_unit(vkey);
X break;
X case USR_PARSED:
X if (!Is_predefined(vassoc) &&
X !How_to(vassoc)->unparsed)
X free_unit(vkey);
X break;
X }
X }
X}
X
XVisible Procedure rem_unit(u) parsetree u; {
X value pname= get_pname(u);
X free_unit(pname);
X release(pname);
X}
X
X/********************************************************************** */
X
XVisible value permkey(name, type) value name; literal type; {
X char t[2];
X value v, w;
X
X if (!Valid(name))
X return Vnil;
X t[0]= type; t[1]= '\0';
X w= mk_text(t);
X v= concat(w, name); release(w);
X return v;
X}
X
XVisible string lastunitname() {
X value *aa;
X
X if (p_exists(last_unit, &aa))
X return sstrval(Permname(*aa));
X return NULL;
X}
X
X#define CANTGETFNAME MESS(4000, "cannot create file name for %s")
X
XHidden value get_ufname(pname, silently) value pname; bool silently; {
X value fname;
X value *aa;
X
X if (p_exists(pname, &aa))
X fname= copy(*aa);
X else {
X value name= Permname(pname);
X literal type= Permtype(pname);
X
X fname= new_fname(name, type);
X if (Valid(fname))
X def_perm(pname, fname);
X else if (!silently)
X interrV(CANTGETFNAME, name);
X release(name);
X }
X return fname;
X}
X
XHidden bool p_version(name, type, pname) value name, *pname; literal type; {
X value *aa;
X *pname= permkey(name, type);
X if (p_exists(*pname, &aa)) return Yes;
X release(*pname); *pname= Vnil;
X return No;
X}
X
XHidden bool u_version(name, type, pname) value name, *pname; literal type; {
X value *aa;
X *pname= permkey(name, type);
X if (u_exists(*pname, &aa)) return Yes;
X release(*pname); *pname= Vnil;
X return No;
X}
X
XHidden bool tar_version(name, pname) value name, *pname; {
X value *aa;
X if (p_version(name, Tar, pname))
X return Yes;
X else if (t_exists(name, &aa)) {
X *pname= permkey(name, Tar);
X return Yes;
X }
X else return No;
X}
X
XHidden Procedure del_perm(pname) value pname; {
X value *aa;
X if (p_exists(pname, &aa)) {
X f_delete(*aa);
X idelpos(*aa); /* delete file from positions file */
X free_perm(pname);
X }
X}
X
X/***********************************************************************/
X
XHidden bool is_loaded(pname, aa) value pname, **aa; {
X value u= Vnil, npname= Vnil, *a, get_unit();
X if (u_exists(pname, &a)) {
X if (Is_predefined(*a) && p_exists(pname, aa)) {
X /* loading userdefined over predefined */;
X }
X else {
X *aa= a;
X return Yes; /* already loaded */
X }
X }
X else if (!p_exists(pname, aa)) {
X return No;
X }
X ifile= fopen(strval(**aa), "r");
X if (ifile == NULL) {
X vs_ifile();
X return No;
X }
X Eof= No;
X first_ilev();
X u= get_unit(&npname, Yes, No);
X if (still_ok) def_unit(npname, u);
X fclose(ifile);
X vs_ifile();
X Eof= No;
X if (still_ok && !u_exists(pname, aa)) {
X value name= Permname(pname);;
X release(uname); uname= copy(pname);
X curline= How_to(u)->unit; curlino= one;
X interrV(MESS(4001, "filename and how-to name incompatible for %s"), name);
X release(name);
X }
X release(u); release(npname);
X return still_ok;
X}
X
X/* Does the unit exist without faults? */
X
XVisible bool is_unit(name, type, aa) value name, **aa; literal type; {
X value pname;
X context c; bool is;
X sv_context(&c);
X cntxt= In_unit;
X pname= permkey(name, type);
X is= is_loaded(pname, aa);
X release(pname);
X set_context(&c);
X return is;
X}
X
X/***********************************************************************/
X
X#define CANT_WRITE MESS(4002, "cannot create file %s; need write permission in directory")
X
X#define CANT_READ MESS(4003, "unable to find file")
X
XHidden Procedure u_name_type(v, name, type) parsetree v; value *name;
X literal *type; {
X intlet adic;
X switch (Nodetype(v)) {
X case HOW_TO: *type= Cmd; break;
X case YIELD: adic= intval(*Branch(v, FPR_ADICITY));
X *type= adic==0 ? Zfd : adic==1 ? Mfd : Dfd;
X break;
X case TEST: adic= intval(*Branch(v, FPR_ADICITY));
X *type= adic==0 ? Zpd : adic==1 ? Mpd : Dpd;
X break;
X default: syserr(MESS(4004, "wrong nodetype of how-to"));
X }
X *name= copy(*Branch(v, UNIT_NAME));
X}
X
XHidden value get_unit(pname, filed, editing) value *pname; bool filed, editing;
X{
X value name; literal type;
X parsetree u= unit(No, editing);
X if (u == NilTree)
X return Vnil;
X u_name_type(u, &name, &type);
X *pname= permkey(name, type);
X release(name);
X switch (Nodetype(u)) {
X case HOW_TO: return mk_how(u, filed);
X case YIELD: return mk_fun(type, Use, u, filed);
X case TEST: return mk_prd(type, Use, u, filed);
X default: return Vnil; /* Keep lint happy */
X }
X}
X
XVisible value get_pname(v) parsetree v; {
X value pname, name; literal type;
X u_name_type(v, &name, &type);
X pname= permkey(name, type);
X release(name);
X return pname;
X}
X
XHidden Procedure get_heading(h, pname) parsetree *h; value *pname; {
X *h= unit(Yes, No);
X *pname= still_ok ? get_pname(*h) : Vnil;
X}
X
X/********************************************************************** */
X
X/* Check for certain types of name conflicts.
X The checks made are:
X - unit with the same name
X - function and predicate with the same name (and different or same
X adicity)
X - function or predicate with the same name as a target
X - zeroadic and monadic unit with the same name
X - zeroadic and dyadic unit with the same name.
X*/
X
X#define CR_EXIST MESS(4005, "there is already a how-to with this name")
X
X#define CR_TAR MESS(4006, "there is already a permanent location with this name")
X
X#define ED_EXIST MESS(4007, "*** the how-to name is already in use;\n*** should the old how-to be discarded?\n*** (if not you have to change the how-to name)\n")
X
X#define ED_TAR MESS(4008, "*** the how-to name is already in use for a permanent location;\n*** should that location be deleted?\n*** (if not you have to change the how-to name)\n")
X
X/* name_conflict() is called if a unit is created (HOW TO ? : command) */
X
XHidden bool name_conflict(pname) value pname; {
X value npname;
X if (smash(pname, &npname)) {
X interr(Permtype(npname) == Tar ? CR_TAR : CR_EXIST);
X if (Permtype(pname) != Tar)
X def_perm(last_unit, npname);
X release(npname);
X return Yes;
X }
X return No;
X}
X
X/* name_clash() is called if a unit is edited through the ':' command */
X
XHidden bool name_clash(pname) value pname; {
X value npname;
X
X if (!Valid(pname))
X return No;
X while (smash(pname, &npname)) {
X if (!do_discard(npname)) {
X release(npname);
X return Yes;
X }
X /* continue: there can be both a monadic and a */
X /* dyadic version */
X release(npname); npname= Vnil;
X }
X return No;
X}
X
XHidden bool do_discard(pname) value pname; {
X bool istarg= Permtype(pname) == Tar;
X
X if (is_intended(istarg ? ED_TAR : ED_EXIST)) {
X if (istarg) {
X value name= Permname(pname);
X del_target(name);
X release(name);
X }
X else {
X free_unit(pname);
X del_perm(pname);
X }
X return Yes;
X }
X return No;
X}
X
XHidden bool smash(pname, npname) value pname, *npname; {
X value name, *aa;
X literal u_type, v_type;
X bool sm;
X
X if (p_exists(pname, &aa)) {
X *npname= copy(pname);
X return Yes;
X }
X u_type= Permtype(pname);
X if (u_type == Cmd) {
X *npname= Vnil;
X return No;
X }
X name= Permname(pname);
X sm= p_version(name, Zfd, npname) ||
X p_version(name, Mfd, npname) ||
X p_version(name, Dfd, npname) ||
X p_version(name, Zpd, npname) ||
X p_version(name, Mpd, npname) ||
X p_version(name, Dpd, npname) ||
X tar_version(name, npname);
X release(name);
X if (!sm) {
X release(*npname); *npname= Vnil;
X return No;
X }
X v_type= Permtype(*npname);
X switch (u_type) {
X case Mfd: sm= v_type != Dfd; break;
X case Dfd: sm= v_type != Mfd; break;
X case Mpd: sm= v_type != Dpd; break;
X case Dpd: sm= v_type != Mpd; break;
X default: sm= Yes; break;
X }
X if (!sm) {
X release(*npname); *npname= Vnil;
X return No;
X }
X return Yes;
X}
X
X/***********************************************************************/
X
X/* Create a unit via the editor or from the input stream. */
X
XVisible Procedure create_unit() {
X value pname= Vnil; parsetree heading= NilTree;
X if (!interactive) {
X value v= get_unit(&pname, No, No);
X if (still_ok) def_unit(pname, v);
X release(v); release(pname);
X return;
X }
X get_heading(&heading, &pname);
X curline= heading; curlino= one; /* For all error messages */
X if (still_ok && !name_conflict(pname)) {
X value fname= get_ufname(pname, No);
X
X if (Valid(fname)) {
X FILE *fp= fopen(strval(fname), "w");
X if (fp == NULL)
X interrV(CANT_WRITE, fname);
X else {
X txptr tp= fcol();
X do { fputc(Char(tp), fp); }
X while (Char(tp++) != '\n');
X fputc('\n', fp);
X f_close(fp);
X ed_unit(&pname, &fname, Yes);
X }
X }
X release(fname);
X }
X release(pname); release(heading);
X}
X
X
X/***********************************************************************/
X
X/* Edit a unit. The name of the unit is either given, or is defaulted
X to the last unit edited or the last unit that gave an error, whichever
X was most recent.
X It is possible for the user to mess things up with the w command, for
X instance, but this is not checked. It is allowed to rename the unit though,
X or delete it completely. If the file is empty, the unit is disposed of.
X Otherwise, the name and adicity are determined and if these have changed,
X the new unit is written out to a new file, and the original deleted.
X Thus the original is not saved.
X
X The function edit_unit parses the command line and does some
X high-level bookkeeping; ed_unit does the lower-level bookkeeping;
X f_edit is called to pass control to the editor and wait till it
X finishes its job. Note that the editor reads the unit from the file
X and writes it back (if changed); there is no sharing of data
X structures such as parse trees in this version of the system.
X
X Renaming, deleting, or changing the adicity of a test or yield
X unfortunately requires all other units to be thrown away internally
X (by freeunits), since the unit parse trees may be wrong. For instance,
X consider the effect on the following of making a formerly monadic
X function f, into a zeroadic function:
X WRITE f root 2
X*/
X
X#define CANT_EDIT MESS(4009, "I find nothing editible here")
X
XVisible value last_unit= Vnil;
X
XVisible Procedure edit_unit() {
X value name= Vnil, pname= Vnil;
X value fname, *aa;
X value which_funprd();
X char *kw;
X
X if (Ceol(tx)) {
X if (!p_exists(last_unit, &aa))
X parerr(MESS(4010, "no current how-to"));
X else pname= copy(*aa);
X }
X else if (is_cmdname(ceol, &kw)) {
X name= mk_text(kw);
X pname= permkey(name, Cmd);
X }
X else if (is_tag(&name))
X pname= which_funprd(name);
X else
X parerr(CANT_EDIT);
X
X if (still_ok && ens_filed(pname, &fname)) {
X ed_unit(&pname, &fname, No);
X release(fname);
X }
X release(name); release(pname);
X}
X
X#define ED_MONDYA MESS(4011, "*** do you want to visit the version with %c or %c operands?\n")
X#define ONE_PAR '1'
X#define TWO_PAR '2'
X
XHidden value which_funprd(name) value name; {
X /* There may be two units with the same name (functions
X or predicates of different adicity). Check if this
X is the case, and if so, ask which one is meant.
X */
X value pname, v= Vnil;
X char qans;
X
X if (p_version(name, Zfd, &pname) || p_version(name, Zpd, &pname))
X return pname;
X if (p_version(name, Mfd, &pname) || p_version(name, Mpd, &pname)) {
X if (p_version(name, Dfd, &v) || p_version(name, Dpd, &v)) {
X qans= q_answer(ED_MONDYA, ONE_PAR, TWO_PAR);
X if (qans == ONE_PAR) {
X release(v);
X return pname;
X }
X else if (qans == TWO_PAR) {
X release(pname);
X return copy(v);
X }
X else {
X /* interrupted */
X still_ok = No;
X return pname;
X }
X }
X else {
X release(v);
X return pname;
X }
X }
X if (p_version(name, Dfd, &pname))
X return pname;
X if (p_version(name, Dpd, &pname))
X return pname;
X
X /* be prepared to find at least one not-filed how-to;
X * this does not find all of them;
X * and it doesn't allow any conflicting with already existing ones.
X */
X
X if (u_version(name, Zfd, &pname) ||
X u_version(name, Mfd, &pname) ||
X u_version(name, Dfd, &pname) ||
X u_version(name, Zpd, &pname) ||
X u_version(name, Mpd, &pname) ||
X u_version(name, Dpd, &pname)
X )
X return pname;
X
X return permkey(name, Dpd);
X /* If it doesn't exist, ens_filed will complain. */
X}
X
X#define NO_U_WRITE MESS(4012, "*** you have no write permission in this workspace:\n*** you may not change the how-to\n*** do you still want to display the how-to?\n")
X
X/* Edit a unit. Parameters are the prmnv key and the file name.
X This is called in response to the ':' command and when a new unit is
X created (the header of the new unit must already be written to the
X file).
X Side effects are many, e.g. on prmnv: the unit may be deleted or
X renamed. When renamed, the original unit is lost.
X The unit is reparsed after editing. A check is made for illegal
X name conflicts (e.g., a zeroadic and a monadic unit of the same
X name), and this is resolved by forcing the user to edit the unit
X again. In that case the edit is done on a temporary file.
X The new unit name is kept as the current unit name; when the unit is
X deleted the current unit name is set to Vnil. */
X
XHidden bool clash;
X
X#define First_edit (!clash)
X
X#ifdef TYPE_CHECK
XHidden value old_typecode= Vnil;
X#define Sametypes(old, new) ((!Valid(old) && !Valid(new)) || \
X (Valid(old) && Valid(new) && compare(old, new) == 0))
X#endif
X
XHidden Procedure ed_unit(pname, fname, creating) value *pname, *fname;
X bool creating;
X{
X#ifdef CK_WS_WRITABLE
X if (!wsp_writable() && !is_intended(NO_U_WRITE)) return;
X#endif
X#ifdef CLEAR_MEM
X clear_perm();
X /* To give the editor as much space as possible, remove
X all parse trees and target values from memory.
X (targets that have been modified are first written
X out, of course).
X */
X#endif
X clash= No;
X#ifdef TYPE_CHECK
X old_typecode= stc_code(*pname);
X if (!creating) del_types();
X#endif
X do edunit(pname, fname, creating); while (clash);
X#ifdef SAVE_PERM
X put_perm(b_perm);
X#endif
X#ifdef TYPE_CHECK
X release(old_typecode);
X#endif
X}
X
XHidden Procedure edunit(p_pname, p_fname, creating) value *p_pname, *p_fname;
X bool creating; {
X value pname= *p_pname, fname= *p_fname;
X value npname= Vnil, u;
X bool new_def, changed, samehead;
X#ifdef TYPE_CHECK
X value new_typecode;
X#endif
X
X release(uname); uname= copy(pname);
X changed= f_edit(fname, err_line(pname), ':', creating && First_edit)
X || creating;
X errlino= 0;
X if (First_edit && !changed) {
X /* Remember it as current unit: */
X def_perm(last_unit, pname);
X#ifdef TYPE_CHECK
X if (!creating) adjust_types(Yes);
X#endif
X return;
X }
X if (!still_there(fname)) {
X free_original(pname);
X#ifdef TYPE_CHECK
X if (!creating) adjust_types(No);
X#endif
X idelpos(fname); /* delete file from positions file */
X free_perm(last_unit);
X clash= No;
X return;
X }
X first_ilev();
X u= get_unit(&npname, Yes, Yes);
X /* the second Yes means the user may edit the heading;
X * therefore no type check now in unit() */
X fclose(ifile); vs_ifile(); Eof= No;
X
X if (First_edit && same_heading(pname, npname, u)) {
X new_def= Yes;
X samehead= Yes;
X }
X else {
X samehead= No;
X free_original(pname);
X if (!name_clash(npname) && rnm_file(fname, npname))
X clash= No;
X else {
X /* edit again with npname and temp fname */
X release(*p_pname);
X *p_pname= copy(npname);
X if (First_edit) {
X value tfile= mk_text(temp1file);
X f_rename(fname, tfile);
X imovpos(fname, tfile);
X /* move position in positions file */
X release(*p_fname);
X *p_fname= tfile;
X }
X clash= Yes;
X }
X new_def= !clash;
X }
X if (new_def) {
X /* changed heading now def_perm()'ed, so now typecheck */
X#ifdef TYPE_CHECK
X type_check((Is_funprd(u) ? Funprd(u)->unit : How_to(u)->unit));
X new_typecode= stc_code(npname);
X if (!creating)
X adjust_types(samehead &&
X Sametypes(old_typecode, new_typecode));
X release(new_typecode);
X#endif
X if (still_ok) def_unit(npname, u);
X else free_unit(npname);
X def_perm(last_unit, npname);
X }
X release(npname); release(u);
X}
X
XHidden Procedure free_original(pname) value pname; {
X if (First_edit) {
X free_unit(pname);
X free_perm(pname);
X freeunits(USR_PARSED);
X }
X}
X
X#define cmd_unit(pname) (Permtype(pname) == Cmd)
X
XHidden bool same_heading(pname, npname, u_new) value pname, npname, u_new; {
X value *aa;
X
X if (!Valid(u_new) || !Valid(npname))
X return No;
X else if (compare(pname, npname) != 0)
X return No;
X else if (!cmd_unit(pname))
X return Yes;
X else if (!u_exists(pname, &aa))
X return Yes;
X else {
X parsetree old= How_to(*aa)->unit;
X parsetree new= How_to(u_new)->unit;
X parsetree old_kw, old_fml, old_next;
X parsetree new_kw, new_fml, new_next;
X
X old= *Branch(old, HOW_FORMALS);
X new= *Branch(new, HOW_FORMALS);
X do {
X old_kw= *Branch(old, FML_KEYW);
X old_fml= *Branch(old, FML_TAG);
X old_next= *Branch(old, FML_NEXT);
X new_kw= *Branch(new, FML_KEYW);
X new_fml= *Branch(new, FML_TAG);
X new_next= *Branch(new, FML_NEXT);
X
X if (compare(old_kw, new_kw) != 0)
X return No;
X else if (old_fml == NilTree && new_fml != NilTree)
X return No;
X else if (old_fml != NilTree && new_fml == NilTree)
X return No;
X else if (old_next == NilTree && new_next != NilTree)
X return No;
X else if (old_next != NilTree && new_next == NilTree)
X return No;
X old= old_next;
X new= new_next;
X }
X while (old != NilTree);
X return Yes;
X }
X}
X
X#define CANT_GET_FNAME MESS(4013, "*** cannot create file name;\n*** you have to change the how-to name\n")
X
XHidden bool rnm_file(fname, pname) value fname, pname; {
X value nfname;
X
X nfname= (Valid(pname) ? get_ufname(pname, Yes) : Vnil);
X
X if (Valid(nfname)) {
X f_rename(fname, nfname);
X imovpos(fname, nfname); /* move position in positions file */
X release(nfname);
X return Yes;
X }
X else {
X putmess(errfile, CANT_GET_FNAME);
X return No;
X }
X}
X
X/* Find out if the file exists, and is not empty. Some editors don't
X allow a file to be edited to empty, but insist it should be at least
X one empty line. Therefore, a file with one, empty, line is also
X considered empty.
X As a side effect, if the file is 'still there', ifile is set to it
X and it remains open, positioned at the beginning.
X (A previous version of this function would leave it positioned after
X an initial \n, if there was one; this version just rewinds the file.)
X */
X
XHidden bool still_there(fname) value fname; {
X int k;
X
X ifile= fopen(strval(fname), "r");
X if (ifile == NULL) {
X vs_ifile();
X return No;
X } else {
X if ((k= getc(ifile)) == EOF ||
X (k == '\n' && (k= getc(ifile)) == EOF)) {
X fclose(ifile);
X f_delete(fname);
X vs_ifile();
X return No;
X }
X rewind(ifile);
X return Yes;
X }
X}
X
X/* Ensure the unit is filed. If the unit was read non-interactively (eg passed
X as a parameter to abc), it is only held in store.
X Editing it puts it into a file. This is the safest way to copy a unit from
X one workspace to another.
X*/
X
X#define NO_HOWTO MESS(4014, "%s isn't a how-to in this workspace")
X
XHidden bool ens_filed(pname, fname) value pname, *fname; {
X value *aa;
X if (p_exists(pname, &aa)) {
X *fname= copy(*aa);
X return Yes;
X } else if (!u_exists(pname, &aa) || How_to(*aa)->unit == NilTree) {
X value name= Permname(pname);
X pprerrV(NO_HOWTO, name);
X release(name);
X return No;
X } else {
X how *du= How_to(*aa); FILE *fp;
X if (du->filed == Yes) {
X syserr(MESS(4015, "ens_filed()"));
X return No;
X }
X *fname= get_ufname(pname, No);
X if (!Valid(*fname))
X return No;
X fp= fopen(strval(*fname), "w");
X if (!fp) {
X interrV(CANT_WRITE, *fname);
X release(*fname);
X return No;
X } else {
X display(fp, du->unit, No);
X f_close(fp);
X du->filed= Yes;
X return Yes;
X }
X }
X}
X
XHidden int err_line(pname) value pname; {
X value *aa;
X if (!p_exists(last_unit, &aa) || compare(*aa, pname) != 0)
X return 0;
X else
X return errlino;
X}
X
X/************************** VALUES ***************************************/
X/* The permanent environment in the old format was kept as a single file */
X/* but this caused slow start ups if the file was big. */
X/* Thus the new version stores each permanent target on a separate file, */
X/* that furthermore is only loaded on demand. */
X/* To achieve this, a directory is kept of the permanent tags and their */
X/* file names. Care has to be taken that disaster occurring in */
X/* the middle of an update of this directory does the least harm. */
X/* Having the directory refer to a non-existent file is considered less */
X/* harmful than leaving a file around that can never be accessed, for */
X/* instance, so a file is deleted before its directory entry, */
X/* and so forth. */
X/*************************************************************************/
X
XVisible value errtname= Vnil;
X
XHidden Procedure tarfiled(name, v) value name, v; {
X value p= mk_indirect(v);
X def_target(name, p);
X release(p);
X}
X
XVisible value last_target= Vnil; /* last edited target */
X
XVisible Procedure del_target(name) value name; {
X value pname= permkey(name, Tar);
X value *aa;
X free_target(name);
X del_perm(pname);
X if (p_exists(last_target, &aa) && (compare(name, *aa) == 0))
X free_perm(last_target);
X release(pname);
X}
X
XHidden value get_tfname(name) value name; {
X value fname;
X value pname= permkey(name, Tar);
X value *aa;
X
X if (p_exists(pname, &aa))
X fname= copy(*aa);
X else {
X fname= new_fname(name, Tar);
X if (Valid(fname))
X def_perm(pname, fname);
X else
X interrV(CANTGETFNAME, name);
X }
X release(pname);
X return fname;
X}
X
XVisible Procedure edit_target() {
X value name= Vnil;
X value fname, *aa;
X if (Ceol(tx)) {
X if (!p_exists(last_target, &aa))
X parerr(MESS(4016, "no current location"));
X else
X name= copy(*aa);
X } else if (!is_tag(&name))
X parerr(CANT_EDIT);
X if (still_ok && ens_tfiled(name, &fname)) {
X ed_target(name, fname);
X release(fname);
X }
X release(name);
X}
X
X#define NO_T_WRITE MESS(4017, "*** you have no write permission in this workspace:\n*** you may not change the location\n*** do you still want to display the location?\n")
X
X/* Edit a target. The value in the target is written to the file,
X and then removed from the internal permanent environment so that
X if a syntax error occurs when reading the value back, the value is
X absent from the internal permanent environment.
X Thus when editing the file to correct the syntax error, the
X file doesn't get overwritten.
X The contents may be completely deleted in which case the target is
X deleted. */
X
XHidden Procedure ed_target(name, fname) value name, fname; {
X value v;
X
X#ifdef CK_WS_WRITABLE
X if (!wsp_writable() && !is_intended(NO_T_WRITE)) return;
X#endif
X#ifdef CLEAR_MEM
X clear_perm(); /* To give the editor as much space as possible */
X#endif
X def_perm(last_target, name);
X if (!f_edit(fname, 0, '=', No))
X /* File is unchanged */
X return;
X if (!still_there(fname)) {
X del_target(name);
X#ifdef SAVE_PERM
X put_perm(b_perm);
X#endif
X return;
X }
X fclose(ifile); /* Since still_there leaves it open */
X /* vs_ifile(); ? */
X v= getval(fname, In_edval);
X if (still_ok) def_target(name, v);
X release(v);
X}
X
X#define NO_TARGET MESS(4018, "%s isn't a location in this workspace")
X
XVisible bool ens_tfiled(name, fname) value name, *fname; {
X value *aa;
X if (!t_exists(name, &aa)) {
X pprerrV(NO_TARGET, name);
X return No;
X } else {
X *fname= get_tfname(name);
X if (!Valid(*fname))
X return No;
X if (!Is_filed(*aa)) {
X release(errtname); errtname= copy(name);
X putval(*fname, *aa, No, In_tarval);
X tarfiled(name, *aa);
X }
X return Yes;
X }
X}
X
X/***************************** Values on files ****************************/
X
XVisible value getval(fname, ct) value fname; literal ct; {
X char *buf; int k; parsetree w, code= NilTree; value v= Vnil;
X ifile= fopen(strval(fname), "r");
X if (ifile) {
X txptr fcol_save= first_col, tx_save= tx; context c;
X sv_context(&c);
X cntxt= ct;
X buf= (char *) getmem((unsigned)(f_size(ifile)+2)*sizeof(char));
X first_col= tx= ceol= buf;
X while ((k= getc(ifile)) != EOF)
X if (k != '\n') *ceol++= k;
X *ceol= '\n';
X fclose(ifile); vs_ifile();
X w= expr(ceol);
X if (still_ok) fix_nodes(&w, &code);
X curline= w; curlino= one;
X v= evalthread(code);
X if (!env_ok(v)) {
X release(v);
X v= Vnil;
X }
X curline= Vnil;
X release(w);
X freemem((ptr) buf);
X set_context(&c);
X first_col= fcol_save; tx= tx_save;
X } else {
X interr(CANT_READ);
X vs_ifile();
X }
X return v;
X}
X
XHidden bool env_ok(v) value v; {
X if (cntxt == In_prmnv || cntxt == In_wsgroup) {
X if (!Is_table(v)) {
X interr(MESS(4019, "value is not a table"));
X return No;
X }
X else if (!Is_ELT(v) && !Is_text(*key(v, 0))) {
X interr(MESS(4020, "in t[k], k is not a text"));
X return No;
X }
X }
X return Yes;
X}
X
XVisible bool permchanges;
X
XVisible Procedure initperm() {
X if (F_exists(permfile)) {
X value fn, name;
X intlet k, len;
X value v, pname;
X
X fn= mk_text(permfile);
X v= getval(fn, In_prmnv);
X release(fn);
X if (Valid(v)) {
X release(b_perm);
X b_perm= v;
X }
X len= length(b_perm);
X for (k= 0; k < len; k++) {
X pname= *key(b_perm, k);
X if (Permtype(pname) == Tar) {
X name= Permname(pname);
X tarfiled(name, Vnil);
X release(name);
X }
X }
X }
X permchanges= No;
X}
X
XVisible Procedure putval(fname, v, silently, ct) value fname, v;
X bool silently; literal ct; {
X value fn= copy(fname);
X FILE *fp;
X bool was_ok= still_ok;
X context c;
X
X sv_context(&c);
X cntxt= ct;
X curline= Vnil;
X curlino= one;
X#ifdef unix
X release(fn); fn= mk_text(tempfile);
X#endif
X fp= fopen(strval(fn), "w");
X if (fp != NULL) {
X redirect(fp);
X still_ok= Yes;
X wri(v, No, No, Yes); newline();
X f_close(fp);
X redirect(stdout);
X#ifdef unix
X if (still_ok) f_rename(fn, fname);
X#endif
X }
X else if (!silently) interrV(CANT_WRITE, fn);
X still_ok= was_ok;
X release(fn);
X set_context(&c);
X}
X
XVisible Procedure endperm() {
X static bool active;
X bool was_ok= still_ok;
X
X if (active)
X return;
X active= Yes;
X still_ok= Yes;
X put_targs();
X put_perm(b_perm);
X still_ok= was_ok;
X active= No;
X}
X
XHidden Procedure put_targs() {
X int k, len;
X value v, name;
X
X len= Valid(prmnv->tab) ? length(prmnv->tab) : 0;
X for (k= 0; k < len; k++) {
X v= copy(*assoc(prmnv->tab, k));
X name= copy(*key(prmnv->tab, k));
X if (!Is_filed(v)) {
X value fname= get_tfname(name);
X if (Valid(fname)) {
X release(errtname); errtname= copy(name);
X putval(fname, v, Yes, In_tarval);
X }
X release(fname);
X }
X tarfiled(name, Vnil);
X release(v); release(name);
X }
X}
X
XVisible Procedure put_perm(v) value v; {
X value fn;
X intlet len;
X
X if (!permchanges || !Valid(v))
X return;
X fn= mk_text(permfile);
X /* Remove the file if the permanent environment is empty */
X len= length(v);
X if (len == 0)
X f_delete(fn);
X else
X putval(fn, v, Yes, In_prmnv);
X release(fn);
X permchanges= No;
X}
X
XVisible Procedure clear_perm() {
X freeunits(USR_ALL);
X endperm();
X}
X
XVisible Procedure initsou() {
X release(b_units); b_units= mk_elt();
X release(last_unit); last_unit= mk_text(":");
X release(last_target); last_target= mk_text("=");
X release(b_perm); b_perm= mk_elt();
X}
X
XVisible Procedure endsou() {
X if (terminated)
X return; /* hack; to prevent seemingly endless QUIT */
X release(b_units); b_units= Vnil;
X release(b_perm); b_perm= Vnil;
X release(last_unit); last_unit= Vnil;
X release(last_target); last_target= Vnil;
X}
X
X/*
X * lst_uhds() displays the first line of the unit without a possible
X * present simple command
X */
X
X#define MORE MESS(4021, "Press [SPACE] for more, [RETURN] to exit list")
Xextern int winheight;
Xbool ask_for();
X
XVisible Procedure lst_uhds() {
X intlet k, len;
X value pname, *aa;
X how *u;
X int nprinted= 0;
X bool more= Yes;
X
X len= length(b_perm);
X for (k= 0; k<len && still_ok && more; ++k) {
X pname= *key(b_perm, k);
X if (!Is_text(pname) || Permtype(pname) == Tar)
X continue;
X /* reduce disk access: */
X if (u_exists(pname, &aa) && !Is_predefined(*aa))
X display(stdout, How_to(*aa)->unit, Yes);
X else
X lst_fileheading(*assoc(b_perm, k));
X fflush(stdout);
X if (++nprinted >= winheight) {
X more= ask_for(MORE);
X nprinted= 0;
X }
X }
X /* not interactive units */
X len= length(b_units);
X for (k= 0; k<len && still_ok && more; ++k) {
X u= How_to(*assoc(b_units, k));
X if (u -> filed == No && !p_exists(*key(b_units, k), &aa)) {
X display(stdout, u -> unit, Yes);
X fflush(stdout);
X if (++nprinted >= winheight) {
X more= ask_for(MORE);
X nprinted= 0;
X }
X }
X
X }
X}
X
XHidden Procedure lst_fileheading(v) value v; {
X FILE *fn;
X char *line;
X char *pcolon, *pc;
X
X if (!Is_text(v))
X return;
X fn= fopen(strval(v), "r");
X if (!fn)
X return;
X if ((line= f_getline(fn)) != NULL) {
X pcolon= strchr(line, C_COLON);
X if (pcolon != NULL) {
X pc= ++pcolon;
X while (Space(*pc)) ++pc;
X if (*pc != C_COMMENT && *pc != '\n') {
X /* single command after colon;
X * don't show it.
X */
X *(pcolon+1)= '\n';
X *(pcolon+2)= '\0';
X }
X }
X putstr(stdout, line);
X freestr(line);
X }
X fclose(fn);
X}
END_OF_FILE
if test 29957 -ne `wc -c <'abc/bint3/i3sou.c'`; then
echo shar: \"'abc/bint3/i3sou.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3sou.c'
fi
if test ! -d 'abc/bio' ; then
echo shar: Creating directory \"'abc/bio'\"
mkdir 'abc/bio'
fi
if test ! -d 'abc/boot' ; then
echo shar: Creating directory \"'abc/boot'\"
mkdir 'abc/boot'
fi
if test ! -d 'abc/btr' ; then
echo shar: Creating directory \"'abc/btr'\"
mkdir 'abc/btr'
fi
if test ! -d 'abc/doc' ; then
echo shar: Creating directory \"'abc/doc'\"
mkdir 'abc/doc'
fi
if test ! -d 'abc/ehdrs' ; then
echo shar: Creating directory \"'abc/ehdrs'\"
mkdir 'abc/ehdrs'
fi
if test ! -d 'abc/ex' ; then
echo shar: Creating directory \"'abc/ex'\"
mkdir 'abc/ex'
fi
if test ! -d 'abc/ex/generate' ; then
echo shar: Creating directory \"'abc/ex/generate'\"
mkdir 'abc/ex/generate'
fi
if test ! -d 'abc/ex/hanoi' ; then
echo shar: Creating directory \"'abc/ex/hanoi'\"
mkdir 'abc/ex/hanoi'
fi
if test ! -d 'abc/ex/pi' ; then
echo shar: Creating directory \"'abc/ex/pi'\"
mkdir 'abc/ex/pi'
fi
if test ! -d 'abc/ex/try' ; then
echo shar: Creating directory \"'abc/ex/try'\"
mkdir 'abc/ex/try'
fi
if test ! -d 'abc/ex/xref' ; then
echo shar: Creating directory \"'abc/ex/xref'\"
mkdir 'abc/ex/xref'
fi
if test ! -d 'abc/ihdrs' ; then
echo shar: Creating directory \"'abc/ihdrs'\"
mkdir 'abc/ihdrs'
fi
if test ! -d 'abc/keys' ; then
echo shar: Creating directory \"'abc/keys'\"
mkdir 'abc/keys'
fi
if test ! -d 'abc/lin' ; then
echo shar: Creating directory \"'abc/lin'\"
mkdir 'abc/lin'
fi
if test -f 'abc/lin/i1obj.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/lin/i1obj.c'\"
else
echo shar: Extracting \"'abc/lin/i1obj.c'\" \(7180 characters\)
sed "s/^X//" >'abc/lin/i1obj.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Generic routines for all values */
X
X#include "b.h"
X#include "bint.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "i1tlt.h"
X#include "i3typ.h"
X
X#define Len (len < 200 ? len : ((len-1)/8+1)*8)
X
XVisible unsigned tltsyze(type, len, nptrs)
X literal type;
X intlet len;
X int *nptrs;
X{
X register unsigned syze= 0;
X *nptrs= 0;
X switch (type) {
X case Tex: syze= (len+1)*sizeof(char); *nptrs= 0; break;
X case ELT:
X case Lis:
X case Ran:
X case Tab: syze= Len*sizeof(value); *nptrs= len; break;
X }
X return syze;
X}
X
XVisible Procedure rel_subvalues(v) value v; {
X rrelease(v);
X}
X
X#define INCOMP MESS(500, "incompatible types %s and %s")
X
XHidden Procedure incompatible(v, w) value v, w; {
X value m1, m2, m3, m;
X string s1, s2;
X
X m1= convert(m3= (value) valtype(v), No, No); release(m3);
X m2= convert(m3= (value) valtype(w), No, No); release(m3);
X s1= sstrval(m1);
X s2= sstrval(m2);
X sprintf(messbuf, getmess(INCOMP), s1, s2);
X m= mk_text(messbuf);
X interrV(-1, m);
X
X fstrval(s1); fstrval(s2);
X release(m1); release(m2);
X release(m);
X}
X
XVisible bool comp_ok;
X
X#define Sgn(d) (d)
X
XVisible relation compare(v, w) value v, w; {
X literal vt= Type(v), wt= Type(w);
X register intlet vlen, wlen, len, k;
X
X comp_ok= Yes;
X vlen= IsSmallInt(v) ? 0 : Length(v);
X wlen= IsSmallInt(w) ? 0 : Length(w);
X if (v == w) return 0;
X if (!(vt == wt && !(vt == Com && vlen != wlen) ||
X vt == Ran && (wt == Lis || wt == ELT) ||
X wt == Ran && (vt == Lis || vt == ELT) ||
X vt == ELT && (wt == Lis || wt == Tab) ||
X wt == ELT && (vt == Lis || vt == Tab))) {
X incompatible(v, w);
X comp_ok= No;
X return -1;
X }
X if (vt != Num && (vlen == 0 || wlen == 0))
X return Sgn(vlen-wlen);
X if (vt == Ran || wt == Ran)
X return range_comp(v, w);
X switch (vt) {
X case Num: return numcomp(v, w);
X case Tex: return strcmp(Str(v), Str(w));
X
X case Com:
X case Lis:
X case Tab:
X case ELT:
X {value *vp= Ats(v), *wp= Ats(w);
X relation c;
X len= vlen < wlen ? vlen : wlen;
X for (k= 0; k < len; k++)
X if ((c= compare(*vp++, *wp++)) != 0)
X return c;
X return Sgn(vlen-wlen);
X }
X default:
X syserr(MESS(501, "comparison of unknown types"));
X /* NOTREACHED */
X }
X}
X
XVisible double hash(v) value v; {
X if (Is_number(v))
X return numhash(v);
X else {
X literal t= Type(v); intlet len= Length(v), k;
X double d= t+.404*len;
X switch (t) {
X case Tex:
X {string vp= Str(v);
X for (k= 0; k < len; k++)
X d= .987*d+.277*(*vp++);
X return d;
X }
X case Com:
X case Lis:
X case Ran:
X case Tab:
X case ELT:
X {value *vp= Ats(v);
X if (len == 0) return .909;
X for (k= 0; k < len; k++)
X d= .874*d+.310*hash(*vp++);
X return d;
X }
X default:
X syserr(MESS(502, "hash called with unknown type"));
X /* NOTREACHED */
X }
X }
X}
X
X/* For reasons of efficiency, wri does not always call convert but writes
X directly on the standard output. Modifications in convert should
X be mirrored by changes in wri and vice versa. */
X
X#ifdef RANGEPRINT
XHidden Procedure conc_vals(pt, l, u) value *pt; value l, u; {
X value x;
X if (compare(l, u) == 0)
X concato(pt, x= convert(l, No, No));
X else if (is_increment(u, l)) {
X concato(pt, x= convert(l, No, No)); release(x);
X concato(pt, x= mk_text("; ")); release(x);
X concato(pt, x= convert(u, No, No));
X }
X else {
X concato(pt, x= convert(l, No, No)); release(x);
X concato(pt, x= mk_text("..")); release(x);
X concato(pt, x= convert(u, No, No));
X }
X release(x);
X}
X#endif /* RANGEPRINT */
X
X#define Last(k, len) ((k) == (len)-1)
X
XVisible value convert(v, coll, outer) value v; bool coll, outer; {
X value t, quote, c, cv, sep, th, open, close, i, s;
X int k, len; char ch; relation r;
X switch (Type(v)) {
X case Num:
X return mk_text(convnum(v));
X case Tex:
X if (outer) return copy(v);
X quote= mk_text("\"");
X len= length(v);
X t= copy(quote);
X for (k=1; k<=len; k++) {
X c= thof(k, v);
X ch= charval(c);
X concato(&t, c);
X if (ch == '"' || ch == '`') concato(&t, c);
X release(c);
X }
X concato(&t, quote);
X release(quote);
X break;
X case Com:
X len= Nfields(v);
X outer&= coll;
X sep= mk_text(outer ? " " : ", ");
X t= mk_text(coll ? "" : "(");
X for (k= 0; k < len; k++) {
X concato(&t, cv= convert(*Field(v, k), No, outer));
X release(cv);
X if (!Last(k, len)) concato(&t, sep);
X }
X release(sep);
X if (!coll) {
X concato(&t, cv= mk_text(")"));
X release(cv);
X }
X break;
X case Ran:
X case Lis:
X case ELT:
X t= mk_text("{");
X sep= mk_text("; ");
X#ifndef RANGEPRINT
X i= copy(one); s= size(v);
X while ((r=numcomp(i, s)) <= 0) {
X th= item(v, i);
X concato(&t, cv= convert(th, No, No));
X if (r < 0) {
X concato(&t, sep);
X }
X release(cv); release(th);
X i= sum(th=i, one);
X release(th);
X }
X release(i); release(s);
X#else /* RANGEPRINT */
X {
X value lwb, upb;
X bool first= Yes;
X i= copy(one); s= size(v);
X while (numcomp(i, s) <= 0) {
X th= item(v, i);
X if (first) {
X lwb= copy(th);
X upb= copy(th);
X first= No;
X }
X else if (is_increment(th, upb)) {
X release(upb);
X upb= copy(th);
X }
X else {
X conc_vals(&t, lwb, upb) ;
X concato(&t, sep);
X release(lwb); release(upb);
X lwb= copy(th); upb= copy(th);
X }
X release(th);
X i= sum(th=i, one);
X release(th);
X }
X if (!first) {
X conc_vals(&t, lwb, upb);
X release(lwb); release(upb);
X }
X release(i); release(s);
X }
X#endif /* RANGEPRINT */
X concato(&t, cv= mk_text("}"));
X release(cv); release(sep);
X break;
X case Tab:
X len= length(v);
X open= mk_text("[");
X close= mk_text("]: ");
X sep= mk_text("; ");
X t= mk_text("{");
X for (k= 0; k < len; k++) {
X concato(&t, open);
X concato(&t, cv= convert(*key(v, k), Yes, No));
X release(cv);
X concato(&t, close);
X concato(&t, cv= convert(*assoc(v, k), No, No));
X release(cv);
X if (!Last(k, len)) concato(&t, sep);
X }
X concato(&t, cv= mk_text("}")); release(cv);
X release(open); release(close); release(sep);
X break;
X default:
X syserr(MESS(503, "unknown type in convert"));
X }
X return t;
X}
X
X#define Left 'L'
X#define Right 'R'
X#define Centre 'C'
X
X#define ADJLEFT_NUM MESS(504, "in t<<n, n is not a number")
X#define ADJRIGHT_NUM MESS(505, "in t><n, n is not a number")
X#define CENTRE_NUM MESS(506, "in t>>n, n is not a number")
X
XHidden value adj(x, y, side) value x, y; literal side; {
X value r, v= convert(x, Yes, Yes); int i;
X intlet lv, la, k, ls, rs;
X string rp, vp;
X
X if (!Is_number(y)) {
X switch (side) {
X case Left: interr(ADJLEFT_NUM); break;
X case Centre: interr(ADJRIGHT_NUM); break;
X case Right: interr(CENTRE_NUM); break;
X }
X return v;
X }
X i= intval(y);
X lv= Length(v);
X la= propintlet(i) - lv;
X if (la <= 0) return v;
X r= grab(Tex, lv+la); rp= Str(r); vp= Str(v);
X
X if (side == Left) { ls= 0; rs= la; }
X else if (side == Centre) { ls= la/2; rs= (la+1)/2; }
X else { ls= la; rs= 0; }
X
X for (k= 0; k < ls; k++) *rp++= ' ';
X for (k= 0; k < lv; k++) *rp++= *vp++;
X for (k= 0; k < rs; k++) *rp++= ' ';
X *rp= 0;
X release(v);
X return r;
X}
X
XVisible value adjleft(x, y) value x, y; {
X return adj(x, y, Left);
X}
X
XVisible value centre(x, y) value x, y; {
X return adj(x, y, Centre);
X}
X
XVisible value adjright(x, y) value x, y; {
X return adj(x, y, Right);
X}
X
X
END_OF_FILE
if test 7180 -ne `wc -c <'abc/lin/i1obj.c'`; then
echo shar: \"'abc/lin/i1obj.c'\" unpacked with wrong size!
fi
# end of 'abc/lin/i1obj.c'
fi
if test ! -d 'abc/scripts' ; then
echo shar: Creating directory \"'abc/scripts'\"
mkdir 'abc/scripts'
fi
if test ! -d 'abc/stc' ; then
echo shar: Creating directory \"'abc/stc'\"
mkdir 'abc/stc'
fi
if test ! -d 'abc/tc' ; then
echo shar: Creating directory \"'abc/tc'\"
mkdir 'abc/tc'
fi
if test ! -d 'abc/uhdrs' ; then
echo shar: Creating directory \"'abc/uhdrs'\"
mkdir 'abc/uhdrs'
fi
if test ! -d 'abc/ukeys' ; then
echo shar: Creating directory \"'abc/ukeys'\"
mkdir 'abc/ukeys'
fi
if test ! -d 'abc/unix' ; then
echo shar: Creating directory \"'abc/unix'\"
mkdir 'abc/unix'
fi
echo shar: End of archive 1 \(of 25\).
cp /dev/null ark1isdone
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
--
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