Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/21/prep.sim
There is 1 other file named prep.sim in the archive. Click here to see a list.
BEGIN
EXTERNAL TEXT PROCEDURE conc,front,scanto,upcase,
frontstrip,rest,getitem,request;
EXTERNAL PROCEDURE split,arrtxt;
EXTERNAL INTEGER PROCEDURE checkint,scanint,
maxint,search,splita,hash,arrlgd;
EXTERNAL CLASS dbmmin;
dbmmin("",0,TRUE) BEGIN
BOOLEAN load,wr4switch,wr5switch,wr6switch,linkrec;
TEXT ARRAY recordtypes(1:20);
TEXT ARRAY loadsym,storesym(1:6),keyconv(1:2);
TEXT ARRAY cparm(1:6),cptexts(1:20),recparm(1:50);
TEXT iterms,rterms,txterms,iaterms,raterms,taterms,allterms;
INTEGER nparms,j,k,n,nr_of_rec,cpmax,loopc;
TEXT t,u,uu,z,outfname,outbuf,rcname,cptext,rclasstype,keytext;
REF (Outfile) outf;
REF (rspec) rtyp;
TEXT PROCEDURE intput(n); INTEGER n;
BEGIN uu.Putint(n); intput:-frontstrip(uu); END;
PROCEDURE outlong(t); VALUE t; TEXT t;
BEGIN CHARACTER c;
WHILE t.More DO
BEGIN
c:=t.Getchar;
outf.Outchar(c);
IF outf.Image.Pos > 50 AND c = ',' THEN outf.Outimage;
END;
END;
PROCEDURE split_types(r); REF (rspec) r;
INSPECT r DO
BEGIN INTEGER k;
TEXT PROCEDURE addterm(t,u); TEXT t,u;
IF t == NOTEXT THEN addterm:-u ELSE
addterm:-conc(t,conc(komma,u));
FOR k:=1 STEP 1 UNTIL adim DO
BEGIN SWITCH cons := int,rel,txt,inta,rela,txta;
allterms:-addterm(allterms,anames(k));
GOTO cons(atypes(k));
int: iterms:-addterm(iterms,anames(k)); GOTO l2;
rel: rterms:-addterm(rterms,anames(k)); GOTO l2;
txt: txterms:-addterm(txterms,anames(k)); GOTO l2;
inta: iaterms:-addterm(iaterms,anames(k)); GOTO l2;
rela: raterms:-addterm(raterms,anames(k)); GOTO l2;
txta: taterms:-addterm(taterms,anames(k));
l2:
END;
END of split_types;
TEXT PROCEDURE tproc(t); TEXT t;
BEGIN INTEGER k;
k:=rtyp.atypes(j);
IF load THEN tproc:-loadsym(k) ELSE
BEGIN ! augment string of actual parameters;
cptext:-IF cptext==NOTEXT THEN cparm(k) ELSE
conc(cptext,komma,cparm(k));
tproc:-storesym(k); END;
END;
! START OF MAIN ________________________________;
uu:-Blanks(12);
loadsym(1):-Copy("SCANINT(");
storesym(1):-Copy("intput(");
loadsym(2):-Copy("SCANREAL(");
storesym(2):-Copy("realput(");
loadsym(3):-NOTEXT;
storesym(3):-NOTEXT;
loadsym(4):-Copy("getintar(");
storesym(4):-Copy("intarput(");
loadsym(5):-Copy("getrealar(");
storesym(5):-Copy("realarput(");
loadsym(6):-Copy("gettextar(");
storesym(6):-Copy("textarput(");
cparm(1):-Copy("0"); cparm(2):-Copy("0.0");
cparm(3):-Copy("notext");
cparm(4):-cparm(5):-cparm(6):-Copy("none");
keyconv(1):-Copy("intput(");
keyconv(2):-Copy("textreal(");
outbuf :- Blanks(80);
askdb:
request("Data base file: ","x",load_file,TRUE,"","");
request("Image size: ","68",z,TRUE,"",NOTEXT);
imsize:=scanint(z);
openbase(load_file,imsize);
IF \defined__f THEN
BEGIN Outtext("Base undefined !"); Outimage; GOTO askdb; END;
request("Output file (without extension):","",
outfname,TRUE,"",
"FILE FOR GENERATED SOURCE CODE., EXTENSION SIM ALWAYS ASSUMED");
outf :- NEW Outfile(conc(outfname,Copy(".sim")));
outf.Open(outbuf);
n := 0;
request("Records to expand: ",
NOTEXT,t,TRUE,"?",
"Example: RTYP1,RTYP2,RTYP3");
nr_of_rec:=splita(t,komma,recordtypes,20);
request("Linked records? ","NO",z,TRUE,"?",
"Answer yes if sets are used");
IF z.Length > 0 THEN linkrec:=upcase(z).Getchar = 'Y';
INSPECT outf DO
BEGIN
PROCEDURE outclass(arr_typ); VALUE arr_typ; TEXT arr_typ;
BEGIN outline(conc("class ",arr_typ,"__arr(dim); integer dim;"));
Outtext(conc("begin ",arr_typ));
IF rtyp.atypes(j)=4 THEN Outtext("eger");
Outtext(" array vekt(1:dim+1);"); Outimage;
outline(conc("end of ",arr_typ,"__arr;"));
END of outclass;
PROCEDURE outarput(arr_typ,put_typ); VALUE arr_typ,put_typ;
TEXT arr_typ,put_typ;
BEGIN outline(conc("text procedure ",arr_typ,"arput(arr_); ref (",
arr_typ,"__arr) arr_;"));
outline("begin i_:=arr_.dim;");
IF rtyp.atypes(j)\=6 THEN
outline(conc("t_:-copy(",put_typ,"(arr_.vekt(1)));")) ELSE
outline("t_:-arr_.vekt(1);");
outline("for k_:=2 step 1 until i_ do");
IF rtyp.atypes(j)\=6 THEN
outline(conc("t_:-conc(t_,arrchar,copy(",
put_typ,"(arr_.vekt(k_))));")) ELSE
outline("t_:-conc(t_,arrchar,arr_.vekt(k_));");
outline(conc(arr_typ,"arput:-t_;"));
outline(conc("end of ",arr_typ,"arput;"));
END of outarput;
PROCEDURE outgetar(arr_typ,get_typ);
VALUE arr_typ,get_typ; TEXT arr_typ,get_typ;
BEGIN outline(conc("ref (",arr_typ,"__arr) procedure get",
arr_typ,"ar(t);"));
outline("text t;");
outline(conc("begin ref (",arr_typ,"__arr) arr_;"));
outline("i_:=splita(t,arrchar,splitarr,200);");
outline(conc("arr_:-new ",arr_typ,"__arr(i_);"));
outline("for k_:=1 step 1 until i_ do");
IF rtyp.atypes(j)\=6 THEN
outline(conc("arr_.vekt(k_):=splitarr(k_)",get_typ,";")) ELSE
outline("arr_.vekt(k_):-splitarr(k_);");
outline(conc("get",arr_typ,"ar:-arr_;"));
outline(conc("end of get",arr_typ,"ar;"));
END of outgetar;
PROCEDURE outspec(t,ttyp); NAME ttyp; TEXT t,ttyp;
BEGIN
IF t =/= NOTEXT THEN
BEGIN Outtext(ttyp); outlong(t); outline(";"); END;
END of outspec;
PROCEDURE outline(t); VALUE t; TEXT t;
BEGIN Outtext(t); Outimage; END;
outline("options(/external);");
outline("EXTERNAL REF (Infile) PROCEDURE findinfile;");
outline("EXTERNAL REF (Outfile) PROCEDURE findoutfile;");
outline(
"EXTERNAL TEXT PROCEDURE conc,front,scanto,upcase,");
outline("frontstrip,rest,checkextension,getitem;");
outline("EXTERNAL CHARACTER PROCEDURE fetchar,findtrigger;");
outline("EXTERNAL LONG REAL PROCEDURE scanreal;");
outline("EXTERNAL PROCEDURE split,arrtxt;");
outline("EXTERNAL INTEGER PROCEDURE checkreal,checkint,scanint,ilog,");
outline("maxint,search,splita,hash,arrlgd;");
outline("EXTERNAL BOOLEAN PROCEDURE menu,puttext;");
Outtext("external class ");
Outtext("safeio,simdbm");
IF linkrec THEN outline(",dbmset;") ELSE outline(";");
IF linkrec THEN Outtext("dbmset") ELSE Outtext("simdbm");
Outtext(" class "); Outtext(outfname); Outchar(';'); Outimage;
outline("begin");
outline("text array noargs[1:1],splitarr[1:200];");
outline("text b_,t_;");
outline("integer i_,k_;");
outline("ref (rspec) r;");
n:=0; WHILE n < nr_of_rec DO
BEGIN
iaterms:-raterms:-taterms:-NOTEXT;
iterms:-rterms:-txterms:-allterms:-NOTEXT;
n:=n+1; rcname:-recordtypes(n);
rtyp:-getrecordspec(rcname);
IF rtyp == NONE THEN
BEGIN
Sysout.Outtext("record type undefined : ");
Sysout.Outtext(rcname); Sysout.Outimage;
END ELSE
BEGIN
nparms:=rtyp.adim;
split_types(rtyp);
j:=loctext(rtyp.key,rtyp.anames); j:=rtyp.atypes(j);
IF j < 3 THEN
keytext:-conc(keyconv(j),conc(rtyp.key,Copy(")")))
ELSE keytext:-rtyp.key;
FOR j:=1 STEP 1 UNTIL nparms DO
BEGIN IF rtyp.atypes(j)=4 AND \wr4switch THEN
BEGIN Outimage; outclass("int");
Outimage; outarput("int","intput");
Outimage; outgetar("int",".getint");
wr4switch:=TRUE;
END;
IF rtyp.atypes(j)=5 AND \wr5switch THEN
BEGIN Outimage; outclass("real");
Outimage; outarput("real","realput");
Outimage; outgetar("real",".getreal");
wr5switch:=TRUE;
END;
IF rtyp.atypes(j)=6 AND \wr6switch THEN
BEGIN Outimage; outclass("text");
Outimage; outarput("text",NOTEXT);
Outimage; outgetar("text",NOTEXT);
wr6switch:=TRUE;
END;
END;
COMMENT generate record class;
Outimage;
Outtext("record class ");
Outtext(rcname); Outchar('(');
outlong(allterms); outline("); ");
outspec(iterms,"integer ");
outspec(rterms,"real "); outspec(txterms,"text ");
outspec(iaterms,"ref (int__arr) ");
outspec(raterms,"ref (real__arr) ");
outspec(taterms,"ref (text__arr) ");
outline("begin");
Outtext("text procedure getkey; getkey:-");
Outtext(keytext); outline(";");
outline("procedure store; inspect d__file do");
outline("begin text s;");
Outtext("dbskey:=lookup("); Outtext(keytext);
Outtext(",spec);");
outline("locate(dbskey);");
loopc:=0;
Outtext("s:-conc(");
FOR j:=1 STEP 1 UNTIL nparms DO
BEGIN COMMENT create input code for parameters;
load:=FALSE;
u:-tproc(rtyp.anames(j));
Outtext(u);
Outtext(rtyp.anames(j));
IF u=/=NOTEXT THEN Outtext(")");
IF j<nparms THEN
BEGIN Outtext(komma); Outtext("b_,");
END ELSE Outtext(");");
IF loopc > 1 THEN
BEGIN Outimage; loopc:=0; END ELSE loopc:=loopc+1;
END;
IF loopc > 0 THEN Outimage;
outline("storerecord(SYNPOINTER,s);");
outline("end of store;");
cpmax:=cpmax+1; cptexts(cpmax):-cptext;
cptext:-NOTEXT;
Outtext("ref ("); Outtext(rcname);
outline(") procedure load(t); value t; text t;");
Outtext("begin ref ("); Outtext(rcname);
outline(") r;");
outline("text array avalues[1:spec.adim];");
outline("t:-t.strip;");
outline("splita(t,b_,avalues,spec.adim);");
Outtext("r:-new "); Outtext(rcname); Outchar('(');
Outtext("spec,avalues,");
load:=TRUE;
FOR j:=1 STEP 1 UNTIL nparms DO
BEGIN
u:-tproc(rtyp.anames(j)); Outtext(u);
Outtext("avalues(");
Outtext(intput(j)); IF u =/= NOTEXT THEN Outtext(")");
Outtext("),");
IF Pos > 50 AND j < nparms THEN Outimage;
END;
Setpos(Pos-1); outline(");");
outline("load:-r;");
outline("end of load;");
Outtext("end of "); Outtext(rcname);
Outchar(';'); Outimage;
Outimage;
END;
END of record class generation;
outline("b_:-backslash;");
FOR n:=1 STEP 1 UNTIL nr_of_rec DO
BEGIN
Outtext("r:-getrecordspec("""); Outtext(recordtypes(n));
outline(""");");
Outtext("r.prototype:-NEW "); Outtext(recordtypes(n));
Outchar('(');
Outtext("r,noargs,");
nparms:=splita(cptexts(n),komma,recparm,50);
FOR j:=1 STEP 1 UNTIL nparms DO
BEGIN Outtext(recparm(j));
IF j=nparms THEN outline(");") ELSE
IF Pos>50 THEN outline(",") ELSE
Outtext(",");
END;
END;
outline("INNER;");
outline("END;");
END of inspect outf;
fin: outf.Close;
END;
END;