Modula-2 is an actively used programming language created in 1978.

41Years Old 2,825Users 2Jobs

Example code from the Hello World Collection:

(* Hello World in Modula-2 *)

MODULE HelloWorld;
FROM InOut IMPORT WriteString,WriteLn;
BEGIN
  WriteString("Hello World!");
  WriteLn;
END HelloWorld.

Example code from Linguist:

IMPLEMENTATION MODULE HuffChan;

(*
 This module shows how to redefine standard IO file functions. It provides
 functions for reading and writing packed files opened in Raw mode.
*)

IMPORT IOChan, IOLink, ChanConsts, IOConsts, SYSTEM, Strings;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;

CONST
  rbldFrq = 512;	(* means: every 512 bytes rebuild table *)

TYPE
  charTap  = POINTER TO ARRAY [0..MAX(INTEGER)-1] OF CHAR;
  smbTp = POINTER TO smbT;

  smbT = RECORD			(* Huffman's tree *)
    ch			: CHAR;
    n			: CARDINAL; (* frequncy of char ch *)
    left,right,next	: smbTp;
  END;

  tblT = RECORD		(* bit sequence for code *)
    vl		: CARDINAL;	(* bit sequence *)
    cnt		: INTEGER;	(* it length *)
  END;

  lclDataT = RECORD	(* channel's local data *)
    tRoot 	: smbTp;
    htbl	: ARRAY [0..255] OF tblT;     (* code -> bit sequence table *)
    ftbl  	: ARRAY [0..255] OF CARDINAL; (* frequncey table *)
    wBf,rb1,rb2	: CARDINAL;
    wbc,rbc,smc	: INTEGER;
    chid	: IOChan.ChanId;
  END;
  lclDataTp = POINTER TO lclDataT;
  charp     = POINTER TO CHAR;

VAR
  did	: IOLink.DeviceId;
  ldt	: lclDataTp;


PROCEDURE Shf(a:CARDINAL; b : INTEGER) : CARDINAL; (* shl a,b (or shr) *)
BEGIN
  RETURN SYSTEM.CAST(CARDINAL,SYSTEM.SHIFT(SYSTEM.CAST(BITSET,a),b));
END Shf;

PROCEDURE wrDword(a:CARDINAL);	(* write 4 bytes to file *)
BEGIN
  IOChan.RawWrite(ldt^.chid,SYSTEM.ADR(a),4);
END wrDword;

PROCEDURE rdDword() : CARDINAL;  (* read 4 bytes from file *)
VAR
  a,z : CARDINAL;
BEGIN
  a:=0;
  IOChan.RawRead(ldt^.chid,SYSTEM.ADR(a),4,z);
  RETURN a;
END rdDword;

PROCEDURE wrSmb(ch : CHAR);	(* write bit sequence for code ch *)
VAR
  v,h : CARDINAL;
  b,c : INTEGER;
BEGIN
  WITH ldt^ DO
    v:=htbl[ORD(ch)].vl;
    c:=htbl[ORD(ch)].cnt;
    IF c+wbc<=32 THEN
      wBf:=Shf(wBf,c);
      wBf:=wBf+v;
      wbc:=wbc+c;
      IF wbc=32 THEN
	wrDword(wBf);
	wBf:=0; wbc:=0;
      END;
      RETURN;
    END;
    b:=c+wbc-32;
    h:=Shf(v,-b);
    wBf:=Shf(wBf,32-wbc)+h;
    wrDword(wBf);
    wBf:=v-Shf(h,b);
    wbc:=b;
  END;
END wrSmb;

PROCEDURE flush();	(* write data in buffer *)
BEGIN
  WITH ldt^ DO
    wBf:=Shf(wBf,32-wbc);
    wrDword(wBf);
  END;
END flush;

PROCEDURE getSym() : CHAR; (* find code for first bit sequence in buffer *)
VAR
  t,i : CARDINAL;
  b   : INTEGER;
BEGIN
  WITH ldt^ DO
    IF rbc<=32 THEN
      rb2:=rdDword();
      t:=Shf(rb2,-rbc);
      IF rbc=32 THEN t:=0; END;
      rb1:=rb1+t;
      rb2:=Shf(rb2,32-rbc);
      IF rbc=0 THEN rb2:=0; END;
      rbc:=rbc+32;
    END;
    FOR i:=0 TO 255 DO
      t:=Shf(rb1,htbl[i].cnt-32);
      IF t=htbl[i].vl THEN
	rb1:=Shf(rb1,htbl[i].cnt);
	b:=32-htbl[i].cnt;
	t:=Shf(rb2,-b);
	rb1:=rb1+t;
	rb2:=Shf(rb2,32-b);
	rbc:=rbc+b-32;
	RETURN CHR(i);
      END;
    END;
  END;
END getSym;

PROCEDURE Insert(s : smbTp); (* insert new character in Huffman's tree *)
VAR
  cr : smbTp;
BEGIN
  WITH ldt^ DO
    IF tRoot=NIL THEN
      cr:=tRoot;
      tRoot:=s;
      s^.next:=cr;
      RETURN;
    ELSIF tRoot^.n<=s^.n THEN
      cr:=tRoot;
      tRoot:=s;
      s^.next:=cr;
      RETURN;
    END;
    cr:=tRoot;
    WHILE (cr^.next<>NIL) & (cr^.next^.n>s^.n) DO
      cr:=cr^.next;
    END;
    s^.next:=cr^.next;
    cr^.next:=s;
  END;
END Insert;

PROCEDURE BuildTree(); (* build Huffman's tree *)
VAR
  cr,ocr,ncr : smbTp;
BEGIN
  WITH ldt^ DO
    LOOP
      ocr:=NIL; cr:=tRoot;
      WHILE cr^.next^.next<>NIL  DO
	ocr:=cr; cr:=cr^.next;
      END;
      NEW(ncr);
      ncr^.n:=cr^.n+cr^.next^.n;
      ncr^.left:=cr;
      ncr^.right:=cr^.next;
      IF ocr<>NIL THEN
	ocr^.next:=NIL;
	Insert(ncr);
      ELSE
	tRoot:=NIL;
	Insert(ncr);
	EXIT;
      END;
    END;
  END;
END BuildTree;

PROCEDURE BuildTable(cr: smbTp; vl,n: CARDINAL); (* build table: code -> bit sequence *)
BEGIN
  WITH ldt^ DO
    IF cr^.left=NIL THEN
      htbl[ORD(cr^.ch)].vl:=vl;
      htbl[ORD(cr^.ch)].cnt:=n;
      DISPOSE(cr);
      RETURN;
    END;
    vl:=vl*2;
    BuildTable(cr^.left,vl,n+1);
    BuildTable(cr^.right,vl+1,n+1);
    DISPOSE(cr);
  END;
END BuildTable;

PROCEDURE clcTab(); (* build code/bitseq. table from frequency table *)
VAR
  i : CARDINAL;
  s : smbTp;
BEGIN
  WITH ldt^ DO
    tRoot:=NIL;
    FOR i:=0 TO 255 DO
      NEW(s);
      s^.ch:=CHR(i);
      s^.n:=ftbl[i];
      s^.left:=NIL; s^.right:=NIL; s^.next:=NIL;
      Insert(s);
    END;
    BuildTree();
    BuildTable(tRoot,0,0);
  END;
END clcTab;

PROCEDURE iniHuf();
VAR
  i : CARDINAL;
BEGIN
  WITH ldt^ DO
    FOR i:=0 TO 255 DO
      ftbl[i]:=1;
    END;
    wBf:=0; wbc:=0; rb1:=0; rb2:=0; rbc:=0;
    smc:=0;
    clcTab();
  END;
END iniHuf;


PROCEDURE RawWrite(x: IOLink.DeviceTablePtr; buf: SYSTEM.ADDRESS;
		len: CARDINAL);
VAR
  i	: CARDINAL;
  ch	: CHAR;
  cht	: charTap;
BEGIN
  IF len = 0 THEN RETURN; END;
  ldt:=SYSTEM.CAST(lclDataTp,x^.cd);
  cht:=SYSTEM.CAST(charTap,buf);
  WITH ldt^ DO
    FOR i:=0 TO len-1 DO
      ch:=cht^[i];
      wrSmb(ch);
      IF ch = 377C THEN wrSmb(ch); END;
      ftbl[ORD(ch)]:=ftbl[ORD(ch)]+1; smc:=smc+1;
      IF smc=rbldFrq THEN
	clcTab();
	smc:=0;
      END;
    END;
  END;
  x^.result:=IOChan.ReadResult(ldt^.chid);
END RawWrite;

PROCEDURE RawRead(x: IOLink.DeviceTablePtr; buf: SYSTEM.ADDRESS;
		blen: CARDINAL; VAR len: CARDINAL);
VAR
  i	: CARDINAL;
  cht	: charTap;
  ch	: CHAR;
BEGIN
  ldt:=SYSTEM.CAST(lclDataTp,x^.cd);
  cht:=SYSTEM.CAST(charTap,buf);
  IF (blen=0) OR (x^.result<>IOConsts.allRight) THEN len:=0; RETURN; END;
  WITH ldt^ DO
    FOR i:=0 TO blen-1 DO
      ch:=getSym();
      IF ch = 377C THEN
	ch:=getSym();
	IF ch = 0C THEN
	  x^.result:=IOConsts.endOfInput;
	  len:=i; cht^[i]:=0C;
	  RETURN;
	END;
      END;
      cht^[i]:=ch;
      ftbl[ORD(ch)]:=ftbl[ORD(ch)]+1; smc:=smc+1;
      IF smc=rbldFrq THEN
	clcTab();
	smc:=0;
      END;
    END;
    len:=blen;
  END;
END RawRead;

PROCEDURE CreateAlias(VAR cid: ChanId; io: ChanId; VAR res: OpenResults);
VAR
  x	: IOLink.DeviceTablePtr;
BEGIN
  IOLink.MakeChan(did,cid);
  IF cid = IOChan.InvalidChan() THEN
    res:=ChanConsts.outOfChans
  ELSE
    NEW(ldt);
    IF ldt=NIL THEN
      IOLink.UnMakeChan(did,cid);
      res:=ChanConsts.outOfChans;
      RETURN;
    END;
    x:=IOLink.DeviceTablePtrValue(cid,did,IOChan.notAvailable,"");
    ldt^.chid:=io;
    x^.cd:=ldt;
    x^.doRawWrite:=RawWrite;
    x^.doRawRead:=RawRead;
    res:=ChanConsts.opened;
    iniHuf();
    x^.result:=IOConsts.allRight;
  END;
END CreateAlias;

PROCEDURE DeleteAlias(VAR cid: ChanId);
VAR
  x	: IOLink.DeviceTablePtr;
BEGIN
  x:=IOLink.DeviceTablePtrValue(cid,did,IOChan.notAvailable,"");
  ldt:=x^.cd;
  IF ldt^.rbc=0 THEN
    wrSmb(377C);
    wrSmb(0C);
    flush();
  END;
  DISPOSE(ldt);
  IOLink.UnMakeChan(did,cid);
END DeleteAlias;

BEGIN
  IOLink.AllocateDeviceId(did);
END HuffChan.

Example code from Wikipedia:

ABS         EXCL            LONGINT    REAL
BITSET      FALSE           LONGREAL   SIZE
BOOLEAN     FLOAT           MAX        TRUE
CAP         HALT            MIN        TRUNC
CARDINAL    HIGH            NIL        VAL
CHAR        INC             ODD
CHR         INCL            ORD
DEC         INTEGER         PROC
Edit

Last updated February 11th, 2019