Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/util/fqcred.sim
There is 1 other file named fqcred.sim in the archive. Click here to see a list.
OPTIONS(/-q/-a/-i/-d);
! FQCRED program.
! Original author Stefan Arnborg, FOA.
! Modified by Dag Gruneau 7706-7707.
! Modified by Mats Ohlin 7707-08, 780728 (.CON feature).
;
BEGIN
EXTERNAL TEXT PROCEDURE inline,checkextension,front;
EXTERNAL TEXT PROCEDURE tagord,conc,rest,scanto,storbokstav;
EXTERNAL CHARACTER PROCEDURE findtrigger;
EXTERNAL BOOLEAN PROCEDURE tmpout,bokstav;
EXTERNAL PROCEDURE run,exit,depchar;
EXTERNAL REF(Infile) PROCEDURE findinfile;
EXTERNAL REAL PROCEDURE cptime;
REF(Infile) progfile;
TEXT t,fq1,fq2,fqd,fqs,rimage,tracefield;
REAL cpu; BOOLEAN seqtrace;
INTEGER filnl,tpos,tracelimit;
BOOLEAN error;
BOOLEAN seqno; COMMENT SET IF DEC-10 numbered FILE;
CHARACTER notsg,cbar;
INTEGER maxchar; COMMENT MAX NO CHARACTERS (127 ON DEC);
INTEGER imlen; COMMENT LENGTH OF IMAGE ON INPUT FILE;
Outtext("Welcome to FQCRED Version 3"); Outimage;
again:Outimage;
t:- storbokstav(inline("Program:",Sysin));
scanto(t,'/');
IF t.More THEN
BEGIN seqtrace:= t.Getchar = 'T';
IF NOT seqtrace THEN
BEGIN Outtext("%Unknown switch:");
Outtext(rest(t));
Outimage; GO TO again;
END ELSE
BEGIN scanto(t,':');
IF t.More THEN
BEGIN
IF Digit(t.Getchar) THEN
BEGIN
t.Setpos(t.Pos-1);
tracefield:- rest(t);
tracelimit:= tracefield.Getint;
IF tracelimit <0 OR tracefield.More THEN
tferr:
BEGIN Outtext("%Illegal switch value:");
Outtext(tracefield); Outimage;
GO TO again;
END error;
END digit ELSE GO TO tferr;;
END t more;
END seqtrace;
END;
t.Setpos(1); t:- scanto(t,'/');
IF t==NOTEXT THEN
BEGIN Outimage;
Outtext("Type ? for help.");Outimage;
GOTO again;
END;
IF t.Getchar = '?' THEN
BEGIN Outimage;
Outtext("This program will measure how many times each statement");
Outimage;
Outtext("is executed in your SIMULA program.");
Outimage;
Outtext("Enter file to be analysed in the following format:");
Outimage;
Outtext("Dev:name.ext[/T] ( default extension is .SIM ).");
Outtext("If switch T is present then sequence trace will be produced.");
Outimage;
Outtext("N.B. This program will not check whether the inputfile");
Outimage;
Outtext("is a correct SIMULA source file or not. So please test");
Outimage;
Outtext("your program through the compiler first.");Outimage;
Outimage;GOTO again;
END;
t:- checkextension(t,".SIM");
progfile:- findinfile(t);
IF progfile==NONE THEN
BEGIN
Outtext("?Cannot find:");
Outtext(t);
Outimage;
GOTO again;
END;
Outimage;
t.Setpos(1); fq1:- scanto(t,'[');
tpos:= t.Pos;
IF tpos>t.Length THEN
BEGIN t.Setpos(1);
fq1:- scanto(t,'.');
END ELSE
BEGIN t.Setpos(1);
fq2:- scanto(t,'.');
IF tpos>t.Pos THEN
fq1:- fq2;
END;
filnl:= fq1.Length+5; fq2:- Blanks(filnl);
fq2.Sub(2,filnl-1):= fq1;
fq2.Sub(filnl-3,4):= ".FQ2"; fq1:- Copy(fq2);
depchar(fq1,filnl,'1');
fqs:- Copy(fq2); depchar(fqs,filnl,'S');
fqd:- Copy(fq2); depchar(fqd,filnl,'D');
notsg:= '\';
maxchar:= 127;
cbar:= '|';
imlen:= 135;
INSPECT NEW Outfile(fqd) DO
BEGIN
CHARACTER window,ch;
BOOLEAN moreinp;
INTEGER lngth;
REF(input) inp;
REF (tracer) trace;
REF (Inimage) img;
REF (printbegin) pb;
REF (printend) pe;
REF(readword) rw;
TEXT tt1,tt2,tt21,tt22;
CLASS input;
BEGIN
! READ A BASIC SYMBOL AND PUT ITS TEXT IN ;
! SYMBUF AND ITS INTERNAL VALUE IN SCLASS .;
SWITCH cse:= single,asteriks,slash,notsign,equalsign,
lessorgreater,colon,singlequote,doublequote;
start: Detach;
moreinp:= TRUE;
IF window='"' AND sclass=itc THEN GOTO doublequote;
IF sclass=iepr THEN
BEGIN COMMENT END OF FILE;
IF last=iepr THEN
BEGIN warning("END OF FILE");error:= TRUE;GOTO errxit; END;
GOTO start;
END;
IF current=iend THEN
BEGIN
punch.outchar(';');
END;
lb:
sclass:= 0;
symbuf:- symbuf.Main;
q: lngth:= 0;
WHILE lngth = 0 DO
BEGIN IF NOT inbuf.More THEN Call(img);
tmpsym:- tagord(inbuf);
lngth:= tmpsym.Length;
END;
symbuf.Sub(1,lngth):= tmpsym;
symbuf.Setpos(1);
window:= ch:= symbuf.Getchar;
IF current=iend THEN
BEGIN
IF window=';' THEN GOTO sk;
IF NOT bokstav(window) THEN GOTO q;
tmpsym:- symbuf.Sub(1,lngth);
storbokstav(tmpsym);
IF tmpsym="END" THEN
ELSE
IF tmpsym="ELSE" THEN
ELSE
IF tmpsym="OTHERWISE" THEN
ELSE
IF tmpsym="WHEN" THEN
ELSE
GOTO q;
END;
sk: IF klass(Rank(window))=letterklass THEN
BEGIN symbuf:- symbuf.Sub(1,IF lngth > 12 THEN 12 ELSE lngth);
storbokstav(symbuf);
IF lngth<2 OR lngth>9 THEN sclass:= nextid
ELSE sclass:= search;GOTO exit END;
IF klass(Rank(window))=numklass THEN
BEGIN sclass:= numklass;
window:= inbuf.Getchar;
IF window='R' OR window='r' THEN
BEGIN COMMENT Radix number;
tmptxt:- tmptxt.Main;
tmptxt.Putchar(window);
window:= inbuf.Getchar;
WHILE Digit(window) OR
(window>='a' AND window<='f') OR
(window>='A' AND window<='F') DO
BEGIN
tmptxt.Putchar(window);window:= inbuf.Getchar;
END;
tmptxt:- front(tmptxt);
symbuf.Sub(lngth+1,tmptxt.Length):= tmptxt;
lngth:= lngth+tmptxt.Length;
END;
IF lngth>72 THEN warning("Number spilled");
inbuf.Setpos(inbuf.Pos-1); GOTO exit3 END;
IF klass(Rank(window))=singleklass THEN
BEGIN
single: COMMENT BASIC SYMBOL IS SINGLE CHARACTER;
sclass:= sclasses(Rank(ch));
symbuf:- symbuf.Sub(1,1);
GOTO exit;
END;
GOTO cse(klass(Rank(window))-2);
COMMENT END OF FILE?;
IF progfile.Endfile THEN GOTO slash;
IF Rank(window)<=12 THEN BEGIN Call(img); GOTO lb; END;
COMMENT checks if window=Form Feed or 'less' (VT);
Sysout.Outtext(inbuf); Sysout.Outimage;
Call(img); GOTO lb;
set_sclass: sclass:= sclasses(Rank(ch)); inbuf.Setpos(inbuf.Pos-1);
symbuf:- symbuf.Sub(1,1);
GOTO start;
asteriks: COMMENT * OR ** ;
window:= inbuf.Getchar;
IF window='*' THEN
BEGIN sclass:= iex; depchar(symbuf,2,'*'); lngth:= 2;
GOTO exit3 END;
GOTO set_sclass;
slash: COMMENT /OR // OR /* (END OF FILE) ** IMPLEMENTATION DEPEND.**;
IF progfile.Endfile THEN
BEGIN sclass:= iepr; symbuf:- NOTEXT;
GOTO start;END;
window:= inbuf.Getchar;
IF window ='/' THEN BEGIN sclass:= iid;
depchar(symbuf,2,'/'); lngth:= 2; GOTO exit3 END;
GOTO set_sclass;
notsign: COMMENT NOT OR NE ;
window:= inbuf.Getchar;
IF window='=' THEN
BEGIN sclass:= ine;
depchar(symbuf,2,'='); lngth:= 2; GOTO exit3 END;
GOTO set_sclass;
equalsign: COMMENT = OR == OR =/=;
window:= inbuf.Getchar;
IF window='=' THEN
BEGIN sclass:= ied;
depchar(symbuf,2,'='); lngth:= 2; GOTO exit3 END;
IF window='/' THEN
BEGIN window:= inbuf.Getchar;
IF window='=' THEN
BEGIN sclass:= ind; depchar(symbuf,2,'/');
depchar(symbuf,3,'='); lngth:= 3; GOTO exit3 END;
warning("ILLEGAL BASIC SYMBOL =/") ;depchar(symbuf,2,'/');
lngth:= 2; inbuf.Setpos(inbuf.Pos-1);
GOTO exit3;
END;
GOTO set_sclass;
lessorgreater: COMMENT > OR< OR >= OR <=;
window:= inbuf.Getchar;
IF window='=' THEN
BEGIN sclass:= (IF ch='>' THEN ige ELSE ile);
depchar(symbuf,2,'='); lngth:= 2; GOTO exit3 END;
GOTO set_sclass;
colon: COMMENT : OR := OR :- ;
window:= inbuf.Getchar;
IF window='=' THEN
BEGIN sclass:= ibc;
depchar(symbuf,2,'='); lngth:= 2; GOTO exit3 END;
IF window='-' THEN
BEGIN sclass:= idn;
depchar(symbuf,2,'-'); lngth:= 2; GOTO exit3 END;
GOTO set_sclass;
singlequote: COMMENT CHARACTER CONSTANT;
window:= inbuf.Getchar; depchar(symbuf,2,window);
window:= inbuf.Getchar; depchar(symbuf,3,window);
sclass:= icc;
lngth:= 3;
IF window NE ''' THEN warning("CHARACTER CONSTANT");
GOTO exit3;
doublequote: COMMENT TEXT STRING;
sclass:= itc;
tc:- tc.main; IF current=itc THEN tc.Putchar(' ');
dbdb:
tc.Putchar('"');
window:= inbuf.Getchar;WHILE window NE '"'DO
BEGIN IF tc.Pos=72 THEN
BEGIN tc.Putchar('"');window:= '"'; tc:- front(tc);
inbuf.Setpos(inbuf.Pos-1); GOTO exit3 END ELSE
BEGIN tc.Putchar(window);IF NOT inbuf.More THEN Call(img);
window:= inbuf.Getchar;
END;
END;
tc.Putchar('"');
window:= inbuf.Getchar;
IF window='"' THEN GOTO dbdb;
tc:- front(tc);
inbuf.Setpos(inbuf.Pos-1);
GOTO start;
exit:
IF sclass = icomment THEN
BEGIN
WHILE window NE ';' DO
BEGIN IF NOT inbuf.More THEN Call(img);
window:= inbuf.Getchar;
END;
GOTO lb;
END ELSE
IF sclass=ioptions THEN
BEGIN
tmptxt:- tmptxt.Main;
tmptxt.Putchar('(');
WHILE window NE ')' DO
BEGIN
IF window='/' THEN
BEGIN
window:= inbuf.Getchar;
IF window='-' THEN
BEGIN
window:= inbuf.Getchar;
IF window='A' OR window='a'
OR window='Q' OR window='q' THEN
BEGIN
tmptxt.Putchar('/');
tmptxt.Putchar('-');
tmptxt.Putchar(window);
END
END ELSE
IF window='A' OR window='a'
OR window='Q' OR window='q' THEN
BEGIN
tmptxt.Putchar('/');
tmptxt.Putchar(window);
END ELSE
IF window='S' OR window='s' THEN
BEGIN
tmptxt.Putchar('/');
WHILE window NE '/' AND window NE ')' DO
BEGIN
tmptxt.Putchar(window);
IF NOT inbuf.More THEN Call(img);
window:= inbuf.Getchar;
END
END
END;
WHILE window NE '/' AND window NE ')' DO
BEGIN
IF NOT inbuf.More THEN Call(img);
window:= inbuf.Getchar;
END;
END;
tmptxt.Putchar(')');
IF tmptxt.Pos=3 THEN
BEGIN
scanto(inbuf,';');
GOTO lb;
END;
symbuf:- symbuf.Main;
tmptxt:- front(tmptxt);
symbuf.Sub(8,tmptxt.Length):= tmptxt;
lngth:= 8+tmptxt.Length;
END ELSE GOTO start;
exit3:
symbuf:- symbuf.Sub(1,lngth);
GOTO start;
END INP;
COMMENT INPUT INTERPRETATION CONSTANTS;
INTEGER
ipl,imi,iti,idi,iid,iex,igt,ige,ilt,ile,ieq,ine,ied,ind,idt, !
+ - * / // ** > >= < <= = \= == =/= . ;
icm,icl,isc,ipt,ilp,irp,ibc,idn,int,icc,itc, !
, : ., & [( ]) := :- \ ' ' " " ;
numclass,iend,ido,ielse,iotherwise,icomment,ibegin,iepr,
ioptions,iif,iproc,iclass,iextern,ithen,iwhen,iinspect;
INTEGER ARRAY klass,sclasses(0:maxchar);
INTEGER numklass,singleklass,letterklass,asterklass,
slashklass,notklass,eqklass,lessgreaterklass,colonklass,
sqklass,dqklass;
INTEGER i;
COMMENT UTILITY PROCEDURES;
PROCEDURE set(j); NAME j; INTEGER j;
BEGIN i:= i+1; j:= i; END SET;
PROCEDURE ic(c,v); CHARACTER c; INTEGER v;
sclasses(Rank(c)):= v;
INTEGER PROCEDURE insert;
BEGIN REF(nod)tp;
tp:- root;
IF root==NONE THEN root:- tp:- NEW nod ELSE
WHILE TRUE DO
IF tp.t<symbuf THEN
BEGIN IF tp.r==NONE THEN
BEGIN tp.r:- tp:- NEW nod; GOTO l; END
ELSE tp:- tp.r;
END ELSE IF tp.t>symbuf THEN
BEGIN IF tp.l==NONE THEN
BEGIN tp:- tp.l:- NEW nod; GOTO l; END
ELSE tp:- tp.l;
END ELSE GOTO l;
l:
insert:= tp.n;
END Insert;
INTEGER PROCEDURE search;
BEGIN REF(nod)tp;
tp:- root;
WHILE TRUE DO
IF tp.t<symbuf THEN
BEGIN IF tp.r==NONE THEN
GOTO l
ELSE tp:- tp.r;
END ELSE IF tp.t>symbuf THEN
BEGIN IF tp.l==NONE THEN
GOTO l
ELSE tp:- tp.l;
END ELSE BEGIN search:= tp.n; GOTO e; END;
l:
search:= nextid;
e:
END Search;
CLASS nod;
BEGIN TEXT t;
REF(nod) l,r; INTEGER n;
t:- Copy(symbuf);
IF declaration THEN
BEGIN declaration:= FALSE;
n:= 1000+nextid;
END ELSE
IF specification THEN
BEGIN specification:= FALSE;
n:= 100+nextid;
END ELSE
n:= nextid;nextid:= nextid+1;
END NOD;
REF(nod) root;
INTEGER nextid,firstid,identifier;
BOOLEAN declaration,specification;
PROCEDURE init;
BEGIN
i:= 0;
set(letterklass); set(numklass); set(singleklass);
set(asterklass); set(slashklass); set(notklass);
set(eqklass); set(lessgreaterklass);
set(colonklass); set(sqklass); set(dqklass);
i:= 0;
set(iepr); set(ipl); set(imi); set(iti);
set(idi); set(iid); set(iex); set(igt);
set(ige); set(ilt); set(ile); set(ieq);
set(ine); set(ied); set(ind); set(idt);
set(icm); set(icl); set(isc); set(ipt);
set(ilp); set(irp); set(ibc); set(idn);
set(int); set(icc); set(itc); set(numclass);
set(nextid);
FOR i:= 0 STEP 1 UNTIL maxchar DO
BEGIN IF bokstav(Char(i))THEN klass(i):= letterklass ELSE
IF Digit(Char(i)) THEN klass(i):= numklass;
END;
klass(Rank('+')):= klass(Rank('-')):= klass(Rank('.')):= singleklass;
klass(Rank(',')):= klass(Rank(';')):= klass(Rank('(')):= singleklass;
klass(Rank('^')):= klass(Rank('!')):= singleklass;
klass(Rank(')')):= singleklass;
klass(Rank('[')):= klass(Rank(']')):= singleklass;
klass(Rank('_')):= klass(Rank('$')):= klass(Rank('#')):= klass(Rank('@')):=
letterklass;
klass(Rank('>')):= klass(Rank('<')):= lessgreaterklass;
klass(Rank('*')):= asterklass;
klass(Rank('/')):= slashklass;
klass(Rank(notsg)):= notklass;
klass(Rank('=')):= eqklass;
klass(Rank(':')):= colonklass;
klass(Rank(''')):= sqklass;
klass(Rank('"')):= dqklass;
klass(Rank('&')):= numklass;
ic('+',ipl); ic('-',imi); ic('*',iti);
ic('/',idi); ic('>',igt); ic('<',ilt);
ic('=',ieq); ic('.',idt); ic(',',icm);
ic(':',icl); ic(';',isc); ic('&',ipt);
ic('(',ilp); ic(')',irp); ic('^',iex);
ic(''',icc); ic('"',itc);
ic('[',ilp); ic(']',irp);
identifier:= nextid;
symbuf:- Copy("LONG"); declaration:= TRUE; insert;
symbuf:- Copy("ELSE"); ielse:= insert;
symbuf:- Copy("REF"); declaration:= TRUE; insert;
symbuf:- Copy("CHARACTER"); declaration:= TRUE; insert;
symbuf:- Copy("IF"); iif:= insert;
symbuf:- Copy("OTHERWISE"); iotherwise:= insert;
symbuf:- Copy("THEN"); ithen:= insert;
symbuf:- Copy("BEGIN"); ibegin:= insert;
symbuf:- Copy("COMMENT"); icomment:= insert;
symbuf:- Copy("EXTERNAL"); declaration:= TRUE; iextern:= insert;
symbuf:- Copy("INTEGER"); declaration:= TRUE; insert;
symbuf:- Copy("NOT"); specification:= TRUE; insert;
symbuf:- Copy("PROTECTED"); specification:= TRUE; insert;
symbuf:- Copy("SWITCH"); declaration:= TRUE; insert;
symbuf:- Copy("WHEN"); iwhen:= insert;
symbuf:- Copy("ARRAY"); declaration:= TRUE; insert;
symbuf:- Copy("BOOLEAN"); declaration:= TRUE; insert;
symbuf:- Copy("CLASS"); declaration:= TRUE; iclass:= insert;
symbuf:- Copy("DO"); ido:= insert;
symbuf:- Copy("END"); iend:= insert;
symbuf:- Copy("HIDDEN"); declaration:= TRUE; insert;
symbuf:- Copy("INSPECT"); iinspect:= insert;
symbuf:- Copy("LABEL"); specification:= TRUE; insert;
symbuf:- Copy("NAME"); specification:= TRUE; insert;
symbuf:- Copy("OPTIONS"); declaration:= TRUE; ioptions:= insert;
symbuf:- Copy("PROCEDURE"); declaration:= TRUE; iproc:= insert;
symbuf:- Copy("REAL"); declaration:= TRUE; insert;
symbuf:- Copy("SHORT"); declaration:= TRUE; insert;
symbuf:- Copy("TEXT"); declaration:= TRUE; insert;
symbuf:- Copy("VALUE"); specification:= TRUE; insert;
symbuf:- Copy("VIRTUAL"); specification:= TRUE; insert;
ic('!',icomment);
firstid:= nextid;
symbuf:- Blanks(imlen);
tpl:- Blanks(imlen);
i1:- Blanks(imlen);
i2:- Blanks(imlen);
t1:- Blanks(72);
t2:- Blanks(72);
tc:- Blanks(72);
tmptxt:- Blanks(imlen);
inp:- NEW input;
trace:- NEW tracer;
img:- NEW inimage;
pb:- NEW printbegin;
pe:- NEW printend;
rw:- NEW readword;
Call(img);
window:= inbuf.Getchar;
IF Digit(window) THEN
BEGIN seqno:= TRUE; inbuf.Setpos(7);
END ELSE
inbuf.Setpos(1);
END Init;
COMMENT LEXICAL SCAN INTERFACE;
BOOLEAN newimg;
INTEGER trno,sclass,current,next,last,
p1,p2,nimg,saveimg;
TEXT symbuf,inbuf,t1,tbegin,tend,t2,tc;
TEXT i1,i2,tpl,tmptxt,tmpsym;
CLASS readword;
BEGIN INTEGER lastimg;
start: Detach;
punch.Outtext(t1);
IF current>=identifier THEN punch.Outchar(' ');
COMMENT is t1 an identifier or not?;
t1:- t1.Main.Sub(1,t2.Length);
t1:= t2;
last:= current;current:= next;
p1:= p2;
lastimg:= nimg;
Call(inp);
newimg:= current NE isc AND nimg > lastimg;
next:= sclass;
IF sclass=itc THEN
BEGIN t2:- t2.main.Sub(1,tc.Length);t2:= tc END ELSE
BEGIN t2:- t2.Main.Sub(1,lngth); t2:= symbuf END;
p2:= inbuf.Pos-lngth;
GOTO start;
END rw;
CLASS Inimage;
BEGIN
l: Detach; nimg:= nimg+1;
IF NOT progfile.Endfile THEN progfile.Inimage ELSE
BEGIN IF last=iepr THEN GOTO xit ELSE
BEGIN progfile.Image:= " ;/*";
IF current = isc AND seqno THEN
depchar(progfile.Image,7,' ');
END mark eof;
END;
Image:- i1;
Outimage;
IF tpl.Pos NE 1 THEN
BEGIN
Image:- tpl;
Outimage;
tpl.Setpos(1);
END;
inbuf:- progfile.Image.Sub(1,progfile.Image.Strip.Length+1);
IF seqno THEN inbuf.Setpos(7);
i1:= inbuf;
GO TO l;
END inimage;
CLASS tracer;
BEGIN
l: Detach;
IF p1 NE 0 AND moreinp THEN
BEGIN tpl.Setpos(p1);tpl.Putchar(cbar);
trno:= trno+1;
tt21.Putint(trno);
tt22:= IF NOT seqtrace THEN tt21 ELSE
IF t1.Length > 6 THEN t1.Sub(1,6) ELSE t1;
punch.Outtext(tt2);
IF newimg THEN
BEGIN newimg:= FALSE;
Image:- tpl; Outimage; tpl.Setpos(1);
END force tpl;
END;
moreinp:= FALSE;
GO TO l;
END TRACE;
CLASS printbegin;
BEGIN l: Detach; punch.Outtext("BEGIN "); GO TO l END;
CLASS printend;
BEGIN l: Detach; punch.Outtext("END "); GO TO l END;
PROCEDURE warning(t);NAME t;TEXT t;
BEGIN Image:- rimage; Outimage;
Outtext("**** "); Outtext(t); Outtext(" ****");
INSPECT Sysout DO
BEGIN
Outtext("****");Outtext(t);Outtext("****");Outchar(Char(7));
Outimage;
i1.Setpos(1);
WHILE i1.More DO
Outchar(i1.Getchar);
END;
Outint(p1,3);
punch.Outtext("COMMENT ");
punch.Outtext(t);
punch.Outchar(';');
Outimage;
tpl.Setpos(p1);tpl.Putchar('&');
END;
COMMENT *** TRANSITION DIAGRAMMES ***;
PROCEDURE program;
BEGIN WHILE NOT block DO Resume(rw);
IF current NE iepr AND next NE iepr THEN
BEGIN warning("TERMINATION");
WHILE NOT progfile.Endfile DO Resume(rw);
error:= TRUE; GO TO errxit;
END;
END;
BOOLEAN PROCEDURE block;
IF current=ibegin THEN
BEGIN block:= TRUE;
Resume(rw);
d;
IF current NE iif AND current NE ibegin THEN Call(trace);
st:
WHILE s DO
BEGIN IF current=isc THEN
BEGIN Resume(rw); IF current NE iif AND
current NE ibegin THEN Call(trace)
END;
END;
IF current NE iend THEN
BEGIN warning("BLOCK STRUCTURE"); Resume(rw); GOTO st END;
Resume(rw);
END BLOCK;
BOOLEAN PROCEDURE d;
BEGIN
l:IF current=iextern THEN
BEGIN d:= TRUE; WHILE current NE isc DO Resume(rw) END ELSE
IF current>=firstid AND next=iclass THEN ELSE
IF current>=1000 THEN
BEGIN WHILE current NE isc DO
!Checks whether current is a declaration or not;
BEGIN d:= TRUE;
IF current=iclass OR current=iproc THEN body
ELSE Resume(rw);
END
END ELSE
GO TO e;
Resume(rw);
GO TO l;
e:
END D;
BOOLEAN PROCEDURE s;
BEGIN INTEGER stack;
IF current=isc THEN
BEGIN s:= TRUE; Resume(rw);GOTO e; END;
WHILE TRUE DO
BEGIN
IF last=icl AND current NE ibegin THEN Call(trace);
IF current=iif THEN
BEGIN IF last=isc OR last=ibegin OR last=icl THEN
BEGIN Call(trace); ifst; END ELSE
IF last=ido OR last=iotherwise THEN
BEGIN Call(pb); Call(trace); ifst; Call(pe); END
ELSE ifex;
END ELSE
IF current=ido AND next NE ibegin THEN
BEGIN Resume(rw); Call(pb);
Call(trace); stack:= stack+1;
END ELSE
IF current=iinspect THEN ii ELSE
IF current=ibegin THEN block ELSE
IF current=isc THEN GOTO e ELSE
IF current=iend THEN GO TO e ELSE
IF current=ielse THEN GOTO e ELSE
IF current=ithen THEN GOTO e ELSE
IF current=iwhen THEN GOTO e ELSE
IF current=iotherwise THEN GOTO e ELSE
Resume(rw);
s:= TRUE;
END eternal loop;
e: WHILE stack>0 DO BEGIN stack:= stack-1;Call(pe); END;
END S;
PROCEDURE ifex;
BEGIN Resume(rw); WHILE current NE ithen DO
BEGIN IF current=iif THEN ifex ELSE Resume(rw);END;
Resume(rw);s;
IF current=ielse THEN
BEGIN Resume(rw); IF current=iif THEN ifex ELSE s END;
END IFEX;
PROCEDURE ifst;
BEGIN Resume(rw);WHILE current NE ithen DO
BEGIN IF current=iif THEN ifex ELSE Resume(rw);END;
Resume(rw);
IF current NE ielse THEN
BEGIN
IF current NE ibegin THEN
BEGIN
Call(pb);Call(trace);s;Call(pe);
END ELSE block;
END;
IF current=ielse THEN
BEGIN Resume(rw); IF current NE ibegin AND current NE iif THEN
BEGIN Call(pb);Call(trace);s;Call(pe);
! Fix ELSE <empty> <SEMICOLON> BEGIN problem;
punch.Outchar(';');
END ELSE
BEGIN IF current=iif THEN
BEGIN
Call(pb); Call(trace); ifst; Call(pe);
END
ELSE block END;
END
END IFST;
PROCEDURE ii;
BEGIN Resume(rw);s;
WHILE current=iwhen DO BEGIN Resume(rw);s END;
IF current=iotherwise THEN
BEGIN Resume(rw);
IF current=ibegin THEN block ELSE
BEGIN Call(pb);Call(trace);s;Call(pe) END;
END;
END II;
PROCEDURE body;
BEGIN
WHILE current NE isc DO Resume(rw);
saveimg:= nimg; Resume(rw);
WHILE current>=100 DO
!Scans declarations and specifications;
BEGIN WHILE current NE isc DO Resume(rw);
saveimg:= nimg; Resume(rw);
END;
IF current=isc THEN COMMENT EMPTY BODY;
BEGIN Call(pb); Call(trace);
Call(pe);
! Fix double semicolon problem;
IF saveimg<nimg AND tpl.Pos>1 THEN
BEGIN Image:- tpl; Outimage;
tpl.Setpos(1);
END;
END ELSE
IF current=ibegin THEN block ELSE
BEGIN Call(pb);Call(trace);s;Call(pe);END;
END BODY;
REF (Outfile) punch;
COMMENT used in trace above;
IF seqtrace THEN
BEGIN tt2:- Copy("z__(*****,""abcdef"");");
tt21:- tt2.Sub(5,5); tt22:- tt2.Sub(12,6);
END ELSE
BEGIN
tt2:- Copy("z_q[*****]:=z_q[*****]+1;");
tt21:- tt2.Sub(5,5); tt22:- tt2.Sub(17,5);
END;
progfile.Open(Blanks(imlen+1));
THIS Outfile.Open(Blanks(imlen));
rimage:- Image;
punch:- NEW Outfile(fq2);
punch.Open(Blanks(72));
init;
program;
xit:
INSPECT NEW Outfile(fq1) DO
BEGIN
PROCEDURE o(p,t); NAME t; INTEGER p; TEXT t;
BEGIN Setpos(p); Outtext(t); Outimage END o;
Open(Blanks(72));
o(1,"OPTIONS(/-i/-d/-w); BEGIN");
Outtext(" INTEGER ARRAY z_q[0:");Outint(trno,6);
o(Pos,"];");
o(4,"ARRAY z_y,z_z[-1:100];");
o(4,"EXTERNAL REAL PROCEDURE fqccptime;");
o(4,"EXTERNAL TEXT PROCEDURE fqcinline;");
o(4,"EXTERNAL PROCEDURE run,exit;");
o(4,"EXTERNAL INTEGER PROCEDURE fqcinput,fqcoutput;");
o(4,"EXTERNAL REF(Infile) PROCEDURE fqcfindinfile;");
IF seqtrace THEN
BEGIN
o(4,"PROCEDURE traceoff;");
o(4,"IF trace THEN BEGIN trace:= FALSE;");
o(7,"IF conseq THEN");
o(7,"BEGIN fqt.Outint(-last_trace,");
o(20,"IF last_trace < 10 THEN 2 ELSE");
o(20,"IF last_trace < 100 THEN 3 ELSE");
o(20,"IF last_trace < 1000 THEN 4 ELSE");
o(20,"IF last_trace < 10000 THEN 5 ELSE 6);");
o(7,"fqt.Outimage; conseq:= FALSE END;");
o(7,"fqt.Outtext(""*** Trace off ***"");");
o(7,"fqt.Outimage;");
o(4,"END of traceoff;");
o(4,"PROCEDURE traceon;");
o(4,"BEGIN trace:= TRUE; last_trace:= -1 END traceon;");
o(4,"INTEGER last_trace; BOOLEAN conseq,trace;");
o(4,"PROCEDURE z__(i,t); NAME t; INTEGER i; TEXT t;");
o(4,"BEGIN OPTIONS(/-A);");
o(7,"z_q[i]:= z_q[i]+1;");
o(7,"IF trace THEN BEGIN");
IF tracelimit<=0 THEN
BEGIN
o(10,"IF i NE last_trace+1 THEN");
o(10,"BEGIN IF conseq THEN");
o(13,"BEGIN fqt.Outint(-last_trace,");
o(20,"IF last_trace < 10 THEN 2 ELSE");
o(20,"IF last_trace < 100 THEN 3 ELSE");
o(20,"IF last_trace < 1000 THEN 4 ELSE");
o(20,"IF last_trace < 10000 THEN 5 ELSE 6);");
o(13,"conseq:= FALSE END;");
END ELSE
BEGIN Setpos(13); Outtext("IF z_q[i] <=");
Outtext(tracefield); Outtext(" THEN BEGIN");
Outimage;
END;
o(13,"fqt.Setpos((fqt.Pos+14)//16*16+1);");
o(13,"fqt.Outtext(t); fqt.Outint(i,6);");
IF tracelimit > 0 THEN
o(13,"END;") ELSE
BEGIN
o(10,"END ELSE conseq:= TRUE;");
o(10,"last_trace:= i;");
END;
o(10,"END trace;");
o(7,"OPTIONS(/A);");
o(4,"END z__;");
o(4,"REF (Outfile) fqt;");
END ELSE
o(4,"PROCEDURE traceon;; PROCEDURE traceoff;;");
o(4,"PROCEDURE z_t(i); INTEGER i;");
o(4,"IF i>0 THEN");
o(4,"z_z[i]:=fqccptime ELSE");
o(4,"IF i<0 THEN z_y[-i]:=z_y[-i]+fqccptime-z_z[-i];");
o(4,"REF(Infile) fqs;");
o(4,"TEXT tt1,tt2,tt3;");
o(4,"INTEGER i;");
Outtext(" tt1:- Copy(""FREQ ");Outtext(fqs);o(Pos,""");");
o(4,"start:");
o(4,"fqs:- fqcfindinfile(tt1);");
o(4,"IF fqs=/=NONE THEN");
o(4,"BEGIN fqs.Open(NOTEXT);");
o(7,"fqcinput(fqs,i); fqs.Close;");
Outtext(" IF i NE ");Outint(trno,6);
o(Pos," THEN GOTO supersede;");
o(7,"test: tt2:- NOTEXT;");
o(7,"WHILE tt2==NOTEXT DO");
o(7,"BEGIN Outimage;");
o(11,"Outtext(""Shall we add the new results to the"");");
o(11,"Outimage;");
o(11,"tt2:- fqcinline(""old frequencyfile?"",Sysin);");
o(11,"Outimage;");
o(7,"END;");
o(7,"tt3:- tt2.Sub(1,1);");
o(7,"IF tt3=""?"" THEN");
Setpos(7); Outtext("BEGIN Outtext(""You have a file named: ");
Outtext(fqs); o(Pos,""");");
o(11,"Outimage;");
o(11,"Outtext(""which contains frequencies from a previous"");"
);
o(11,"Outimage;");
o(11,"Outtext(""execution of this program."");");
o(11,"Outimage;");
o(11,"Outtext(""Answer yes or no (ja and nej is also valid) if"");");
o(11,"Outimage;");
o(11,"Outtext(""you want to accumulate the frequencies or not."");");
o(11,"Outimage; Outimage;");
o(11,"GOTO test;");
o(7,"END ELSE");
o(7,"IF tt3=""N"" or tt3=""n"" THEN");
o(7,"BEGIN supersede:");
o(15,"Outtext(""%Superseding existing file"");");
o(15,"Outimage;");
o(15,"fqcinline(""To continue press return """);
o(12," ""else type ^C :"",Sysin);");
o(15,"GOTO prh;");
o(7,"END;");
o(7,"IF (tt3 ne ""j"" and tt3 ne ""y"") and");
o(7,"(tt3 NE ""J"" AND tt3 NE ""Y"") THEN");
o(7,"BEGIN");
o(11,"Outtext(""Answer yes or no (ja och nej is also valid)"");");
o(11,"Outimage;");
o(11,"Outtext(""For help type ?"");");
o(11,"Outimage; Outimage;");
o(11,"GOTO test;");
o(7,"END;");
o(7,"fqs.Open(NOTEXT); fqcinput(fqs,i,z_q,z_y);");
o(7,"fqs.Close;");
o(4,"END;");
o(4,"prh:");
IF seqtrace THEN
BEGIN
Outtext("fqt:- NEW Outfile(""TRACE ");
Outtext(fqs.Sub(1,fqs.Length-1));
o(Pos,"T/A:APPEND"");");
o(4,"fqt.Open(Blanks(80));");
o(4,"fqt.Outtext(""-----------------------"");");
o(4,"fqt.Outimage; traceon;");
END;
o(4,"z_y[-1]:=z_y[-1]+fqccptime;");
Close;
END;
INSPECT punch DO
BEGIN Outchar(';');
Outtext("z_y[0]:=z_y[0]+fqccptime;");Outimage;
Outtext("BEGIN");Outimage;
Outtext("REF (Outfile) s;");Outimage;
IF seqtrace THEN
Outtext("traceoff; fqt.Close;");
Outtext("s:- NEW Outfile(tt1);");Outimage;
Outtext("s.Open(NOTEXT);");Outimage;
Outtext("z_q[0]:= z_q[0]+1;");Outimage;
Outtext("fqcoutput(s,");Outint(trno,7);Outtext(",z_q,z_y);");
Outimage;
Outtext("Outimage;");Outimage;
Outtext("Outtext(""If you want to have the result at once"
" type .CONTINUE"");");
Outimage;Outtext("Outimage;");Outimage;
Outtext("Outtext(""To accumulate the frequencies just type: START"");");
Outimage;Outtext("Outimage;");Outimage;
Outtext("s.Close; exit(0); run(""PUB:FQCLST"",1);");
Outimage;
Outtext("run(""FQCLST"",1);");
Outtext("Outtext(""?Could not find PUB: or SYS: FQCLST"");");
Outtext("Outimage;END END;"); Outimage;
END;
errxit: punch.Close;
progfile.Close;
THIS Outfile.Close;
IF error THEN
BEGIN Sysout.Outimage;
Sysout.Outtext("%FQCETD Execution terminated");
Sysout.Outimage; exit(0); exit(1); END;
END of of inspect outfile;
t:- Blanks(80);
! 46 should be sufficient but input ABCDEFXXX.SIM works too!;
t.Sub(1,filnl):= fqd; t.Sub(filnl,2):= "R=";
t.Sub(filnl+2,filnl):= fq1; t.Sub(2*filnl+2,1):= ",";
t.Sub(2*filnl+3,filnl):= fq2; t.Setpos(3*filnl+3);
t.Putchar(Char(13)); t.Putchar(Char(10));
t.Sub(3*filnl+5,5):= "LINK!";
t.Setpos(3*filnl+10);
t.Putchar(Char(13)); t.Putchar(Char(10));
tmpout("SIM",t);
t.Sub(filnl-2,4):= "DSK:";
t.Sub(2*filnl+1,5):= "R/E/G";
tmpout("LNK",Copy(t.Sub(filnl-2,filnl+8)));
t.Sub(filnl-5,7):= "EX/REL ";
tmpout("SVC",Copy(t.Sub(filnl-5,filnl+7)));
Outtext("[FQCRED: CPU time:");
cpu:= cptime;
IF cpu>=60 THEN BEGIN Outint(Entier(cpu)//60,3); Outchar(':');
cpu:= cpu-(Entier(cpu)//60)*60;END;
Outfix(cpu,2,5);
Outchar(']'); Outimage;
Outtext("Running modified program: ");Breakoutimage;
run("SYS:SIMULA",2);
END of program;