Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

OPTIONS(/external);
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Directfile) PROCEDURE finddirectfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL INTEGER PROCEDURE arrlgd;
EXTERNAL PROCEDURE arrtxt;
EXTERNAL TEXT PROCEDURE front,scanto,getitem,tsub,from,upto;
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;
fetch1 CLASS fetch2;
BEGIN
  INTEGER termposition,m,n,k,lmax,nrof_hits,fx,tabdim,blksize;
  BOOLEAN fileout,orconnections,scanagain,
  filewrite,ny_tab,store_tab,setfollow;
  TEXT setname,tabname,otype,mtype,owner,members,strip_t,followset;
  TEXT indrtype;
  TEXT ARRAY tabnames,tabpos[1:80];
  INTEGER ARRAY fieldloc,fieldpos[1:80];
  REF (Outfile) tabfile;
  TEXT ARRAY invx[1:10],opa[1:100],oparr[1:30];
  INTEGER ARRAY opargs[1:30];
  REF (record) rowner,rmemb;
  TEXT newvalue,optot,t,t1,u,recordtype,keyvalue,tname;
  REF (rspec) rtypsave,indexspec,setspecif;
  REF (record) r;
  REF (condarray) topcond;
  CHARACTER c;



  REF (record) PROCEDURE getrecm(key,type,l);
  VALUE type; TEXT key,type; LABEL l;
  BEGIN REF (record) r;
    getrecm:-r:-get(key,type);
    IF r == NONE THEN
    BEGIN
      Outtext(type); outline2(" record not found: ",key);  GOTO l;
    END;
  END GETRECM;

  PROCEDURE getterm;
  BEGIN TEXT t_t,u,oldt;
    t_t:-tname; u:-scanto(t_t,'=').Strip; IF u \= t_t THEN
    BEGIN ! assignment to attribute;
      newvalue:-frontstrip(rest(t_t)); tname:-scanto(u,' ');
      m:=loctext(tname,rtyp.anames);
      IF m > 0 THEN
      BEGIN
	IF tname \= u THEN BEGIN
	  oldt:-frontstrip(rest(u));
	  change(r.avalues(m),oldt,newvalue); newvalue:-r.avalues(m);
	  newvalue.Setpos(1);
	END;
	IF tcheck(rtyp.atypes(m),newvalue) THEN INSPECT r DO
	BEGIN
	  IF m = rtyp.keypos AND avalues(m) \= newvalue THEN syn_:=blank2;
	  avalues(m):-newvalue; store;
	END;
      END;
    END;
    termposition:=loctext(tname,rtyp.anames);
  END of getterm;

  TEXT PROCEDURE getrecordid(t1,t); NAME t1; VALUE t;
  TEXT t1,t;
  BEGIN TEXT u; REF(record) r;
    r:-get(t1,t);
    IF r =/= NONE THEN
    BEGIN
      stringrequest("Overwrite ?",u);
      IF u.Length > 0 THEN BEGIN
	IF upcase(u).Getchar = 'N' THEN
	stringrequest("Give new name:",t1);
      END;
      t1:-t1.Strip;
    END;
    getrecordid:-t1;
  END of getrecordid;

  INTEGER PROCEDURE fieldlength(k); INTEGER k;
  BEGIN INTEGER kk,kkk;
    ! locate next field position, bypass negative numbers
    indicating moving of context via sets;
    fieldlength:=0; kk:=k+1;
    WHILE kkk <=0 DO
    BEGIN
      kkk:=fieldpos(kk);
      kk:=kk+1;
    END;
    IF kkk < fieldpos(k) THEN kkk:=fieldpos(tabdim+1);
    fieldlength:=kkk-fieldpos(k);
  END of fieldlength;



  PROCEDURE wtabfile(r); REF (record) r;
  INSPECT tabfile DO
  BEGIN INTEGER k,m,mm;
    FOR k:=1 STEP 1 UNTIL tabdim DO
    BEGIN
      IF fieldpos(k)<0 THEN
      BEGIN
	r:-getowner(r,tabnames(k));
	IF r == NONE THEN GOTO fin;
      END ELSE
      IF fieldpos(k) = 0 THEN Outimage;
      BEGIN
	Setpos(fieldpos(k));
	IF fieldloc(k) > 0 THEN INSPECT r DO
	BEGIN
	  ! INTEGERS RIGHT ADJUSTED, THE REST LEFT ADJUSTED;
	  IF spec.atypes(fieldloc(k)) = 1 THEN
	  ! fields of type integer are right-adjusted (to allow sorting);
	  Outint(avalues(fieldloc(k)).Getint,fieldlength(k))
	  ELSE
	  BEGIN
	    m:=avalues(fieldloc(k)).Length; mm:=fieldlength(k);
	    IF m > mm THEN Outtext(avalues(fieldloc(k)).Sub(1,mm)) ELSE
	    Outtext(avalues(fieldloc(k)));
	  END;
	END;
      END;
    END;
    fin: Outimage;
  END of wtabfile;

  PROCEDURE outrecord(r); REF (record) r;
  BEGIN
    IF setfollow THEN r:-getowner(r,followset);
    IF filewrite THEN wtabfile(r) ELSE tabulate(r);
  END;

  PROCEDURE check_write(r); REF (record) r;
  ! check that recor satisfies all conditions in rconds
  ! if so type entire record
  ;
  INSPECT r DO BEGIN
    IF satisfied(topcond,r) THEN
    BEGIN
      IF setfollow THEN r:-getowner(r,followset);
      IF r == NONE THEN GOTO fin;
      IF fileout THEN
      BEGIN
	TEXT tt; INTEGER kk;
	tt:-intput(r.dbskey);
	indrtype:-r.spec.rname;
	invx(fx).Setpos(1); kk:=search(invx(fx),tt);
	IF kk > invx(fx).Length THEN invx(fx):-conc(invx(fx),bl1,tt)
	ELSE nrof_hits:=nrof_hits-1;
	;
      END ELSE
      IF filewrite THEN wtabfile(r) ELSE tabulate(r);
      nrof_hits:=nrof_hits+1;
    END;
    fin:
  END of check_write;

  BOOLEAN PROCEDURE setcheck(t); TEXT t;
  BEGIN REF (setspec) ss;
    ss:-getsetspec(t); IF ss == NONE THEN
    BEGIN
      outline("Set undefined !"); setcheck:=TRUE;
    END ELSE
    BEGIN
      otype:-ss.ownertype;
      mtype:-ss.membertype;
      IF  otype == NOTEXT OR mtype == NOTEXT THEN
      BEGIN
	outline("Set not well-defined !"); setcheck:=TRUE;
      END;
    END;
  END of setcheck;



  PROCEDURE select;
  BEGIN TEXT t,u; REF (condarray) cond1;
    REF (record) toprec; REF (rspec) rtsave;
    REF(action) f; INTEGER level,lmax,fxsave;
    BOOLEAN fusave;
    REF (action) ARRAY setstack[0:20];
    CLASS action(setname,owntype,membtype,conds);
    TEXT setname,owntype,membtype; REF (condarray) conds;
    BEGIN
      lmax:=lmax+1; setstack(lmax):-THIS action;
    END of action;

    PROCEDURE scanset(r); REF (record) r;
    INSPECT setstack(level) DO
    BEGIN
      IF satisfied(conds,r) THEN
      BEGIN
	IF level < lmax THEN
	BEGIN
	  level:=level+1;
	  mapset(r,setname,scanset);
	  level:=level-1;
	END ELSE
	mapset(r,setname,check_write);
      END;
    END scanset;

    rtsave:-rtyp; fusave:=fileout; fxsave:=fx;
    IF \scanagain THEN BEGIN fx:=1; invx(1):-NOTEXT; END;
    parmcheck(2);
    indcond:-Blanks(150);
    next:
    stringrequest("Set:",u);
    t:-Copy(u);
    t:-upcase(t.Strip);
    IF t = ".TYPE" THEN fileout:=FALSE;
    IF t = ".INDEX" THEN fileout:=TRUE;
    IF t = ".TYPE" OR t = ".INDEX" THEN
    BEGIN
      outline("Final conditions: ");
      rtyp:-getrecordspec(otype);
      topcond:-readconds(FALSE);
      level:=1;
      rtyp:-rtsave;
      IF toprec == NONE THEN
      BEGIN
	IF scanagain THEN scanindex(scanset) ELSE
	doforeach(setstack(level).owntype,scanset);
      END ELSE
      BEGIN
	fx:=fx+1; invx(fx):-NOTEXT; scanset(toprec);
      END;

      IF fileout THEN nextstep;
    END ELSE
    BEGIN
      t:-scanto(u,',');
      IF setcheck(t) THEN GOTO next;
      IF lmax = 0 THEN toprec:-get(rest(u),otype);
      outline("Conditions: ");
      rtyp:-getrecordspec(otype);
      cond1:-readconds(FALSE);
      f:-NEW action(t,otype,mtype,cond1);
      otype:-mtype;
      GOTO next;
    END;
    fin:
    rtyp:-rtsave; fileout:=fusave; fx:=fxsave;
  END of select;

  PROCEDURE nextstep;
  BEGIN INTEGER n,m; TEXT ARRAY ta[1:4];
    REF (rspec) rtsave;
    BOOLEAN PROCEDURE nexttest(t); TEXT t;
    BEGIN
      IF t.Length<=1 THEN GOTO fin;
      c:=upcase(t.Sub(2,1)).Getchar;
      IF c = 'A' OR c = 'D' OR c = 'N' OR
      c = 'I' OR c = 'E' THEN nexttest:=TRUE;
      fin:
    END of nexttest;
    Outtext("Number of ");
    Outtext(indrtype); Outtext(" records found =");
    Outint(nrof_hits,6);
    Outimage;
    stringrequest("Next action: ",t);
    IF \nexttest(t) THEN GOTO fin;

    IF c = 'A' THEN scanagain:=TRUE
    ELSE scanagain:=FALSE;
    IF c = 'D' OR c = 'N' THEN
    BEGIN
      IF c = 'N' THEN nameonly:=TRUE;
      rtsave:-rtyp; rtyp:-getrecordspec(indrtype);
      scanindex(outrecord);
      rtyp:-rtsave;
      nameonly:=FALSE;
    END;
    IF c = 'I' THEN
    BEGIN
      n:=splita(t,komma,ta,4); IF n < 2 THEN GOTO fin;
      t1:-getrecordid(ta(2),"INDEXFILE");
      indexstore(t1,nrof_hits,indcond.Strip,ta(3));
    END;

    IF c='E' THEN scanagain:=FALSE;
    fin:
  END of nextstep;



  PROCEDURE indexstore(iname,n,icond,irem);
  VALUE icond;
  TEXT iname,icond,irem; INTEGER n;
  BEGIN
    TEXT u,t,b,c,ind;
    b:-backslash; c:-intput(n);
    ind:-invx(fx).Strip;
    t:-conc(iname,b,c,b,indrtype,b,icond,b,irem,b,ind);
    put_record(getrecordspec("INDEXFILE"),t);
  END of indexstore;

  PROCEDURE scanindex(p); PROCEDURE p;
  BEGIN TEXT tsave;
    tsave:-invx(fx).Strip; fx:=fx+1;
    invx(fx):-NOTEXT;
    WHILE tsave.More DO
    BEGIN
      k:=scanint(tsave); refr:-rtyp.prototype;
      r:-getrec(k); IF r =/= NONE THEN p(r);
    END;
  END of scanindex;

  PROCEDURE checkfile(t); TEXT t;
  IF t =/= NOTEXT THEN
  BEGIN
    t:-upcase(t);
    IF t = "NAMES" THEN
    BEGIN filewrite:=FALSE;  nameonly:=TRUE; END ELSE
    BEGIN
      IF tabdim = 0 THEN
      outline("No table specified for output !");
      IF tabfile =/= NONE AND tabfile =/= Sysout THEN tabfile.Close;
      IF t = "SYSOUT" THEN tabfile:-Sysout ELSE
      BEGIN
	tabfile:-NEW Outfile(t); tabfile.Open(Blanks(blksize));
      END;
      filewrite:=TRUE;
    END;
  END ELSE filewrite:=FALSE;

  PROCEDURE checkifset(t); TEXT t;
  BEGIN
    setfollow:=getsetspec(t) =/= NONE;
    followset:-t;
  END;

  PROCEDURE parmcheck(n); INTEGER n;
  BEGIN checkfile(opa(n)); checkifset(opa(n+1)); END;

  PROCEDURE scan;
  BEGIN BOOLEAN savesc;
    savesc:=scanagain;
    parmcheck(2);
    indcond:-Blanks(150); indcond.Sub(1,4):=opa(1);
    indcond.Setpos(5);
    topcond:-readconds(orconnections);
    IF scanagain THEN scanindex(check_write) ELSE
    BEGIN
      fx:=1; invx(fx):-NOTEXT;
      doforeach(recordtype,check_write);
    END;
    IF fileout THEN nextstep;
    IF savesc THEN BEGIN fx:=1; scanagain:=TRUE; END;
  END of scan;

  BOOLEAN PROCEDURE index_ok;
  BEGIN
    t:-opa(2);
    r:-getrecm(t,"INDEXFILE",fin);
    index_ok:=TRUE;
    Outtext("Nr of "); Outtext(r.avalues(3));
    outline2(" records = ",r.avalues(2));
    rtypsave:-rtyp; rtyp:-getrecordspec(r.avalues(3));
    invx(1):-r.avalues(6);
    fin:
  END of index_ok;



  INTEGER PROCEDURE oper;
  BEGIN INTEGER n,m; TEXT t;
    oper:=15;
    t:-keyvalue.Strip; IF t == NOTEXT THEN GOTO fin2;
    IF d__file == NONE THEN
    BEGIN ! first of all a file must be opened;
      IF t.Length > 6 THEN
      BEGIN TEXT v;
	v:-upcase(t.Sub(1,4));
	IF v = ".OPE" THEN GOTO ook;
      END;
      outline("Please use .OPEN command to open a data base file !");
      GOTO fin2;
      ook:
    END;
    IF t.Sub(1,1) \= "." THEN n:=1 ELSE
    BEGIN
      m:=splita(t,komma,opa,20);
      opa(1):-upcase(opa(1));
      IF opa(1).Length < 4 THEN
      BEGIN IF opa(1) = ".OR" THEN n:=3; GOTO fin; END;
      n:=loctext(upcase(t.Sub(2,3)),oparr);
      IF n = 0 THEN GOTO fin;
      IF m-1<opargs(n) THEN outline("Too few arguments !");
    END;
    fin:
    IF n = 0 THEN
    BEGIN REF (record) r; TEXT u;
      u:-scanto(t,ckomma); u:-u.Sub(2,u.Length-1); right_part:-rest(t);
      r:-get(u,"CPROC"); IF r =/= NONE THEN comproc:-getcproc(r) ELSE
      outline("Illegal command !");
    END ELSE IF rtyp == NONE AND n < 6 THEN
    outline("Please do .type,rname to specify current record type !")
    ELSE oper:=n;
    fin2:
  END of oper;

  BOOLEAN PROCEDURE tab_pres;
  BEGIN
    INTEGER i;
    r:-getrecm(tabname,"TABLE",fin);
    outline("FIELDS: "); outline(r.avalues(2));
    outline("COLUMNS: "); outline(r.avalues(3));
    outline("REMARK: "); outline(r.avalues(5));
    FOR i:=1 STEP 1 UNTIL 5 DO opa(i):-r.avalues(i);
    tab_pres:=TRUE;
    fin:
  END of tab_pres;

  PROCEDURE keyindex;
  BEGIN
    INTEGER inddim; TEXT t2;
    TEXT ARRAY keynames[1:50];
    t:- opa(2);
    IF t == NOTEXT THEN
    BEGIN
      stringrequest("Give index name:",t);
      IF t == NOTEXT THEN GOTO fin;
      t:-t.Strip;
    END;
    IF opa(3) == NOTEXT THEN opa(3):-Copy(bl1);
    t:-getrecordid(t,"INDEXFILE");
    stringrequest("KEYS:",opa(4));
    inddim:= splita(opa(4),komma,keynames,50);
    fx:=1; invx(fx):-NOTEXT;
    FOR n:=1 STEP 1 UNTIL inddim DO
    BEGIN
      r:- getrecm(keynames(n),recordtype,fin);
      t2:-intput(r.dbskey); invx(fx):-conc(invx(fx),bl1,t2);
    END;
    indrtype:-rtyp.rname;
    indexstore(t,inddim," ",opa(3));
    fin:
  END OF KEYINDEX;

  BOOLEAN PROCEDURE tabfilspec;
  BEGIN
    REF (setspec) setc; REF (rspec) typsave,typc;
    PROCEDURE exit(t); VALUE t; TEXT t;
    BEGIN outline(t); GOTO fin; END;
    typsave:-typc:-rtyp;
    tabdim:=splita(opa(2),komma,tabnames,80);
    k:=splita(opa(3),komma,tabpos,80);
    IF k < tabdim THEN exit("too few columns !");
    blksize:=scanint(tabpos(k)); IF k = tabdim THEN blksize:=blksize+20;
    tabpos(k).Setpos(1);
    fieldpos(tabdim+1):=blksize;
    IF blksize < 0 THEN exit("Blksize less than 0");
    FOR k:=1 STEP 1 UNTIL tabdim DO
    BEGIN
      fieldpos(k):=scanint(tabpos(k));
      IF fieldpos(k) >= 0 THEN
      BEGIN
	IF tabnames(k).Strip == NOTEXT THEN fieldloc(k):=0 ELSE
	BEGIN
	  fieldloc(k):=loctext(tabnames(k),typc.anames);
	  IF fieldloc(k) = 0 THEN
	  BEGIN Outtext("Field undefined: ");
	  exit(tabnames(k)); END;
	END;
      END ELSE IF fieldpos(k) > -10000 THEN
      BEGIN ! switch of context to owner record;
	setc:-getsetspec(tabnames(k));
	IF setc == NONE THEN
	BEGIN Outtext("SET UNDEFINED: "); exit(tabnames(k)); END;
	typc:-getrecordspec(setc.ownertype);
      END ELSE exit("Incorrect columns");
    END;
    tabfilspec:=TRUE;
    fin:
    rtyp:-typsave;
  END of tabfilspec;



  PROCEDURE tabspecstore;
  BEGIN TEXT b;
    IF store_tab THEN
    BEGIN
      IF \ny_tab THEN tabname:-getrecordid(tabname,"TABLE");
      b:-backslash;
      u:-conc(tabname,b,opa(2),b,opa(3),b,opa(4),b,opa(5));
      put_record(getrecordspec("TABLE"),u);
    END;
  END of tabspecstore;

END of fetch2;