Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/23/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;