Category : Files from Magazines
Archive   : DDJ0988.ZIP
Filename : PORTER.LIS

 
Output of file : PORTER.LIS contained in archive : DDJ0988.ZIP
_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.









  3 Responses to “Category : Files from Magazines
Archive   : DDJ0988.ZIP
Filename : PORTER.LIS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/