Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/libsim/dbmset.sim
There is 1 other file named dbmset.sim in the archive. Click here to see a list.
OPTIONS(/external);
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL TEXT PROCEDURE front,scanto,getitem;
EXTERNAL INTEGER PROCEDURE maxint,search,splita,hash;
EXTERNAL PROCEDURE split;
EXTERNAL INTEGER PROCEDURE arrlgd;
EXTERNAL PROCEDURE arrtxt;
EXTERNAL BOOLEAN PROCEDURE puttext;
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;
simdbm CLASS dbmset;
BEGIN
BOOLEAN break_map;
CHARACTER carrchar;
REF (setspec) set__spec;
TEXT struc,strucname,dot2;
REF (rspec) strucspec,rs_spec;
TEXT ARRAY setarr[1:10];
REF(setspec) stab,nextstab;
CLASS setspec(setname,ownertype,membertype);
TEXT setname,ownertype,membertype;
!----------------------------------------------------------
Internal structure to specify a SET if not already
in array STAB, store it there (Why??).
----------------------------------------------------------;
BEGIN REF (setspec) next;
nextstab:-stab; WHILE nextstab =/= NONE DO
BEGIN
IF nextstab.setname = setname THEN GOTO fin;
nextstab:-nextstab.next;
END;
nextstab:-stab; stab:-THIS setspec;
stab.next:-nextstab;
fin:
END of setspec;
REF (setspec) PROCEDURE getsetspec(t); TEXT t;
BEGIN
nextstab:-stab; WHILE nextstab =/= NONE DO
BEGIN
IF t = nextstab.setname THEN
BEGIN getsetspec:-nextstab; GOTO fin; END;
nextstab:-nextstab.next;
END;
fin:
END getsetspec;
PROCEDURE defineset(sname,owner,member,remark);
VALUE sname,owner,member,remark; TEXT sname,owner,member,remark;
!------------------------------------------------------
Create internal structure defining a SET.
See if it is externally stored, if not store it
in external data base file.
------------------------------------------------------;
BEGIN REF (record) r; TEXT ARRAY ta[1:4];
r:-get(sname,"SETSPEC");
IF r == NONE THEN
BEGIN
IF scheck(owner) AND scheck(member) THEN
BEGIN
ta(1):-sname; ta(2):-owner; ta(3):-member; ta(4):-remark;
r:-NEW record(rs_spec,ta); r.store;
NEW setspec(sname,owner,member);
END;
END;
END defineset;
PROCEDURE makesetspec(r); REF (record) r;
INSPECT r DO
IF scheck(avalues(2)) AND scheck(avalues(3)) THEN
NEW setspec(avalues(1),avalues(2),avalues(3));
BOOLEAN PROCEDURE scheck(t); TEXT t;
IF getrecordspec(t) =/= NONE THEN scheck:=TRUE ELSE
outline2("Set with undef. RTYPE: ",t);
TEXT PROCEDURE maketext(t); TEXT ARRAY t;
! ---------------------------------------------------
! concatenate all the elements of t to one single text,
! each element separated with arrchar.
! -------------------------------------------------------;
BEGIN TEXT u,s; INTEGER k;
s:-t(1); k:=2; u:-t(2);
FOR k:=k+1 WHILE u =/= NOTEXT DO
BEGIN s:-conc(s,arrchar,u); u:-t(k); END;
maketext:-s;
END maketext;
REF (record) PROCEDURE getstruc(r); REF (record) r;
!------------------------------------------------------
! retrieve structure record
! the key of that is record type concatenated with
! record key.
! -------------------------------------------------------;
BEGIN
strucname:-conc(r.spec.rname,dot2,r.getkey);
getstruc:-get(strucname,struc);
END getstruc;
REF (record) PROCEDURE getstruc2(r,s,memb);
REF (record) r; TEXT s; BOOLEAN memb;
BEGIN INTEGER k;
! ------------------------------------------------------
! check if SET is represented as an internal
! field or as an proper set
! when internal field, create an artificial
! structure record.
! -------------------------------------------------------;
k:=loctext(s,r.spec.anames);
IF k>0 THEN
BEGIN !internal field represents set;
TEXT ARRAY struc[1:4]; TEXT t;
t:-conc(s,semikolon,r.avalues(k));
IF memb THEN struc(2):-t ELSE struc(3):-t;
getstruc2:-NEW record(strucspec,struc);
END
ELSE getstruc2:-getstruc(r);
END of getstruc2;
REF (record) PROCEDURE makstruc(r); REF (record) r;
! --- construct a structure record for r -----------;
BEGIN TEXT ARRAY astruc[1:4];
astruc(1):-conc(r.spec.rname,dot2,r.getkey);
makstruc:-NEW record(strucspec,astruc);
END makstruc;
PROCEDURE makstruc2(r1,r2,s);
! -----------------------------------------------------
! for records with internal field representing set,
! locate this field for r1
! concatenate the key of r2 to this field.
! --------------------------------------------------------;
REF (record) r1,r2; TEXT s;
BEGIN INTEGER k; TEXT t1,t2;
k:=loctext(s,r1.spec.anames);
IF k>0 THEN
BEGIN IF r1.avalues(k) == NOTEXT THEN
r1.avalues(k):-r2.getkey ELSE
BEGIN t1:-r1.avalues(k); t2:-r2.getkey;
r1.avalues(k):-conc(t1,semikolon,t2);
END;
END;
END of makstruc2;
INTEGER PROCEDURE findset(t,u); TEXT t,u;
! -------------------------------------------------------
! u is a sequence of set specifications each of the form:
!
! SETNAME!m1!m2! ...
!
! split the set representation to the global array SETARR
! then locate the element with SETNAME = t
! and return as value the index in SETARR of that element
! ----------------------------------------------------------;
BEGIN INTEGER n,k; TEXT v;
n:=splita(u,arrchar,setarr,10);
FOR k:=1 STEP 1 UNTIL n DO
BEGIN
v:-setarr(k);
IF t = scanto(v,csemikolon) THEN
BEGIN findset:=k; GOTO fin; END;
END;
fin:
END findset;
PROCEDURE insert(set,owner,memb); VALUE set;
TEXT set; REF (record) owner,memb;
BEGIN REF (record) rown,rmemb; INTEGER k,n; TEXT t;
rown:-getstruc2(owner,set,TRUE);
IF rown == NONE THEN rown:-makstruc(owner);
IF rown.avalues(1) == NOTEXT THEN makstruc2(owner,memb,set);
IF rown.avalues(2) == NOTEXT THEN
rown.avalues(2):-conc(set,semikolon,memb.getkey) ELSE
BEGIN
n:=findset(set,rown.avalues(2));
IF n = 0 THEN
rown.avalues(2):-conc(set,semikolon,memb.getkey,arrchar,rown.avalues(2))
ELSE
BEGIN t:-memb.getkey;
setarr(n):-conc(setarr(n),semikolon,t);
rown.avalues(2):-maketext(setarr);
END;
END;
rmemb:-getstruc2(memb,set,FALSE);
IF rmemb == NONE THEN rmemb:-makstruc(memb);
IF rmemb.avalues(1) == NOTEXT THEN makstruc2(memb,owner,set);
IF rmemb.avalues(3) == NOTEXT THEN
rmemb.avalues(3):-conc(set,semikolon,owner.getkey) ELSE
BEGIN
n:=findset(set,rmemb.avalues(3));
IF n = 0 THEN
rmemb.avalues(3):-
conc(rmemb.avalues(3),arrchar,set,semikolon,owner.getkey) ELSE
BEGIN
t:-setarr(n); scanto(t,csemikolon);
IF owner.getkey = scanto(t,csemikolon) THEN
BEGIN outline2("Double owners: ",memb.getkey); GOTO fin; END;
END;
END;
IF rown.avalues(1) =/= NOTEXT THEN
BEGIN
rown.store; rmemb.store;
END ELSE BEGIN memb.store; owner.store; END;
fin:
END insert;
PROCEDURE mapset(r,set,p); VALUE set;
! -----------------------------------------------------
! scan all records in set for owner record r, for each
! record call the procedure p.
!
! a. find the structure record
!
! b. find among the owner specifications the one with
! matching name.
!
! c. scan through all the kys of the members which are
! delimited with semicolons.
!
! d. if the global variable BREAK_MAP has been set in
! the calld procedure, then scanning is interrupted.
! -------------------------------------------------------;
REF (record) r; TEXT set; PROCEDURE p;
BEGIN REF (record) s,m; INTEGER n; TEXT t,u; REF (setspec) ss;
break_map:=FALSE;
s:-getstruc2(r,set,TRUE); IF s =/= NONE THEN
BEGIN
n:=findset(set,s.avalues(2)); IF n > 0 THEN
BEGIN
ss:-getsetspec(set);
t:-setarr(n); t.Setpos(setarr(n).Pos);
u:-scanto(t,csemikolon); u:-scanto(t,csemikolon);
WHILE u =/= NOTEXT DO
BEGIN
m:-get(u,ss.membertype); p(m); IF break_map THEN GOTO fin;
u:-scanto(t,csemikolon);
END;
END;
END;
fin:
END mapset;
REF (record) PROCEDURE getowner(r,set); VALUE set;
! ------------------------------------------------------
! find the owner of the record r in set
! find structure record
! find SET among member specifications
! scan past name, and find find type of owner via
! the set specification.
! --------------------------------------------------------;
REF (record) r; TEXT set;
BEGIN REF (record) s; INTEGER n; REF (setspec) ss; TEXT t;
s:-getstruc2(r,set,FALSE); IF s =/= NONE THEN
BEGIN
n:=findset(set,s.avalues(3)); IF n > 0 THEN
BEGIN
ss:-getsetspec(set);
t:-setarr(n); scanto(t,csemikolon);
getowner:-get(rest(t),ss.ownertype);
END;
END;
END getowner;
PROCEDURE remove(r,set); REF (record) r; TEXT set;
IF r =/= NONE THEN
BEGIN
REF (record) owner,ostruc,eigstruc; INTEGER k; BOOLEAN mremove;
PROCEDURE remstring(t); NAME t; TEXT t;
BEGIN ! remove string started with "SET, .. " from text t;
TEXT u,v,s;
TEXT PROCEDURE restpart(t); TEXT t;
IF mremove THEN restpart:-NOTEXT ELSE
BEGIN INTEGER k; TEXT x,s1,sn;
restpart:-t; s1:-t;
sn:-r.getkey; WHILE s1.More DO
BEGIN
k:=s1.Pos; x:-scanto(s1,csemikolon);
IF x = sn THEN
BEGIN
x:-conc(s1.Sub(1,k-1),rest(s1));
! see if some key is left in string;
x.Setpos(1); sn:-scanto(x,csemikolon);
IF x.More THEN restpart:-x ELSE restpart:-NOTEXT;
GOTO fin;
END;
END;
fin:
END restpart;
u:-t; WHILE u.More DO
BEGIN
k:=u.Pos;
v:-scanto(u,carrchar); s:-scanto(v,csemikolon); IF s = set THEN
BEGIN
IF k = 1 THEN t:-conc(restpart(v),rest(u)) ELSE
t:-conc(u.Sub(1,k-1),restpart(v),rest(u));
GOTO fin;
END;
END;
t:-u;
fin:
END remstring;
PROCEDURE reststore(r); REF (record) r;
IF r.avalues(2) =/= NOTEXT OR r.avalues(3) =/= NOTEXT THEN r.store ELSE
delete(r);
eigstruc:-getstruc(r); IF eigstruc =/= NONE THEN
BEGIN
owner:-getowner(r,set); ostruc:-getstruc2(owner,set,TRUE);
remstring(ostruc.avalues(2));
mremove:=TRUE; remstring(eigstruc.avalues(3));
reststore(eigstruc); reststore(ostruc);
END ELSE
BEGIN INTEGER k; ! set represented by field in record;
k:=loctext(set,r.spec.anames); IF k > 0 THEN
BEGIN
owner:-get(r.avalues(k),getsetspec(set).ownertype);
r.avalues(k):-NOTEXT; r.store;
k:=loctext(set,owner.spec.anames);
IF k > 0 THEN
BEGIN TEXT oldset,newset,key,u;
oldset:-owner.avalues(k); key:-r.getkey;
u:-scanto(oldset,csemikolon); WHILE u =/= NOTEXT DO
BEGIN
IF u \= key THEN newset:-conc(newset,semikolon,u);
u:-scanto(oldset,csemikolon);
END;
owner.avalues(k):-IF newset == NOTEXT THEN NOTEXT ELSE
newset.Sub(2,newset.Length-1); owner.store;
END;
END;
END;
;
END remove;
PROCEDURE delstruc(r); REF (record) r;
BEGIN REF (record) r1,r2;
INTEGER i,n; TEXT s,t; TEXT ARRAY member,owner[1:10];
PROCEDURE remove1(r); REF (record) r;
remove(r,s);
r1:-getstruc(r); IF r1 =/= NONE THEN
BEGIN
n:=splita(r1.avalues(2),arrchar,owner,10);
FOR i:=1 STEP 1 UNTIL n DO
BEGIN
t:-owner(i);
s:-scanto(t,csemikolon);
mapset(r,s,remove1);
END;
n:=splita(r1.avalues(3),arrchar,member,10);
FOR i:=1 STEP 1 UNTIL n DO
BEGIN
t:-member(i);
s:-scanto(t,csemikolon);
remove(r,s);
END;
delete(r1);
END;
END of delstruc;
PROCEDURE initset;
BEGIN
struc:-Copy("STRUKTUR");
carrchar:=arrchar.Getchar;
csemikolon:=';'; dot2:-Copy("..");
strucspec:-getrecordspec(struc);
rs_spec:-getrecordspec("SETSPEC");
stab:-NONE;
doforeach("SETSPEC",makesetspec);
END;
! -------- initiering av set-hanteringen --------------;
IF defined__f THEN initset;
END;