home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS 1992 September
/
Simtel20_Sept92.cdr
/
msdos
/
ddjmag
/
ddj8809.arc
/
PORTER.LIS
< prev
next >
Wrap
File List
|
1988-08-22
|
18KB
|
807 lines
_THE STATE OF MODULEA-2_
by
Kent Porter
Listing One
MODULE dry;
FROM Storage
IMPORT ALLOCATE, DEALLOCATE, Available, InstallHeap, RemoveHeap;
FROM Strings
IMPORT CompareStr;
(*
* "DHRYSTONE" Benchmark Program
*
* Version: Mod2/1
* Date: 05/03/86
* Author: Reinhold P. Weicker, CACM Vol 27, No 10, 10/84 pg. 1013
* C version translated from ADA by Rick Richardson
* Every method to preserve ADA-likeness has been used,
* at the expense of C-ness.
* Modula-2 version translated from C by Kevin Northover.
* Again every attempt made to avoid distortions of the original.
* Machine Specifics:
* The time function is system dependant, one is
* provided for the Amiga. Your compiler may be different.
* The LOOPS constant is initially set for 50000 loops.
* If you have a machine with large integers and is
* very fast, please change this number to 500000 to
* get better accuracy.
* You can also time the program with a stopwatch when it
* is lightly loaded (no interlaced 4 bit deep Amiga screens ...).
*
**************************************************************************
*
* The following program contains statements of a high-level programming
* language (Modula-2) in a distribution considered representative:
*
* assignments 53%
* control statements 32%
* procedure, function calls 15%
*
* 100 statements are dynamically executed. The program is balanced with
* respect to the three aspects:
* - statement type
* - operand type (for simple data types)
* - operand access
* operand global, local, parameter, or constant.
*
* The combination of these three aspects is balanced only approximately.
*
* The program does not compute anything meaningfull, but it is
* syntactically and semantically correct.
*
*)
(* Accuracy of timings and human fatigue controlled by next two lines *)
CONST
LOOPS = 50000;
TYPE
Enumeration = (Ident1, Ident2, Ident3, Ident4, Ident5);
OneToThirty = CARDINAL;
OneToFifty = CARDINAL;
CapitalLetter = CHAR;
String30 = ARRAY [0..30-1] OF CHAR;
Array1Dim = ARRAY [0..50] OF CARDINAL;
Array2Dim = ARRAY [0..50], [0..50] OF CARDINAL;
RecordPtr = POINTER TO RecordType;
RecordType = RECORD
PtrComp: RecordPtr;
Discr: Enumeration;
EnumComp: Enumeration;
IntComp: OneToFifty;
StringComp: String30;
END;
(*
* Package 1
*)
VAR
IntGlob: CARDINAL;
BoolGlob: BOOLEAN;
Char1Glob: CHAR;
Char2Glob: CHAR;
Array1Glob: Array1Dim;
Array2Glob: Array2Dim;
PtrGlb: RecordPtr;
PtrGlbNext: RecordPtr;
PROCEDURE Proc7(IntParI1, IntParI2: OneToFifty;
VAR IntParOut: OneToFifty);
VAR
IntLoc: OneToFifty;
BEGIN
IntLoc := IntParI1+2;
IntParOut := IntParI2+IntLoc;
END Proc7;
PROCEDURE Proc3(VAR PtrParOut: RecordPtr);
BEGIN
IF (PtrGlb <> NIL) THEN
PtrParOut := PtrGlb^.PtrComp
ELSE
IntGlob := 100
END;
Proc7(10, IntGlob, PtrGlb^.IntComp);
END Proc3;
PROCEDURE Func3(EnumParIn: Enumeration): BOOLEAN;
VAR
EnumLoc: Enumeration;
VAR Func3Result: BOOLEAN;
BEGIN
EnumLoc := EnumParIn;
Func3Result := EnumLoc = Ident3;
RETURN Func3Result
END Func3;
PROCEDURE Proc6(EnumParIn: Enumeration;
VAR EnumParOut: Enumeration);
BEGIN
EnumParOut := EnumParIn;
IF ( NOT Func3(EnumParIn)) THEN
EnumParOut := Ident4
END;
CASE EnumParIn OF
Ident1:
EnumParOut := Ident1
| Ident2:
IF (IntGlob > 100) THEN
EnumParOut := Ident1
ELSE
EnumParOut := Ident4
END
| Ident3:
EnumParOut := Ident2
| Ident4:
| Ident5:
EnumParOut := Ident3
ELSE
END;
END Proc6;
PROCEDURE Proc1(PtrParIn: RecordPtr);
BEGIN
WITH PtrParIn^ DO
PtrComp^ := PtrGlb^;
IntComp := 5;
PtrComp^.IntComp := IntComp;
PtrComp^.PtrComp := PtrComp;
Proc3(PtrComp^.PtrComp);
IF (PtrComp^.Discr = Ident1) THEN
PtrComp^.IntComp := 6;
Proc6(EnumComp, PtrComp^.EnumComp);
PtrComp^.PtrComp := PtrGlb^.PtrComp;
Proc7(PtrComp^.IntComp, 10, PtrComp^.IntComp);
ELSE
PtrParIn^ := PtrComp^
END;
END;
END Proc1;
PROCEDURE Proc2(VAR IntParIO: OneToFifty);
VAR
IntLoc: OneToFifty;
EnumLoc: Enumeration;
BEGIN
IntLoc := IntParIO+10;
REPEAT
IF (Char1Glob = 'A') THEN
DEC(IntLoc, 1);
IntParIO := IntLoc-IntGlob;
EnumLoc := Ident1;
END;
UNTIL EnumLoc = Ident1;
END Proc2;
PROCEDURE Proc4;
VAR
BoolLoc: BOOLEAN;
BEGIN
BoolLoc := Char1Glob = 'A';
BoolLoc := BoolLoc OR BoolGlob;
Char2Glob := 'B';
END Proc4;
PROCEDURE Proc5;
BEGIN
Char1Glob := 'A';
BoolGlob := FALSE;
END Proc5;
PROCEDURE Proc8(VAR Array1Par: Array1Dim;
VAR Array2Par: Array2Dim;
IntParI1, IntParI2: OneToFifty);
VAR
IntLoc: OneToFifty;
IntIndex: OneToFifty;
BEGIN
IntLoc := IntParI1+5;
Array1Par[IntLoc] := IntParI2;
Array1Par[IntLoc+1] := Array1Par[IntLoc];
Array1Par[IntLoc+30] := IntLoc;
FOR IntIndex := IntLoc TO (IntLoc+1) DO
Array2Par[IntLoc][IntIndex] := IntLoc
END;
Array2Par[IntLoc][IntLoc-1] := Array2Par[IntLoc][IntLoc-1]+1;
Array2Par[IntLoc+20][IntLoc] := Array1Par[IntLoc];
IntGlob := 5;
END Proc8;
PROCEDURE Func1(CharPar1, CharPar2: CapitalLetter): Enumeration;
VAR
CharLoc1, CharLoc2: CapitalLetter;
VAR Func1Result: Enumeration;
BEGIN
CharLoc1 := CharPar1;
CharLoc2 := CharLoc1;
IF (CharLoc2 <> CharPar2) THEN
Func1Result := (Ident1)
ELSE
Func1Result := (Ident2)
END;
RETURN Func1Result
END Func1;
PROCEDURE Func2(VAR StrParI1, StrParI2: String30): BOOLEAN;
VAR
IntLoc: OneToThirty;
CharLoc: CapitalLetter;
VAR Func2Result: BOOLEAN;
BEGIN
IntLoc := 2;
WHILE (IntLoc <= 2) DO
IF (Func1(StrParI1[IntLoc], StrParI2[IntLoc+1]) = Ident1) THEN
CharLoc := 'A';
INC(IntLoc, 1);
END;
END;
IF (CharLoc >= 'W') AND (CharLoc <= 'Z') THEN
IntLoc := 7
END;
IF CharLoc = 'X' THEN
Func2Result := TRUE
ELSIF CompareStr (StrParI1, StrParI2) > 0 THEN
INC(IntLoc, 7);
Func2Result := TRUE
ELSE
Func2Result := FALSE
END;
RETURN Func2Result
END Func2;
PROCEDURE Proc0;
VAR
IntLoc1: OneToFifty;
IntLoc2: OneToFifty;
IntLoc3: OneToFifty;
CharLoc: CHAR;
CharIndex: CHAR;
EnumLoc: Enumeration;
String1Loc, String2Loc: String30;
i, LoopMax: CARDINAL;
BEGIN
LoopMax := LOOPS;
NEW(PtrGlbNext);
NEW(PtrGlb);
PtrGlb^.PtrComp := PtrGlbNext;
PtrGlb^.Discr := Ident1;
PtrGlb^.EnumComp := Ident3;
PtrGlb^.IntComp := 40;
PtrGlb^.StringComp := 'DHRYSTONE PROGRAM, SOME STRING';
String1Loc := "DHRYSTONE PROGRAM, 1'ST STRING";
FOR i := 0 TO LoopMax DO
Proc5;
Proc4;
IntLoc1 := 2;
IntLoc2 := 3;
String2Loc := "DHRYSTONE PROGRAM, 2'ND STRING";
EnumLoc := Ident2;
BoolGlob := NOT Func2(String1Loc, String2Loc);
WHILE (IntLoc1 < IntLoc2) DO
IntLoc3 := 5*IntLoc1-IntLoc2;
Proc7(IntLoc1, IntLoc2, IntLoc3);
INC(IntLoc1, 1);
END;
Proc8(Array1Glob, Array2Glob, IntLoc1, IntLoc3);
Proc1(PtrGlb);
CharIndex := 'A';
WHILE CharIndex <= Char2Glob DO
IF (EnumLoc = Func1(CharIndex, 'C')) THEN
Proc6(Ident1, EnumLoc)
END;
CharIndex := VAL(CHAR, ORD(CharIndex)+1);
END;
IntLoc3 := IntLoc2*IntLoc1;
IntLoc2 := IntLoc3 DIV IntLoc1;
IntLoc2 := 7*(IntLoc3-IntLoc2)-IntLoc1;
Proc2(IntLoc1);
END;
END Proc0;
(* The Main Program is trivial *)
BEGIN
Proc0;
END dry.
Listing Two
MODULE sieve;
(* Eratosthenes sieve prime number program, Byte Magazine *)
CONST size = 8190;
VAR
psn, k, prime, iter : INTEGER;
flags : ARRAY [0..size] OF BOOLEAN;
BEGIN
FOR iter := 1 TO 25 DO
FOR psn := 0 TO size DO
flags[ psn ] := TRUE;
END(* for *);
FOR psn := 0 TO size DO
IF flags[ psn ]
THEN (* prime *)
prime := psn + psn + 3;
k := psn + prime;
WHILE k <= size DO (* cancel multiples *)
flags[ k ] := FALSE;
k := k + prime;
END(* while *);
END(* if then *);
END(* for *);
END(* for *);
END sieve.
Listing Three
MODULE fib;
(* Berkeley standard benchmark *)
(* Computes largest 16-bit Fibonacci number *)
(* Tests compiler recursion efficiency and CPU thruput *)
CONST
TIMES = 10;
VALUE = 24;
VAR
i: INTEGER;
f: CARDINAL;
(* ----------------------------------------------------------- *)
PROCEDURE fibonacci(n: INTEGER): CARDINAL;
VAR fibonacciResult: CARDINAL;
BEGIN
IF n >= 2 THEN
fibonacciResult := fibonacci(n-1)+fibonacci(n-2)
ELSE
fibonacciResult := n
END;
RETURN fibonacciResult
END fibonacci; (* --------------------------- *)
BEGIN (* main *)
FOR i := 1 TO TIMES DO
f := fibonacci(VALUE)
END;
END fib.
Listing Four
MODULE acker;
(* Berkeley standard benchmark *)
(* Ackerman's function: ack (2, 4) *)
(* Tests recursion and integer math *)
(* Repeats 10,000 times *)
VAR
loop, r: INTEGER;
(* ---------------------------------------------------------- *)
PROCEDURE ack(x1, x2: INTEGER): INTEGER;
VAR
result: INTEGER;
VAR ackResult: INTEGER;
BEGIN
IF x1 = 0 THEN
result := x2+1
ELSIF x2 = 0 THEN
result := ack(x1-1, 1)
ELSE
result := ack(x1-1, ack(x1, x2-1))
END;
ackResult := result;
RETURN ackResult
END ack; (* --------------------------- *)
BEGIN (* main *)
FOR loop := 1 TO 10000 DO
r := ack(2, 4)
END;
END acker.
Listing Five
MODULE FPMath;
(* Benchmarks floating point math package *)
FROM MathLib0 IMPORT arctan, exp, ln, sin, sqrt;
FROM InOut IMPORT Write, WriteLn, WriteString;
CONST
pi = 3.1415927;
nloops = 5;
VAR
i, j: INTEGER;
angle, result, argument: REAL;
BEGIN
WriteString('SQUARE ROOTS ');
FOR i := 1 TO nloops DO
Write ('.');
argument := 0.0;
WHILE argument <= 1000.0 DO
result := sqrt (argument);
argument := argument + 1.0
END;
END; (* FOR *)
WriteLn;
WriteString('LOGS ');
FOR i := 1 TO nloops DO
Write ('.');
argument := 0.1;
WHILE argument <= 1000.1 DO
result := ln (argument);
argument := argument + 1.0
END;
END; (* FOR *)
WriteLn;
WriteString('EXPONENTIALS ');
FOR i := 1 TO nloops DO
Write ('.');
argument := 0.1;
WHILE argument <= 10.0 DO
result := exp (argument);
argument := argument + 0.01
END;
END; (* FOR *)
WriteLn;
WriteString('ARCTANS ');
FOR i := 1 TO nloops DO
Write ('.');
argument := 0.1;
WHILE argument <= 10.0 DO
angle := arctan (argument);
argument := argument + 0.01
END;
END; (* FOR *)
WriteLn;
WriteString('SINES ');
FOR i := 1 TO nloops DO
Write ('.');
angle := 0.0;
WHILE angle <= 2.0 * pi DO
result := sin (angle);
angle := angle + pi / 360.0
END;
END; (* FOR *)
WriteLn;
END FPMath.
Listing Six
MODULE QSort;
(* The test uses QuickSort to measure recursion speed *)
(* An ordered array is created by the program and is *)
(* reverse sorted. The process is performed 'MAXITER'*)
(* number of times. *)
CONST SIZE = 1000;
MAXITER = 50;
TYPE NUMBERS = ARRAY[1..SIZE] OF CARDINAL;
VAR Iter, Offset, I, J, Temporary : CARDINAL;
A : NUMBERS;
PROCEDURE InitializeArray ;
(* Procedure to initialize array *)
VAR I : CARDINAL;
BEGIN
FOR I := 1 TO SIZE DO
A[I] := SIZE - I + 1
END; (* FOR I *)
END InitializeArray;
PROCEDURE QuickSort;
(* Procedure to perform a QuickSort *)
PROCEDURE Sort(Left, Right : CARDINAL);
VAR i, j : CARDINAL;
Data1, Data2 : CARDINAL;
BEGIN
i := Left; j := Right;
Data1 := A[(Left + Right) DIV 2];
REPEAT
WHILE A[i] < Data1 DO INC(i) END;
WHILE Data1 < A[j] DO DEC(j) END;
IF i <= j THEN
Data2 := A[i]; A[i] := A[j]; A[j] := Data2;
INC(i); DEC(j)
END;
UNTIL i > j;
IF Left < j THEN Sort(Left,j) END;
IF i < Right THEN Sort(i,Right) END;
END Sort;
BEGIN (* QuickSort *)
Sort(1,SIZE);
END QuickSort;
BEGIN (* Main *)
FOR Iter := 1 TO MAXITER DO
InitializeArray;
QuickSort
END; (* FOR Iter *)
END QSort.
Listing Seven
MODULE ShSort;
(* Tests Shell sort speed on an integer array of ARSIZE elements. *)
(* Creates an array ordered from smaller to larger, then sorts it *)
(* into reverse order. Repeats NSORTS times. *)
CONST ARSIZE = 1000;
NSORTS = 20;
TYPE NUMBERS = ARRAY [1..ARSIZE] OF INTEGER;
VAR IsInOrder, Ascending : BOOLEAN;
Iter, Offset, I, J, Temporary : CARDINAL;
Ch : CHAR;
A : NUMBERS;
PROCEDURE InitializeArray ;
(* Initialize array *)
BEGIN
FOR I := 1 TO ARSIZE DO
A [I] := I
END; (* FOR I *)
END InitializeArray;
PROCEDURE ShellSort ;
(* Shell-Meztner sort *)
PROCEDURE Swap;
(* Swap elements A[I] and A[J] *)
BEGIN
IsInOrder := FALSE;
Temporary := A[I];
A[I] := A[J];
A[J] := Temporary;
END Swap;
BEGIN
(* Toggle 'Ascending' flag *)
Ascending := NOT Ascending;
Offset := ARSIZE;
WHILE Offset > 1 DO
Offset := Offset DIV 2;
REPEAT
IsInOrder := TRUE;
FOR J := 1 TO (ARSIZE - Offset) DO
I := J + Offset;
IF Ascending
THEN IF A[I] < A[J] THEN Swap END
ELSE IF A[I] > A[J] THEN Swap END
END; (* IF AscendingOrder *)
END; (* FOR J *)
UNTIL IsInOrder;
END; (* End of while-loop *)
END ShellSort;
BEGIN (* Main *)
InitializeArray;
Ascending := TRUE;
FOR Iter := 1 TO NSORTS DO
ShellSort
END;
END ShSort.
Listing Eight
MODULE cortn;
(* Benchmark to test speed of coroutine switching *)
(* Shifts NCHARS characters to upper-case *)
(* Two transfers per character *)
FROM SYSTEM IMPORT NEWPROCESS, TRANSFER, ADDRESS, BYTE, ADR;
CONST NCHARS = 50000;
WorkSize = 1000;
VAR ch : ARRAY [1..NCHARS] OF CHAR;
ShiftWork, CountWork : ARRAY [1..WorkSize] OF BYTE;
count, chval, c : CARDINAL;
main, shifter, counter : ADDRESS;
PROCEDURE CountProc;
(* Increments count *)
BEGIN
REPEAT
count := count + 1;
TRANSFER (counter, shifter);
UNTIL FALSE;
END CountProc;
PROCEDURE ShiftProc;
(* Shifts char at 'count' to upper case *)
BEGIN
REPEAT
IF (ch [count] >= 'a') AND (ch [count] <= 'z') THEN
ch [count] := CHR (ORD (ch [count]) - 32)
END;
TRANSFER (shifter, counter);
UNTIL count = NCHARS;
TRANSFER (shifter, main);
END ShiftProc;
BEGIN (* Main program *)
(* Load array with lower-case letters *)
chval := ORD ('a');
FOR c := 1 TO NCHARS DO
ch [c] := CHR (chval);
chval := chval + 1;
IF chval > ORD ('z') THEN
chval := ORD ('a');
END;
END;
(* Set up coroutines *)
NEWPROCESS (CountProc, ADR (CountWork), WorkSize, counter);
NEWPROCESS (ShiftProc, ADR (ShiftWork), WorkSize, shifter);
(* Dispatch the controlling task *)
count := 1;
TRANSFER (main, shifter);
END cortn.
Listing Nine
MODULE ncortn;
(* Does the same thing as CORTN.MOD, but without *)
(* coroutine switching *)
(* Subtract run time for this from time for CORTN *)
(* to find out actual coroutine overhead *)
CONST NCHARS = 50000;
WorkSize = 1000;
VAR ch : ARRAY [1..NCHARS] OF CHAR;
count, chval, c : CARDINAL;
PROCEDURE CountProc;
(* Increments count *)
BEGIN
count := count + 1;
END CountProc;
PROCEDURE ShiftProc;
(* Shifts all chars in array 'ch' upper case *)
BEGIN
REPEAT
IF (ch [count] >= 'a') AND (ch [count] <= 'z') THEN
ch [count] := CHR (ORD (ch [count]) - 32)
END;
CountProc; (* Substitute call for TRANSFER *)
UNTIL count = NCHARS;
END ShiftProc;
BEGIN (* Main program *)
(* Load array with lower-case letters *)
chval := ORD ('a');
FOR c := 1 TO NCHARS DO
ch [c] := CHR (chval);
chval := chval + 1;
IF chval > ORD ('z') THEN
chval := ORD ('a');
END;
END;
(* Dispatch the controlling task *)
count := 1;
ShiftProc;
END ncortn.