Google
 

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