reduce-historical/psl-1983/3-1/tests/new-test-case.red

 5-Apr-83 07:45:58-MST,6502;000000000001
Return-path: <@UTAH-CS:GRISS@HP-HULK>
Received: from UTAH-CS by UTAH-20; Tue 5 Apr 83 07:43:05-MST
Date:  5 Apr 1983 0633-PST
From: GRISS@HP-HULK
Subject: New-test-case.red
Message-Id: <418401289.19796.hplabs@HP-VENUS>
Received: by HP-VENUS via CHAOSNET; 5 Apr 1983 06:34:46-PST
Received: by UTAH-CS.ARPA (3.320.5/3.7.6)
	id AA04736; 5 Apr 83 07:41:40 MST (Tue)
To: kessler@HP-VENUS, griss@HP-VENUS


% Tools to analyse the standard timing tests
Fluid '(TestNames Fullnames Tests);
imports '(mathlib);

procedure readtest(name,fil);
 Begin scalar chan,body;
	chan := open(fil,'input);
        body:=channelread chan;
	put(name,'fullname,car body);
	body:=list(name) . cdr body;
	set(name,body); 
	TestNames := name  . TestNames;
	close chan;
	return body;
 End;

procedure readalltests;
 Begin  TestNames:=nil;
	Readtest('TestCray,"test-cray.tim");
	Readtest('Std20,"standard-20.tim");
	Readtest('Test20,"test-20.tim");
	Readtest('Ext20,"extended-20.tim");
	Readtest('TestExt20,"extended-test-20.tim");
	Readtest('Fasthp9836,"16mhz-hp9836.tim");
	Readtest('Std780,"standard-vax-780.tim");
	Readtest('Fast780,"fast-780.tim");
	Readtest('Franz780,"Franz-780.tim");
	Readtest('Std750,"standard-vax-750.tim");
	Readtest('Franz750,"Franz-750.tim");
	Readtest('Stdhp9836,"standard-hp9836.tim");
	Readtest('StdApollo,"standard-Apollo.tim");
% Non PSL
	Readtest('LM2,"LM2-hp.tim");
	Readtest('BlkDolphin,"Block-dolphin.tim");
	Print Testnames;
	Tests :=Evlis TestNames;
	return TestNames;
 End;

Procedure Show body;
Begin scalar HDR,fn;
	HDR:=car body; 
	If (fn:=Get(car HDR,'ShowFn)) then return Apply(fn,list body);
% Default Case
	Terpri();
	prin2l car body; % Header
	Terpri();
	While (body:=cdr body) do 
 	 printf("%w%t%w%n",trimblanks caar body,Tab!*,NiceNum cdar body);
End;

procedure Lookup(Body,Facet);
 Begin scalar value;
	If pairp(value:=assoc(Facet,cdr Body)) then return cdr value;
	return 0.0;
 End;

procedure ShowTotal Body;
Begin scalar Hdr;
	Hdr:=car Body;
	printf("%p: %tTot%w, avg%w, dev %w , %w tests%n",
	      Hdr, 10, 	Nicenum Lookup(Body,'total),
	      		nicenum Lookup(Body,'Average),
			nicenum Lookup(Body,'Deviation),
			Nicenum Lookup(Body,'Number));
End;

put('total, 'showfn,' ShowTotal);

Procedure Total body;
 Begin scalar Hdr,knt,tot,avg,dev,b;
	Knt:=0;
	Tot:=0;
	Dev:=0;
	Hdr:=car Body;
	While body:=cdr body do
	 <<knt:=knt+1; 
	   b:=cdar body; 
	   tot:=tot + b;
	   dev := b*b+dev;
        >>;
	Avg:=float(Tot)/knt;
        dev:=float(dev)/knt;
	dev:=dev-(avg*avg);
	dev:=sqrt(dev);
	b:=list('Total . Hdr,
                'Total . tot,
	        'Average . avg,
		'Deviation . dev,
	        'Number .knt);
        return b
 End;

procedure Ratio(Body1,Body2); 
% Divide elements of Body1  by Elements of Body2
  Begin scalar Hdr1,Hdr2,Rat,b1,b2,r,knt,avg,dev;
	Hdr1:=car body1; Hdr2:= car Body2;
	Body1:=cdr body1; Body2:=cdr Body2;
	If length body1 neq length body2 Then return "Length mismatch";
	knt:=0; avg:=0; dev:=0;
	While Body1 do
	  <<b1:=cdar body1; c:= caar body1; body1:=cdr body1;
	    b2:=cdar body2;                 body2:=cdr body2;
	    r:=float(b1)/b2;
	    avg:=r + avg;
            dev:=r*r +dev;
	    knt:=knt+1;
            rat := (c . r) . rat;
          >>;
	avg:=float(avg)/knt;
        dev:=float(dev)/knt;
        dev:=dev-(avg*avg);
	dev:=sqrt  dev;
 	rat := list('ratio,hdr1,hdr2) . reverse rat;
	return rat;
end;

procedure ratio20 body;
  Ratio(Body,std20);

procedure Ratio780 body;
  Ratio(Body,std780);

procedure Ratio750 body;
  Ratio(body,std780);

procedure Ratiohp9836 body;
 Ratio(body,stdhp9836);

procedure MapTest(Fns,TestList);
% Apply each Fn in Fns to each test in list
  for each Test in TestList
        collect applyFns(Reverse FnS,list Test);

Procedure ApplyFns(Fns,Args);
 If Not Pairp Fns then Car Args % Pass back
  else  ApplyFns(cdr Fns, List Apply(car Fns,Args));

procedure MapBody(Fns,Body);
% Apply series of Fns to each Element in Body of test
 Begin 
	For each Fn in Fns do
	   Body:=(Fn . car Body) . MapBody1(Fn, cdr body);
	return Body;
 End;

procedure MapBody1(Fn,Body);
  If Null Body then NIL
   else ( caar body . Apply(Fn,list cdar body)) . MapBody1 (fn,cdr Body);

%standard Maps

Procedure Invert Body;
 MapBody('(Inverted), Body);

Procedure Inverted x;
 1.0/x;

procedure Logarithm Body;
 MapBody('(LOG),Body);

procedure summary();
	<<readalltests();
	  wrs open("summary.tim",'output);
	  printf("%n%n SUMMARY TESTS on %w%n%n",DATE());
	  mapall();
	  close wrs nil>>;

Procedure MapAll;
 Begin scalar t20;

	T20:=Total Std20;

	Printf "%n     Total Times %n";
	MapTest('(show total),Tests);

	Printf "%n     Ratio of Total Times to STD20%n";
	for each test in Tests do
	   showtotal ratio(Total test,t20);

	Printf "%n     Average Each test Ratios to STD20%n";
	MapTest('(show total ratio20),Tests);

	PrintF "%n     68000 Total times%n";
	showtotal ratio(total StdHp9836,total FastHp9836);
	showtotal ratio(total StdApollo,total StdHp9836);

	PrintF "%n     68000 average ratios%n";
	show total ratio(StdHp9836,FastHp9836);
	show total ratio(StdApollo,StdHp9836);
 End;

procedure MapFileAll(fil,Fns);
 Begin scalar chan;
	chan:=open(fil,'output);
	wrs chan;
	MapTest(Fns,Tests);
	wrs nil;
	close chan;
 End;

% Nicer printing

procedure MakePowers(Base,M);
 Begin scalar V;
	V:=Mkvect M;
	v[0]:=1;
	for i:=1:M do V[i]:=Base* V[i-1];
	return V;
 End;

Tens!* := MakePowers(10,10);

Procedure FLTRND(N,fld);
 If floatp N then Fix(FLD*N+.5)/float(fld) else N;

Procedure NiceNum N;
   PadNM(N,nice!*,Fld!*);

FLD!*:=3;
Nice!*:=7;
Tab!*:=30;

Procedure PADNM(Num,n,m);
% LeftPAD number in Field of N;
 Begin scalar m1,m2,FixPart;
        FixPart :=Fix Num;
        m1:=BLDMSG("%p",FIXPART);
	N:=N-Size(m1)-1; % Number of Blanks
	if n>0 then m1:=Concat(MkString(n-1,32),m1);
	if m>0 then <<NUM := NUM-Fixpart;
                      m2:=BLDMSG("%p",FIX(num*Tens!*[m]+0.5));
	              M:=M-size(m2)-1; % Number of 0s
		      if m>0 then m2:=Concat(MkString(m-1,48),m2);
		      m1:=Concat(m1,concat(".",m2))>>;
	return m1;
 End;

procedure TrimBlanks S;
 Begin scalar N;
	if not stringp s then return s;
	n:=Size s;
	While n>0 and (s[n]=char BLANK  or s[n] = char TAB)   do n:=n-1;
	return sub(s,0,n);
  End;

End;
-------