_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.







