perm filename PREP1.SIM[SIM,SYS] blob sn#460173 filedate 1979-07-20 generic text, type T, neo UTF8
BEGIN
  EXTERNAL REF (Infile) PROCEDURE findinfile;
  EXTERNAL REF (Outfile) PROCEDURE findoutfile;
  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;
  EXTERNAL CLASS dbmtxt,dbm;
  dbm("prelog.tmp","english") BEGIN
    BOOLEAN load;
    TEXT ARRAY recordtypes,termarr,linktypes(1:20);
    TEXT ARRAY loadsym,storesym(1:6),keyconv(1:2);
    TEXT ARRAY cparm(1:6),cptexts(1:20);
    TEXT iterms,rterms,txterms,iaterms,raterms,taterms,allterms;
    INTEGER nparms,j,k,n,nr←of←rec,nr←of←links,cpmax,loopc;
    INTEGER linkx;
    TEXT t,outfname,outbuf,rcname,cptext,rclasstype,keytext;
    TEXT rlink;
    REF (Outfile) outf;

    REF (rspec) rtyp;

    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(Copy(","),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;
	IF cptext \= NOTEXT THEN
	cptext:-conc(cptext,Copy(","));
	cptext:-conc(cptext,cparm(k));
      tproc:-storesym(k); END;
    END;


    ! START OF MAIN  ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←;

    loadsym(1):-Copy(":=nextint;");
    storesym(1):-Copy("puti(");
    loadsym(2):-Copy(":=nextreal;");
    storesym(2):-Copy("putr(");
    loadsym(3):-Copy(":-nexttext;");
    storesym(3):-Copy("putt(");
    loadsym(4):-Copy(":-nextiarr;");
    storesym(4):-Copy("putiarr(");
    loadsym(5):-Copy(":-nextrarr;");
    storesym(5):-Copy("putrarr(");
    loadsym(6):-Copy(":-nexttarr;");
    storesym(6):-Copy("puttarr(");
    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);
    REQUEST("OUTPUT FILE (WITHOUT EXTENSION):","",
    TEXTINPUT(OUTFNAME,TRUE),"",
    HELP("FILE FOR GENERATED SIMULA SOURCE CODE., EXTENSION SIM ALWAYS ASSUMED"
    ));
    outf :- NEW Outfile(conc(outfname,Copy(".sim")));
    outf.Open(outbuf);
    n := 0;
    stringrequest("Records to expand (within delimiters): ",
    NOTEXT,t,TRUE,"?",
    help("Example:  /Rtyp1,RTYP2,RTYP3/"));
    nr←of←rec:=split(t,recordtypes);
    stringrequest("Linked records:",NOTEXT,rlink,TRUE,"?",help(
    "Those records that are treated as members or owners in sets"));
    nr←of←links:=split(rlink,linktypes);
    INSPECT outf DO
    BEGIN

      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,upcase,frontstrip,rest,checkEXTEnsion;");
      outline("EXTERNAL CHARACTER PROCEDURE fetchar,findtrigger;");
      outline("EXTERNAL LONG REAL PROCEDURE scanreal;");
      outline("EXTERNAL INTEGER PROCEDURE checkreal,checkint,scanint,ilog;");
      outline("EXTERNAL BOOLEAN PROCEDURE menu;");
      Outtext("external class ");
      Outtext("safeio,dbmtxt,dbm");
      IF nr←of←links > 0 THEN outline(",dbmset[105,121];") ELSE outline(";");
      Outtext("dbm");
      IF nr←of←links > 0 THEN Outtext("set"); Outtext(" class ");
      Outtext(outfname); Outchar(';'); Outimage;
      outline("begin");
      outline("text array noargs[1:1];");
      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;
	  COMMENT generate record class;
	  Outimage;
	  linkx:=loctext(rcname,linktypes);
	  IF linkx > 0 THEN Outtext("lrecord class ") ELSE
	  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 spec.dirfile do");
	  outline("begin text s;");
	  Outtext("dbskey:=lookup("); Outtext(keytext);
	  Outtext(","""); Outtext(rcname);
	  outline(""");");
	  IF linkx > 0 THEN
	  outline("movestruc(this lrecord);");
	  outline("addrpool(dbskey,this record);");
	  outline("spec.dirfile.locate(dbskey);");
	  outline("s:-blanks(maxrsize);");
	  loopc:=0;
	  FOR j:=1 STEP 1 UNTIL nparms DO
	  BEGIN COMMENT create input code for parameters;
	    load:=FALSE;
	    Outtext(tproc(rtyp.anames(j))); Outtext(rtyp.anames(j));
	    Outtext(",s);");
	    IF loopc > 1 THEN
	    BEGIN Outimage; loopc:=0; END ELSE loopc:=loopc+1;
	  END;
	  IF loopc > 0 THEN Outimage;
	  IF linkx > 0 THEN
	  outline("if set← =/= notext then s:-addstruc(s,set←);");
	  outline("storerecord(this directfile,conc(copy(""  ""),syn←),s);");
	  outline("end of store;");
	  Outtext("ref ("); Outtext(rcname);
	  outline(") procedure load(t); text t;");
	  Outtext("begin ref ("); Outtext(rcname);
	  outline(") r;");
	  IF linkx > 0 THEN outline("text u; substruc(t,u);");
	  Outtext("r:-new "); Outtext(rcname); Outchar('(');
	  Outtext("spec,noargs,");
	  Outtext(cptext);
	  cpmax:=cpmax+1; cptexts(cpmax):-cptext;
	  cptext:-NOTEXT;
	  outline(");");
	  outline("t←t:-conc(t,blank2);");
	  loopc:=0;
	  FOR j:=1 STEP 1 UNTIL nparms DO
	  BEGIN
	    load:=TRUE;
	    Outtext("r."); Outtext(rtyp.anames(j));
	    Outtext(tproc(rtyp.anames(j)));
	    IF loopc > 1 THEN
	    BEGIN Outimage; loopc:=0; END ELSE loopc:=loopc+1;
	  END;
	  IF loopc > 0 THEN Outimage;
	  IF linkx > 0 THEN Outtext("r.set←:-u; ");
	  outline("load:-r;");
	  outline("end of load;");
	  Outtext("end of "); Outtext(rcname);
	  Outchar(';'); Outimage;
	  Outimage;
	END;
      END of record class generation;
      Outtext("defaultparms; d←←file:-opendf;");
      outline("loadspec;");
      FOR n:=1 STEP 1 UNTIL nr←of←rec DO
      BEGIN
	Outtext("r:-getrecordspec("""); Outtext(recordtypes(n));
	outline(""");");
	outline("r.dirfile:-d←←file;");
	Outtext("r.prototype:-new "); Outtext(recordtypes(n));
	Outchar('(');
	Outtext("r,noargs,");
	Outtext(cptexts(n)); outline(");");
      END;
      FOR n:=1 STEP 1 UNTIL nr←of←links DO
      BEGIN
	j:=loctext(linktypes(n),recordtypes); IF j = 0 THEN
	BEGIN
	  Outtext("r:-getrecordspec("""); Outtext(linktypes(n));
	  outline(""");");
	  outline("r.dirfile:-d←←file;");
	  outline("r.prototype:-new lrecord(r,noargs);");
	END;
      END;
      outline("inner;");
      outline("closebase;");
      outline("end;");
    END of inspect outf;
    fin: outf.Close;
  END;
END;