Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/libsim/fetch1.sim
There is 1 other file named fetch1.sim in the archive. Click here to see a list.
OPTIONS(/external);
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Directfile) PROCEDURE finddirectfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL TEXT PROCEDURE conc,upcase,frontstrip,rest,checkextension;
EXTERNAL BOOLEAN PROCEDURE puttext;
EXTERNAL INTEGER PROCEDURE arrlgd;
EXTERNAL PROCEDURE arrtxt;
EXTERNAL TEXT PROCEDURE front,scanto,getitem,tsub;
EXTERNAL INTEGER PROCEDURE maxint,search,splita,hash;
EXTERNAL PROCEDURE split;
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;
dbmset CLASS fetch1;
VIRTUAL: LABEL nextkey;
BEGIN
TEXT bl1;
REAL tolerans; REF (rspec) rtyp; TEXT err,indcond;
BOOLEAN ARRAY swi[1:10];
TEXT ARRAY ops[1:8];
REF (condition) ARRAY rconds(1:20);
CLASS cproc(Line); TEXT Line; BEGIN REF (cproc) next; END;
REF (cproc) comproc;
TEXT right_part; TEXT ARRAY argument[1:20];
!========================= REPLACE ==========================;
! Replace byter ut den delstr{ng i t som b`rjar i start och
! har l{ngden l mot str{ngen string. T.pos uppdateras;
!--------------------------------------------------------------;
TEXT PROCEDURE replace(t,start,l,string);
NAME t; VALUE string;
TEXT t,string; INTEGER start,l;
BEGIN TEXT t1,t2,t3; INTEGER nypos;
t1:-t; nypos:=t1.Pos;
IF nypos > start THEN nypos:=nypos+string.Length-l;
t2:-tsub(t1,1,start-1);
t3:-tsub(t1,start+l,t1.Length-start-l+1);
t1:-conc(t2,string,t3);
t1.Setpos(nypos);
t:-t1;
END of replace;
!============ behandling av kommandoprocedurer ==========;
PROCEDURE makecproc(namn); VALUE namn; TEXT namn;
BEGIN REF(record)r; TEXT t,u,v;
TEXT ARRAY aval[1:3];
stringrequest("Description: ",aval(3));
outline("Procedure:");
WHILE v \= "END" DO
BEGIN
u:-IF u==NOTEXT THEN t ELSE conc(u,"!",t);
stringrequest(": ",t); v:-upcase(Copy(t));
END;
aval(1):-upcase(namn);
aval(2):-u;
IF aval(2)=/=NOTEXT THEN
NEW record(getrecordspec("CPROC"),aval).store;
END MAKECPROC;
REF (cproc) PROCEDURE getcproc(r); REF(record) r;
BEGIN TEXT t,v; INTEGER k; REF(cproc)cprev,c;
COMMENT Plocka fram argumenten,bilda lista av 'cproc'
och byt ut formella mot aktuella argument;
right_part.Setpos(1);
FOR k:=1 STEP 1 UNTIL 9 DO
IF NOT right_part.More THEN argument(k):-NOTEXT ELSE
IF right_part.Sub(right_part.Pos,1) = "'" THEN
BEGIN right_part.Getchar;
argument(k):-scanto(right_part,''');
scanto(right_part,',');
END ELSE argument(k):-scanto(right_part,',');
t:-r.avalues(2);
WHILE t.More DO
BEGIN v:-scanto(t,'!');
scanto(v,'%'); WHILE v.More DO
BEGIN k:=v.Sub(v.Pos,1).Getint;
v.Setpos(v.Pos+1);
replace(v,v.Pos-2,2,argument(k));
scanto(v,'%');
END;
v.Setpos(1); c:-NEW cproc(v);
IF cprev==NONE THEN getcproc:-c ELSE cprev.next:-c;
cprev:-c;
END;
IF t.Sub(t.Length,1)="!" THEN cprev.next:-c:-NEW cproc(NOTEXT);
c.next:-comproc;
END getcproc;
!===========slut p} kommandoprocedurer=================;
CLASS condition(set,vpos,op,konst,next);
INTEGER vpos,op; TEXT set,konst; REF (condarray) next;;
CLASS condarray(orconnect,dim); BOOLEAN orconnect; INTEGER dim;
BEGIN REF (condition) ARRAY conds(0:dim);
IF dim > 0 THEN
FOR k__:=1 STEP 1 UNTIL dim DO conds(k__):-rconds(k__);
END of condarray;
PROCEDURE stringrequest(t1,t3); NAME t3; VALUE t1;
TEXT t1,t3;
BEGIN TEXT t,u,lastc;
TEXT PROCEDURE nextcom;
BEGIN
t:-comproc.Line; comproc:-comproc.next;
IF \swi(2) THEN BEGIN Outtext(t1); outline(t); END;
END;
IF comproc == NONE THEN request(t1,"",textinput(t,TRUE),"",allhelp)
ELSE nextcom;
IF t =/= NOTEXT THEN
BEGIN
lastc:-t.Sub(t.Length,1); WHILE lastc = "&" DO
BEGIN
t:-t.Sub(1,t.Length-1); u:-conc(u,t);
IF comproc == NONE THEN request("*","",textinput(t,TRUE),"",
help("type continuation line (previous line ended with &)."))
ELSE nextcom;
lastc:-IF t == NOTEXT THEN backslash ELSE t.Sub(t.Length,1);
END;
u:-conc(u,t);
t3:-u;
END ELSE t3:-t;
IF t = ".." THEN GOTO nextkey;
END stringrequest;
BOOLEAN PROCEDURE allhelp;
helpmess(upcase(mainprompt.Strip));
BOOLEAN PROCEDURE tcheck(k,w);
INTEGER k; TEXT w;
BEGIN
IF k < 3 THEN
BEGIN ! check type for inreger,real;
IF k = 1 THEN
BEGIN
IF checkint(w) > 0 AND checkint(w) = 0 THEN tcheck:=TRUE;
END ELSE
IF checkreal(w) > 0 AND checkreal(w) = 0 THEN tcheck:=TRUE;
END ELSE tcheck:=TRUE;
END of tcheck;
PROCEDURE prompt(rectype); TEXT rectype;
BEGIN
TEXT ARRAY errmess[1:3],setarr[1:10];
INTEGER tantal,i,m,n,k,setnr;
TEXT t,tin,tarea,err,tpr; BOOLEAN error,setact; REF(rspec) r;
BOOLEAN PROCEDURE checktype;
BEGIN
IF \tcheck(m,tin) THEN
BEGIN err:-errmess(m); checktype:=TRUE; END ELSE
tarea:-conc(tarea,backslash,tin);
fin:
END of checktype;
BOOLEAN PROCEDURE checkset(t); TEXT t;
BEGIN
nextstab:-stab; WHILE nextstab =/= NONE DO
BEGIN IF t = nextstab.ownertype OR t = nextstab.membertype THEN
BEGIN setnr:=setnr+1; setarr(setnr):-nextstab.setname;
checkset:=TRUE; END;
nextstab:-nextstab.next;
END;
END of checkset;
BOOLEAN PROCEDURE checkname(t); TEXT t;
BEGIN INTEGER k;
FOR k:=1 STEP 1 UNTIL setnr DO
BEGIN IF setarr(k) = t THEN GOTO fin; END;
checkname:=TRUE;
fin: END of checkname;
r:-getrecordspec(rectype); IF r == NONE THEN
BEGIN outline("NO SUCH RECORD TYPE!"); GOTO fin; END;
setact:=checkset(rectype);
errmess(1):-Copy("Should be integer !");
errmess(2):-Copy("Should be real !");
tantal:=r.adim;
FOR i:=1 STEP 1 UNTIL tantal DO
BEGIN IF setact AND \checkname(r.anames(i))
THEN tarea:-conc(tarea,backslash,NOTEXT) ELSE
BEGIN
m:=r.atypes(i);
current_spec:-r;
tpr:-conc(r.anames(i),": ");
reqf: stringrequest(tpr,tin);
IF checktype THEN BEGIN outline(err); GOTO reqf; END;
END;
END;
tarea:-tarea.Sub(2,tarea.Length-1);
put_record(r,tarea);
fin:
END of prompt;
BOOLEAN PROCEDURE compare(c,r);
REF (record) r; REF (condition) c;
! check that record r satisfies condition c;
BEGIN BOOLEAN b; INTEGER i,j,k; REAL x,y;
INTEGER vtype; TEXT v;
SWITCH loadvarb:=int,rel,cmp;
SWITCH comp:=eq_,less_,greater_,less_eq,
greater_eq,not_eq;
IF c.next =/= NONE THEN
BEGIN b:=satisfied(c.next,r); GOTO fin; END;
IF c.set =/= NOTEXT THEN
BEGIN ! condition concerns owner in a particular set;
r:-getowner(r,c.set);
IF r == NONE THEN GOTO fin;
END;
vtype:=r.spec.atypes(c.vpos); v:-r.avalues(c.vpos);
GOTO loadvarb(vtype);
int: j:=c.konst.Getint; i:=v.Getint; GOTO cmp;
rel: x:=v.Getreal; y:=c.konst.Getreal;
cmp: GOTO comp(c.op);
eq_: IF vtype = 1 THEN b:=i=j ELSE
IF vtype = 2 THEN b:=Abs(x-y) < tolerans ELSE
b:=v = c.konst; GOTO fin;
less_: IF vtype = 1 THEN b:=i<j ELSE
IF vtype = 2 THEN
b:= (y-x) > tolerans ELSE
b := v < c.konst; GOTO fin;
greater_: IF vtype = 1 THEN b := i > j ELSE
IF vtype = 2 THEN
b:= (x-y) > tolerans ELSE
b := v > c.konst; GOTO fin;
less_eq: IF vtype = 1 THEN b:=i <= j ELSE
IF vtype = 2 THEN
b:= (y-x) >= tolerans ELSE
b := v <= c.konst; GOTO fin;
greater_eq: IF vtype = 1 THEN b := i >= j ELSE
IF vtype = 2 THEN
b:= (x-y) >= tolerans ELSE
b := v >= c.konst; GOTO fin;
not_eq: IF vtype = 2 THEN b:=Abs(x-y) > tolerans ELSE
b:= v \= c.konst;
fin:
compare := b;
END of compare;
BOOLEAN PROCEDURE checkc(t,rc,rcx);
NAME rcx;
TEXT t; REF (condition) ARRAY rc; INTEGER rcx;
! check that text t is a condition of the form:
! ATTRIBUTE OPERATTOR CONSTANT
! operators allowed: = < > <= >= /=
;
BEGIN
INTEGER k,m,n; TEXT u,v,w; CHARACTER c;
TEXT setname; REF (rspec) rtypsave; REF (setspec) ss;
BOOLEAN orcond;
PROCEDURE errexit(t); VALUE t; TEXT t;
BEGIN err:-t; GOTO fin; END;
INTEGER PROCEDURE lok(c); CHARACTER c;
BEGIN t.Setpos(1); scanto(t,c); IF t.More THEN lok:=t.Pos; END;
rtypsave:-rtyp; err:-NOTEXT;
IF t == NOTEXT THEN GOTO fin;
IF t = ".or" OR t = ".OR" THEN orcond:=TRUE;
IF orcond OR t = ".and" OR t = ".AND" THEN
BEGIN
rcx:=rcx+1; currentfile.Setpos(0);
rc(rcx):-NEW condition(setname,0,0,NOTEXT,readconds(orcond));
GOTO fin;
END;
k:=lok('<'); IF k = 0 THEN k:=lok('>');
IF k = 0 THEN k:=lok('/'); IF k = 0 THEN k:=lok('=');
IF k = 0 THEN errexit("operator missing ? ");
m:=k; c:=t.Getchar;
t:-t.Strip;
u:-t.Sub(1,k-2).Strip;
! check if two-byte operator;
IF c = '=' THEN k:=k+1;
v:-t.Sub(m-1,k-m+1); w:-frontstrip(t.Sub(k,t.Length-k+1));
! remove leading spaces from w;
c:=' '; WHILE w.More AND c = ' ' DO c:=w.Getchar;
w:-w.Sub(w.Pos-1,w.Length-w.Pos+2);
! when condition concerns owner in a set, separate set name
and field name, check that there is a set with that name;
IF u.Sub(1,1) = ":" THEN
BEGIN
scanto(u,'.'); IF \u.More THEN errexit("Illegal condition !");
m:=u.Pos; setname:-u.Sub(2,m-3); u:-u.Sub(m,u.Length-m+1);
ss:-getsetspec(setname); IF ss == NONE THEN
errexit("Set undefined !");
rtyp:-getrecordspec(ss.ownertype);
END;
! check that left part is an attribute of current record type;
m:=loctext(u,rtyp.anames);
IF m = 0 THEN errexit("invalid attribute ? ");
IF \tcheck(rtyp.atypes(m),w) THEN
errexit("Wrong type on right part ");
k:=loctext(v,ops); IF k = 0 THEN errexit("Invalid operator ?");
rcx:=rcx+1;
rc(rcx):-NEW condition(setname,m,k,w,NONE);
fin:
rtyp:-rtypsave; checkc:=err =/= NOTEXT;
END of checkc;
REF (condarray) PROCEDURE readconds(orcond);
BOOLEAN orcond;
! read conditions for retrival and check them;
BEGIN TEXT t; INTEGER k;
REF (condition) ARRAY rcarr(1:50); INTEGER rcx;
rcx:=0;
next:
stringrequest("*",t);
IF checkc(t,rcarr,rcx) THEN
BEGIN outline(err); GOTO next; END;
IF t =/= NOTEXT THEN
BEGIN
indcond.Sub(indcond.Pos,1):=",";
indcond.Sub(indcond.Pos+1,t.Length):=t;
indcond.Setpos(indcond.Pos+1+t.Length);
GOTO next;
END;
FOR k:=1 STEP 1 UNTIL rcx DO rconds(k):-rcarr(k);
readconds:-NEW condarray(orcond,rcx);
END of readconds;
BOOLEAN PROCEDURE satisfied(carr,r);
REF (condarray) carr; REF (record) r;
BEGIN INTEGER k;
INSPECT carr DO
BEGIN
IF dim = 0 THEN GOTO yes;
FOR k:=1 STEP 1 UNTIL dim DO
BEGIN
IF compare(conds(k),r) THEN
BEGIN IF orconnect THEN GOTO yes; END ELSE
IF NOT orconnect THEN GOTO fin;
END;
IF orconnect THEN GOTO fin;
END;
yes: satisfied:=TRUE;
fin:
END of satisfied;
bl1:-Blanks(1);
INNER;
END of fetch1;