Power-Programmierung/CD1.mdf/magazine/drdobbs/1988/09/porter.lis

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.