Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/util/fetch.sim
There is 1 other file named fetch.sim in the archive. Click here to see a list.
BEGIN
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Directfile) PROCEDURE finddirectfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL TEXT PROCEDURE front,scanto,getitem,tsub,from,upto;
EXTERNAL INTEGER PROCEDURE arrlgd;
EXTERNAL PROCEDURE arrtxt;
EXTERNAL INTEGER PROCEDURE maxint,search,splita,hash;
EXTERNAL PROCEDURE split;
EXTERNAL BOOLEAN PROCEDURE puttext,change;
EXTERNAL TEXT PROCEDURE conc,upcase,frontstrip,rest,
checkextension;
EXTERNAL CHARACTER PROCEDURE fetchar,findtrigger;
EXTERNAL LONG REAL PROCEDURE scanreal;
EXTERNAL INTEGER PROCEDURE checkreal,checkint,scanint,ilog;
EXTERNAL BOOLEAN PROCEDURE menu;
EXTERNAL CLASS safeio,simdbm,dbmset,fetch1,fetch2;
fetch2("ftclog.tmp","English","",68,TRUE) BEGIN
SWITCH opchoice:=record_,and_,or_,makeindex_,table_,
select_,invert_,display_,index_,
tty_,set_,fields_,insert_,define_,nextkey,store_,finish,
type_,owner_,remove_,delete_,tty_,append_,open_,
defproc_,switch_,help_;
INTEGER ixdim;
TEXT itext1,itext2,ixname,itx,indsave;
BOOLEAN PROCEDURE incheck(iname,ivekt);
NAME ivekt; TEXT iname,ivekt;
BEGIN
opa(2):-iname;
incheck:=index_ok; ivekt:-Copy(invx(1));
END of incheck;
TEXT PROCEDURE addindex(t1,t2,opkod);
TEXT t1,t2,opkod;
BEGIN TEXT t,u; INTEGER n1,n2,n3,k,m;
BOOLEAN union,exclusion;
INTEGER ARRAY i1,i2,i3[0:300];
INTEGER PROCEDURE imake(t,i); TEXT t; INTEGER ARRAY i;
BEGIN INTEGER k;
t:-t.Strip;
WHILE t.More DO
BEGIN i(k):=t.Getint; k:=k+1; t:-rest(t); END;
imake:=k-1;
END imake;
IF opkod == NOTEXT THEN union:=TRUE ELSE
exclusion:=opkod.Sub(1,1) = "N";
IF union THEN n3:=imake(t1,i3) ELSE n1:=imake(t1,i1);
n2:=imake(t2,i2);
IF union THEN
BEGIN
FOR k:=0 STEP 1 UNTIL n2 DO
BEGIN
FOR m:=0 STEP 1 UNTIL n3 DO
IF i2(k) = i3(m) THEN GOTO notnew;
n3:=n3+1; i3(n3):=i2(k);
notnew:
END;
END ELSE
BEGIN
n3:=-1;
FOR k:=0 STEP 1 UNTIL n1 DO
BEGIN
FOR m:=0 STEP 1 UNTIL n2 DO
BEGIN
IF i2(m) = i1(k) THEN
BEGIN
IF \exclusion THEN
BEGIN n3:=n3+1; i3(n3):=i1(k); END;
GOTO newfound;
END;
END;
IF exclusion THEN BEGIN n3:=n3+1; i3(n3):=i1(k); END;
newfound:
END;
END;
t:-Blanks(5*n3+5);
FOR k:=0 STEP 1 UNTIL n3 DO
BEGIN
u:-intput(i3(k));
t.Sub(t.Pos,u.Length):=u;
t.Setpos(t.Pos+u.Length+1);
END;
addindex:-t.Strip; ixdim:=n3+1;
END addindex;
REF (rspec) PROCEDURE getrspec(t); TEXT t;
BEGIN REF (rspec) rs;
getrspec:-rs:-getrecordspec(t); IF rs == NONE THEN
BEGIN outline2("UNDEFINED RECORD TYPE: ",t);
GOTO nextkey; END;
END GETRSPEC;
REF (record) PROCEDURE getp(t,u); TEXT t,u;
getp:-getrecm(t,u,nextkey);
! start of main program ________________________________;
OPTIONS(/-W);
margin:=0; displaydefault:=FALSE;
tolerans:=0.001;
fx:=1;
optot:-Copy("+++0AND0OR 0MAK0TAB0SEL0INV0DIS1IND1TTY0SET2"
"FIE1INS3DEF3RRR0STO0EXI0TYP1OWN2REM2DEL1RES0APP3OPE1COM1SWI2HEL1");
FOR k:=1 STEP 1 UNTIL 27 DO
BEGIN
oparr(k):-optot.Sub(k*4-3,3);
opargs(k):=optot.Sub(k*4,1).Getint;
END;
itx:-Copy("=,<,>,<=,>=,/="); splita(itx,komma,ops,8);
nextkey:
stringrequest(">",keyvalue);
nrof_hits:=0; nameonly:=FALSE;
GOTO opchoice(oper);
open_: ! ------------------------------------- OPEN ;
IF defined__f THEN closebase;
k__:=IF opa(3) == NOTEXT THEN 68 ELSE scanint(opa(3));
openbase(opa(2),k__); IF defined__f THEN initset ELSE
outline2("File could not be opened as data base: ",opa(2));
GOTO nextkey;
defproc_: ! -------------------------------------- COMMAND ;
makecproc(opa(2)); GOTO nextkey;
switch_: ! -------------------------------------- SWITCH ;
swi(opa(2).Getint):=opa(3)="T"; GOTO nextkey;
help_: ! -------------------------------------- HELP ;
helpmess(upcase(opa(2))); GOTO nextkey;
and_: ! ________________________________________ AND ;
orconnections:=FALSE; scan; GOTO nextkey;
or_: ! _________________________________________ OR ;
orconnections:=TRUE; scan; GOTO nextkey;
select_: ! _____________________________________ SELECT ;
fx:=1;
lmax:=0;
select; GOTO nextkey;
invert_: ! _____________________________________ INVERT ;
fileout:=TRUE; GOTO nextkey;
display_: ! ____________________________________ DISPLAY ;
indsave:-invx(1);
IF index_ok THEN
BEGIN
filewrite:=fileout:=FALSE; fx:=1;
parmcheck(3);
scanindex(outrecord); fx:=1;
nameonly:=filewrite:=FALSE;
END;
IF rtypsave =/= NONE THEN rtyp:-rtypsave;
invx(1):-indsave;
GOTO nextkey;
index_: ! ______________________________________ INDEX ;
IF opa(3) =/= NOTEXT THEN
BEGIN
fx:=opa(2).Getint;
IF fx = 0 THEN scanagain:=FALSE;
END ELSE BEGIN scanagain:=TRUE; fx:=1; index_ok; END;
GOTO nextkey;
tty_: ! ________________________________________ TTY ;
fx:=0; scanagain:=setfollow:=filewrite:=fileout:=FALSE;
GOTO nextkey;
set_: ! ________________________________________ SET;
IF setcheck(opa(2)) THEN GOTO nextkey;
rowner:-getp(opa(3),otype);
parmcheck(4);
mapset(rowner,opa(2),outrecord);
nameonly:=filewrite:=FALSE;
GOTO nextkey;
fields_: ! _____________________________________ FIELDS;
current_spec:-getrspec(opa(2));
disp_types;
GOTO nextkey;
insert_: ! _____________________________________ INSERT;
setname:-opa(2); owner:-opa(3); members:-opa(4);
IF setcheck(setname) THEN GOTO nextkey;
rowner:-getp(owner,otype);
k:=5; WHILE members =/= NOTEXT DO
BEGIN
rmemb:-getrecm(members,mtype,ins2);
insert(setname,rowner,rmemb);
ins2: members:-opa(k); k:=k+1;
END;
GOTO nextkey;
define_: ! _____________________________________ DEFINE;
defineset(opa(2),opa(3),opa(4),opa(5));
GOTO nextkey;
store_: ! _____________________________________ STORE;
IF opa(2) == NOTEXT THEN opa(2):-recordtype;
prompt(opa(2)); GOTO nextkey;
type_: ! _______________________________________ TYPE;
recordtype:-opa(2); rtyp:-getrspec(recordtype);
IF rtyp == NONE THEN display_records;
scanagain:=FALSE; fx:=0;
GOTO nextkey;
owner_: ! ______________________________________ OWNER;
IF setcheck(opa(2)) THEN GOTO nextkey;
rmemb:-getp(opa(3),mtype);
rowner:-getowner(rmemb,opa(2));
parmcheck(4);
IF rowner =/= NONE THEN
outrecord(rowner); nameonly:=FALSE; GOTO nextkey;
remove_: ! __________________________________________ REMOVE;
IF setcheck(opa(2)) THEN GOTO nextkey;
FOR k:=3 STEP 1 UNTIL 20 DO
BEGIN
IF opa(k) == NOTEXT THEN GOTO nextkey;
rmemb:-get(opa(k),mtype);
remove(rmemb,opa(2));
END;
GOTO nextkey;
delete_: ! ___________________________________________ DELETE;
FOR k:=2 STEP 1 UNTIL 20 DO
BEGIN
IF opa(k) == NOTEXT THEN GOTO nextkey;
rmemb:-get(opa(k),recordtype);
delete(rmemb);
END;
GOTO nextkey;
table_: ! __________________________________________ TABLE;
IF opa(2) =/= NOTEXT THEN
BEGIN
tabname:-opa(2);
IF opa(3) == NOTEXT THEN
BEGIN
IF tab_pres THEN tabfilspec;
GOTO nextkey;
END
ELSE store_tab:=TRUE;
IF opa(4) =/= NOTEXT THEN ny_tab:=TRUE
ELSE ny_tab:=FALSE;
END
ELSE store_tab:=FALSE;
! ask for fields, columns and sums within delimiters;
stringrequest("Fields:",opa(2));
stringrequest("Columns:",opa(3));
stringrequest("Remark:",opa(5));
IF \tabfilspec THEN GOTO nextkey;
tabspecstore;
GOTO nextkey;
record_: ! _____________________________________ RECORD;
r:-getp(keyvalue,recordtype);
current_spec:-rtyp;
nextterm:
stringrequest("term: ",tname);
IF tname == NOTEXT THEN GOTO nextkey;
IF tname.Sub(1,1) = "." THEN
BEGIN outrecord(r); GOTO nextterm; END ELSE
BEGIN
getterm; IF termposition > 0 THEN
BEGIN
outline2(" ",r.avalues(termposition));
END ELSE outline("Field undefined !");
END;
GOTO nextterm;
makeindex_: !________________________________ MAKEINDEX;
keyindex;
GOTO nextkey;
append_: ! ------------------------------------ APPEND;
ixname:-Copy(opa(2));
IF \incheck(opa(3),itext1) THEN GOTO nextkey;
IF \incheck(opa(4),itext2) THEN GOTO nextkey;
IF rtyp =/= rtypsave THEN
BEGIN
outline("ILLEGAL: both indexes must refer to same record type !");
GOTO nextkey;
END;
fx:=1; invx(1):-addindex(itext1,itext2,upcase(opa(5)));
IF ixdim > 0 THEN
BEGIN
indrtype:-rtyp.rname;
indexstore(ixname,ixdim," ",ixname);
Outtext("OK, number of items = "); Outint(ixdim,4);
Outimage;
END ELSE outline("Result is empty set.");
GOTO nextkey;
finish:
eof:
IF tabfile =/= NONE AND tabfile =/= Sysout THEN tabfile.Close;
END;
END of fetch;