XDS Modula-2 Back to the Win32 Shootout
Back to dada's perl lab
[The Original Shootout]   [NEWS]   [FAQ]   [Methodology]   [Platform Details]   [Acknowledgements]   [Scorecard]  
All Source For modula2
Ackermann's Function
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m ackermann
   To run:     ackermann 8
*)

MODULE Ackermann;

(* Prefer unqualified procedure import *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteString, WriteLn;
FROM SWholeIO IMPORT WriteCard;


PROCEDURE Ack (m, n: CARDINAL) : CARDINAL;
BEGIN
   IF m=0 THEN RETURN n+1; END;
   IF n=0 THEN RETURN Ack(m-1, 1); END;
   RETURN Ack(m-1, Ack(m, n-1));
END Ack;


VAR n: CARDINAL;

BEGIN
  n := N();

  WriteString("Ack(3," ); WriteCard(n,1); WriteString("): ");
  WriteCard( Ack(3,n), 1); WriteLn;
END Ackermann.
Array Access
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To compile: xc =m ary3
   To run:     ary3 7000
*)

MODULE Ary3;
<* m2extensions + *>
<* storage + *>
<* ioverflow - *>
<* noptralias + *>
<* checkdindex - *>
<* checknil - *>

(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteString, WriteLn;
FROM SWholeIO IMPORT WriteInt;

TYPE
   Array_Type = ARRAY OF INTEGER;
   Array_Ptr_Type = POINTER TO Array_Type;

VAR
   n, i, m, j: INTEGER;
   x, y:  Array_Ptr_Type;

BEGIN
   n := N();

   NEW(x, n);
   NEW(y, n);

   FOR i := 0 TO INT(HIGH(x^)) DO
      x^[i] := i+1;
      y^[i] := 0;
   END;

   m := HIGH(y^);
   FOR j := 1 TO 1000 DO
      FOR i := 0 TO m DO
         INC(y^[i], x^[i]);
      END;
   END;

   WriteInt(y^[0],1); WriteInt(y^[HIGH(y^)],0); WriteLn;

   DISPOSE(x);
   DISPOSE(y);
END Ary3.
Count Lines/Words/Chars
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m wc
   To run:   wc < input.txt
*)

MODULE Wc;
<* m2extensions + *>

FROM SRawIO IMPORT Read;
FROM SIOResult IMPORT ReadResult, wrongFormat;
FROM SYSTEM IMPORT ADR, FILL;
FROM STextIO IMPORT WriteLn;
FROM SWholeIO IMPORT WriteCard;

CONST
   buffer_size = 4096;
   LF = CHR(10);
   CR = CHR(13);
   TAB = CHR(9);
   Space = CHR(32);
   Null = CHR(0);


TYPE Buffer_Type = ARRAY [1..buffer_size] OF CHAR;


PROCEDURE Fill(VAR buf: Buffer_Type);
   VAR i: INTEGER;
BEGIN
   (* Clear the buffer *)
   FILL( ADR(buf), Null, buffer_size );

   (* Raw read into the buffer *)
   Read(buf);

   IF ReadResult() = wrongFormat THEN
      (* ignore LF if it's followed by end of input *)
      i := LENGTH(buf);
      IF (i > 0) AND (buf[i] = LF) THEN
         buf[i] := Null;
      END;
   END;
END Fill;


VAR
   nc, nl, nw: CARDINAL;
   i, read_length: CARDINAL;
   buf: Buffer_Type;
   c: CHAR;
   insideWord: BOOLEAN;

BEGIN
   insideWord := FALSE;	
   REPEAT
      Fill(buf);

      read_length := LENGTH(buf);	
      INC(nc, read_length);	
      FOR i := 1 TO read_length DO
         c := buf[i];
         IF c = LF THEN INC(nl); END;	
         IF (c = Space) OR (c = LF) OR (c = TAB) OR (c = CR) THEN
            insideWord := FALSE;	
         ELSIF NOT insideWord THEN
            insideWord := TRUE;	
            INC(nw);
         END;
      END;
   UNTIL read_length<1;

   WriteCard(nl,1); WriteCard(nw,0); WriteCard(nc,0); WriteLn;
END Wc.
Exception Mechanisms
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m except
   To run:   except 200000
*)

MODULE Except;
<* procinline + *>

(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

IMPORT EXCEPTIONS;
FROM STextIO IMPORT WriteString, WriteLn;
FROM SWholeIO IMPORT WriteCard;


VAR lo, hi: CARDINAL;
    n, i: CARDINAL;
    source: EXCEPTIONS.ExceptionSource;

TYPE Exceptions = (Lo_Exception, Hi_Exception);


PROCEDURE Exception(): Exceptions;
BEGIN
   RETURN VAL(Exceptions, EXCEPTIONS.CurrentNumber(source));
END Exception;


PROCEDURE BlowUp(i: CARDINAL);
BEGIN
   IF ODD(i) THEN
      EXCEPTIONS.RAISE(source, ORD(Hi_Exception), "HI Exception");
   ELSE
      EXCEPTIONS.RAISE(source, ORD(Lo_Exception), "LO Exception");
   END;
END BlowUp;


PROCEDURE Lo_Function(i: CARDINAL);
BEGIN
   BlowUp(i);
EXCEPT
   IF Exception() = Lo_Exception THEN
      INC(lo);
      RETURN;
   END;
END Lo_Function;


PROCEDURE Hi_Function(i: CARDINAL);
BEGIN
   Lo_Function(i);
EXCEPT
   IF Exception() = Hi_Exception THEN
      INC(hi);
      RETURN;	
   END;
END Hi_Function;


PROCEDURE Some_Function(i: CARDINAL);
BEGIN
   Hi_Function(i);
EXCEPT
   WriteString("We shouldn't get here!");
   WriteLn;
   RETURN;
END Some_Function;


BEGIN
   n := N();
   lo := 0;
   hi := 0;
   EXCEPTIONS.AllocateSource(source);

   WHILE n > 0 DO
      DEC(n);
      Some_Function(i);
   END;  	

   WriteString("Exceptions: HI="); WriteCard(hi,1);
   WriteString(" / LO="); WriteCard(lo,1); WriteLn;
END Except.
Fibonacci Numbers
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m fibo
   To run:     fibo 32
*)

MODULE Fibo;

(* Prefer qualified procedures *)
IMPORT STextIO, SWholeIO, LanguageShootout;


PROCEDURE Fibo (n: CARDINAL) : CARDINAL;
BEGIN
   IF n<2 THEN
      RETURN 1;
   ELSE
      RETURN Fibo(n-2) + Fibo(n-1);
   END;
END Fibo;


BEGIN
  SWholeIO.WriteCard( Fibo( LanguageShootout.N() ),1);
  STextIO.WriteLn;
END Fibo.
Hello World
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m hello
   To run:   hello
*)

MODULE Hello;

FROM STextIO IMPORT WriteString, WriteLn;

BEGIN
  WriteString ("hello world"); WriteLn;
END Hello.
List Operations
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To compile: xc =m lists
   To run:     lists 16
*)

MODULE Lists;
<* m2extensions + *>
<* storage + *>

(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteString, WriteLn;
FROM SWholeIO IMPORT WriteCard;


(* We need an ADT let's implement a double-linked list *)
TYPE
   Node_Ptr = POINTER TO Queue_Node;
   Queue_Node =
      RECORD
         prev, next: Node_Ptr;
         item: CARDINAL;
      END;		
		
   Queue_Ptr = POINTER TO Queue_Type;
   Queue_Type =
      RECORD
         first, last: Node_Ptr;
         length: CARDINAL;
      END;


   Queue_Positions = (First, Last);	


VAR node, node2: Node_Ptr;


PROCEDURE Initialize(VAR q: Queue_Ptr);
BEGIN
   NEW(q);
   q^.length := 0;
   q^.first := NIL;
   q^.last := NIL;
END Initialize;


PROCEDURE Add(position: Queue_Positions; VAR q: Queue_Ptr; item: CARDINAL);
BEGIN
   NEW(node);
   node^.item := item;
   INC(q^.length);

   IF q^.length = 1 THEN
      node^.prev := NIL;
      node^.next := NIL;
      q^.first := node;
      q^.last := node;
   ELSE
      IF position = First THEN
         node^.prev := NIL;
         node^.next := q^.first;
         q^.first^.prev := node;
         q^.first := node;
      ELSE
         node^.prev := q^.last;
         node^.next := NIL;
         q^.last^.next := node;
         q^.last := node;
      END;
   END;
END Add;


PROCEDURE Remove(position: Queue_Positions; VAR q: Queue_Ptr): CARDINAL;
   VAR item: CARDINAL;
BEGIN
   IF q^.length = 0 THEN
      RETURN 0;
   END;

   IF position = First THEN
      node := q^.first;
   ELSE
      node := q^.last;
   END;

   item := node^.item;
   DEC(q^.length);

   IF q^.length = 0 THEN
      q^.first := NIL;
      q^.last := NIL;
   ELSE
      IF position = First THEN
         q^.first := node^.next;
	 q^.first^.prev := NIL;
      ELSE
         q^.last := node^.prev;
	 q^.last^.next := NIL;	
      END;
   END;
   DISPOSE(node);
   RETURN item;
END Remove;


PROCEDURE Dispose(VAR q: Queue_Ptr);
BEGIN
   WHILE q^.first # NIL DO
      node := q^.first^.next;
      DISPOSE(q^.first);
      q^.first := node;
   END;
   DISPOSE(q);
END Dispose;


PROCEDURE Copy(q: Queue_Ptr; VAR qcopy: Queue_Ptr);
BEGIN
   node2 := q^.first ;
   WHILE node2 # NIL DO
      Add(Last, qcopy, node2^.item);
      node2 := node2^.next;
   END;
END Copy;


PROCEDURE Reverse(VAR q: Queue_Ptr);
BEGIN
   node := q^.first;
   q^.first := q^.last;
   q^.last := node;
   WHILE node # NIL DO
      node2 := node^.next;
      node^.next := node^.prev;
      node^.prev := node2;
      node := node2;
   END;
END Reverse;


PROCEDURE Length(q: Queue_Ptr): CARDINAL;
BEGIN
   RETURN q^.length;
END Length;


PROCEDURE FirstItem(q: Queue_Ptr): CARDINAL;
BEGIN
   IF q^.length = 0 THEN
      RETURN 0;
   ELSE
      RETURN q^.first^.item;
   END;
END FirstItem;


PROCEDURE Equal(q,q2: Queue_Ptr): BOOLEAN;
BEGIN
   IF q^.length # q2^.length THEN
      RETURN FALSE;
   END;

   node := q^.first;
   node2 := q2^.first;
   WHILE node # NIL DO
      IF node^.item # node2^.item THEN
         RETURN FALSE;
      END;
      node := node^.next;
      node2 := node2^.next;
   END;
   RETURN TRUE;
END Equal;


CONST SIZE = 10000;

VAR L1, L2, L3: Queue_Ptr;
    i, m, n, lengthL1: CARDINAL;

BEGIN
   n := N();

   FOR m := 1 TO n DO
      NEW(L1);
      Initialize(L1);
      FOR i := 1 TO SIZE DO
         Add(Last, L1, i);
      END;

      NEW(L2);
      Initialize(L2);
      Copy(L1, L2);

      NEW(L3);
      Initialize(L3);
      WHILE Length(L2) > 0 DO
         Add(Last, L3, ( Remove(First, L2)) );
      END;

      WHILE Length(L3) > 0 DO
         Add(Last, L2, ( Remove(Last, L3) ));
      END;

      Reverse(L1);

      IF FirstItem(L1) # SIZE THEN
         WriteString("First item of L1 # SIZE"); WriteLn;
      END;
      IF NOT Equal(L1, L2) THEN
         WriteString("L1 # L2"); WriteLn;
      END;

      lengthL1 := Length(L1);

      Dispose(L1);
      Dispose(L2);
      Dispose(L3);
   END;

   WriteCard(lengthL1,1); WriteLn;
END Lists.
Nested Loops
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m nestedloop
   To run: nestedloop 16
*)

MODULE NestedLoop;
<* coverflow - *>

(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteLn;
FROM SWholeIO IMPORT WriteCard;


VAR
   count: CARDINAL;
   n, g, h, i, j, k, l: CARDINAL;

BEGIN
   n := N();
   count := 0;

   FOR g := 1 TO n DO
      FOR h := 1 TO n DO
         FOR i := 1 TO n DO
            FOR j := 1 TO n DO
               FOR k := 1 TO n DO
	          FOR l := 1 TO n DO
		     INC(count);
		  END;
               END;
            END;
	 END;
      END;
   END;  	
		
   WriteCard(count,1); WriteLn;
END NestedLoop.
Random Number Generator
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m random
   To run:   random 900000
*)

MODULE Random;
<* procinline + *>
<* ioverflow - *>
<* alignment="8" *>


(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteLn;
FROM SLongIO IMPORT WriteFixed;


CONST
   IM = 139968;
   IA = 3877;
   IC = 29573;

VAR
   n, last: INTEGER;
   result: LONGREAL;

PROCEDURE Gen_Random(max: LONGREAL): LONGREAL;
BEGIN
   last := (last*IA + IC) REM IM;
   RETURN max * LFLOAT(last) / LFLOAT(IM);
END Gen_Random;


BEGIN
   n := N();
   last := 42;

   WHILE n > 0 DO
      DEC(n);
      result := Gen_Random(100.0);
   END;  	

   WriteFixed(result,9,1); WriteLn;
END Random.
Sieve of Erathostenes
(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To build: xc =m sieve
   To run:   sieve 900
*)

MODULE Sieve;
<* m2extensions + *>
<* checkindex - *>
<* coverflow - *>

(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteString, WriteLn;
FROM SWholeIO IMPORT WriteCard;
FROM SYSTEM IMPORT ADR, FILL;


CONST
   start = 2;
   stop = 8192;

TYPE Boolean_Array = ARRAY [start..stop] OF BOOLEAN;

VAR
   array_size: CARDINAL;
   n, count, i, k: CARDINAL;
   isPrimeNumber: Boolean_Array;

BEGIN
   n := N();
   array_size := SIZE(Boolean_Array);

   WHILE n > 0 DO
      DEC(n);
      count := 0;

      (* Set all the isPrimeNumber array to TRUE *)
      FILL( ADR(isPrimeNumber), TRUE, array_size );

      FOR i := start TO stop DO
         IF isPrimeNumber[i] THEN
	    INC(count);
            k := i+i;
            WHILE k <= stop DO
               isPrimeNumber[k] := FALSE;
	       INC(k, i);
            END;
         END;
      END;
   END;  	

   WriteString("Count:"); WriteCard(count,0); WriteLn;
END Sieve.