Commits

Georg Brandl committed 33cedd2

Add Modula-2 lexer, contributed by Benjamin Kowarsch.

Comments (0)

Files changed (6)

 * David Hess, Fish Software, Inc. -- Objective-J lexer
 * Varun Hiremath -- Debian control lexer
 * Dennis Kaarsemaker -- sources.list lexer
+* Benjamin Kowarsch -- Modula-2 lexer
 * Marek Kubica -- Scheme lexer
 * Jochen Kupperschmidt -- Markdown processor
 * Gerd Kurzbach -- Modelica lexer
 
   * Ada
   * Coldfusion
+  * Modula-2
   * haXe
   * R console
   * Objective-J

pygments/lexers/_mapping.py

     'MatlabSessionLexer': ('pygments.lexers.math', 'Matlab session', ('matlabsession',), (), ()),
     'MiniDLexer': ('pygments.lexers.agile', 'MiniD', ('minid',), ('*.md',), ('text/x-minidsrc',)),
     'ModelicaLexer': ('pygments.lexers.other', 'Modelica', ('modelica',), ('*.mo',), ('text/x-modelica',)),
+    'Modula2Lexer': ('pygments.lexers.compiled', 'Modula-2', ('modula2', 'm2'), ('*.def', '*.mod'), ('text/x-modula2',)),
     'MoinWikiLexer': ('pygments.lexers.text', 'MoinMoin/Trac Wiki markup', ('trac-wiki', 'moin'), (), ('text/x-trac-wiki',)),
     'MuPADLexer': ('pygments.lexers.math', 'MuPAD', ('mupad',), ('*.mu',), ()),
     'MxmlLexer': ('pygments.lexers.web', 'MXML', ('mxml',), ('*.mxml',), ()),

pygments/lexers/compiled.py

 __all__ = ['CLexer', 'CppLexer', 'DLexer', 'DelphiLexer', 'JavaLexer',
            'ScalaLexer', 'DylanLexer', 'OcamlLexer', 'ObjectiveCLexer',
            'FortranLexer', 'GLShaderLexer', 'PrologLexer', 'CythonLexer',
-           'ValaLexer', 'OocLexer', 'GoLexer', 'FelixLexer', 'AdaLexer']
+           'ValaLexer', 'OocLexer', 'GoLexer', 'FelixLexer', 'AdaLexer',
+           'Modula2Lexer']
 
 
 class CLexer(RegexLexer):
             include('root'),
         ],
     }
+
+
+class Modula2Lexer(RegexLexer):
+    """
+    For `Modula-2 <http://www.modula2.org/>`_ source code.
+
+    Additional options that determine which keywords are highlighted:
+
+    `pim`
+        Select PIM Modula-2 dialect (default: True).
+    `iso`
+        Select ISO Modula-2 dialect (default: False).
+    `objm2`
+        Select Objective Modula-2 dialect (default: False).
+    `gm2ext`
+        Also highlight GNU extensions (default: False).
+
+    *New in Pygments 1.3.*
+    """
+    name = 'Modula-2'
+    aliases = ['modula2', 'm2']
+    filenames = ['*.def', '*.mod']
+    mimetypes = ['text/x-modula2']
+
+    flags = re.MULTILINE | re.DOTALL
+
+    _ws = r'(?:\s|//.*?\n|/[*].*?[*]/)+'
+
+    tokens = {
+        'whitespace': [
+            (r'\n+', Text), # blank lines
+            (r'\s+', Text), # whitespace
+        ],
+        'identifiers': [
+            (r'([a-zA-Z_\$][a-zA-Z0-9_\$]*)', Name),
+        ],
+        'numliterals': [
+            (r'[01]+B', Number.Binary),        # binary number (ObjM2)
+            (r'[0-7]+B', Number.Oct),          # octal number (PIM + ISO)
+            (r'[0-7]+C', Number.Oct),          # char code (PIM + ISO)
+            (r'[0-9A-F]+C', Number.Hex),       # char code (ObjM2)
+            (r'[0-9A-F]+H', Number.Hex),       # hexadecimal number
+            (r'[0-9]+\.[0-9]+E[+-][0-9]+', Number.Float), # real number
+            (r'[0-9]+\.[0-9]+', Number.Float), # real number
+            (r'[0-9]+', Number.Integer),       # decimal whole number
+        ],
+        'strings': [
+            (r"'(\\\\|\\'|[^'])*'", String), # single quoted string
+            (r'"(\\\\|\\"|[^"])*"', String), # double quoted string
+        ],
+        'operators': [
+            (r'[*/+=#~&<>\^-]', Operator),
+            (r':=', Operator),   # assignment
+            (r'@', Operator),    # pointer deref (ISO)
+            (r'\.\.', Operator), # ellipsis or range
+            (r'`', Operator),    # Smalltalk message (ObjM2)
+            (r'::', Operator),   # type conversion (ObjM2)
+        ],
+        'punctuation': [
+            (r'[\(\)\[\]{},.:;|]', Punctuation),
+        ],
+        'comments': [
+            (r'//.*?\n', Comment.Single),       # ObjM2
+            (r'/\*(.*?)\*/', Comment.Multiline), # ObjM2
+            (r'\(\*([^\$].*?)\*\)', Comment.Multiline),
+            # TO DO: nesting of (* ... *) comments
+        ],
+        'pragmas': [
+            (r'\(\*\$(.*?)\*\)', Comment.Preproc), # PIM
+            (r'<\*(.*?)\*>', Comment.Preproc),     # ISO + ObjM2
+        ],
+        'root': [
+            include('whitespace'),
+            include('comments'),
+            include('pragmas'),
+            include('identifiers'),
+            include('numliterals'),
+            include('strings'),
+            include('operators'),
+            include('punctuation'),
+        ]
+    }
+
+    pim_reserved_words = [
+        # 40 reserved words
+        'AND', 'ARRAY', 'BEGIN', 'BY', 'CASE', 'CONST', 'DEFINITION',
+        'DIV', 'DO', 'ELSE', 'ELSIF', 'END', 'EXIT', 'EXPORT', 'FOR',
+        'FROM', 'IF', 'IMPLEMENTATION', 'IMPORT', 'IN', 'LOOP', 'MOD',
+        'MODULE', 'NOT', 'OF', 'OR', 'POINTER', 'PROCEDURE', 'QUALIFIED',
+        'RECORD', 'REPEAT', 'RETURN', 'SET', 'THEN', 'TO', 'TYPE',
+        'UNTIL', 'VAR', 'WHILE', 'WITH',
+    ]
+
+    pim_pervasives = [
+        # 31 pervasives
+        'ABS', 'BITSET', 'BOOLEAN', 'CAP', 'CARDINAL', 'CHAR', 'CHR', 'DEC',
+        'DISPOSE', 'EXCL', 'FALSE', 'FLOAT', 'HALT', 'HIGH', 'INC', 'INCL',
+        'INTEGER', 'LONGINT', 'LONGREAL', 'MAX', 'MIN', 'NEW', 'NIL', 'ODD',
+        'ORD', 'PROC', 'REAL', 'SIZE', 'TRUE', 'TRUNC', 'VAL',
+    ]
+
+    iso_reserved_words = [
+        # 46 reserved words
+        'AND', 'ARRAY', 'BEGIN', 'BY', 'CASE', 'CONST', 'DEFINITION', 'DIV',
+        'DO', 'ELSE', 'ELSIF', 'END', 'EXCEPT', 'EXIT', 'EXPORT', 'FINALLY',
+        'FOR', 'FORWARD', 'FROM', 'IF', 'IMPLEMENTATION', 'IMPORT', 'IN',
+        'LOOP', 'MOD', 'MODULE', 'NOT', 'OF', 'OR', 'PACKEDSET', 'POINTER',
+        'PROCEDURE', 'QUALIFIED', 'RECORD', 'REPEAT', 'REM', 'RETRY',
+        'RETURN', 'SET', 'THEN', 'TO', 'TYPE', 'UNTIL', 'VAR', 'WHILE',
+        'WITH',
+    ]
+
+    iso_pervasives = [
+        # 42 pervasives
+        'ABS', 'BITSET', 'BOOLEAN', 'CAP', 'CARDINAL', 'CHAR', 'CHR', 'CMPLX',
+        'COMPLEX', 'DEC', 'DISPOSE', 'EXCL', 'FALSE', 'FLOAT', 'HALT', 'HIGH',
+        'IM', 'INC', 'INCL', 'INT', 'INTEGER', 'INTERRUPTIBLE', 'LENGTH',
+        'LFLOAT', 'LONGCOMPLEX', 'LONGINT', 'LONGREAL', 'MAX', 'MIN', 'NEW',
+        'NIL', 'ODD', 'ORD', 'PROC', 'PROTECTION', 'RE', 'REAL', 'SIZE',
+        'TRUE', 'TRUNC', 'UNINTERRUBTIBLE', 'VAL',
+    ]
+
+    objm2_reserved_words = [
+        # base language, 42 reserved words
+        'AND', 'ARRAY', 'BEGIN', 'BY', 'CASE', 'CONST', 'DEFINITION', 'DIV',
+        'DO', 'ELSE', 'ELSIF', 'END', 'ENUM', 'EXIT', 'FOR', 'FROM', 'IF',
+        'IMMUTABLE', 'IMPLEMENTATION', 'IMPORT', 'IN', 'IS', 'LOOP', 'MOD',
+        'MODULE', 'NOT', 'OF', 'OPAQUE', 'OR', 'POINTER', 'PROCEDURE',
+        'RECORD', 'REPEAT', 'RETURN', 'SET', 'THEN', 'TO', 'TYPE',
+        'UNTIL', 'VAR', 'VARIADIC', 'WHILE',
+        # OO extensions, 16 reserved words
+        'BYCOPY', 'BYREF', 'CLASS', 'CONTINUE', 'CRITICAL', 'INOUT', 'METHOD',
+        'ON', 'OPTIONAL', 'OUT', 'PRIVATE', 'PROTECTED', 'PROTOCOL', 'PUBLIC',
+        'SUPER', 'TRY',
+    ]
+
+    objm2_pervasives = [
+        # base language, 38 pervasives
+        'ABS', 'BITSET', 'BOOLEAN', 'CARDINAL', 'CHAR', 'CHR', 'DISPOSE',
+        'FALSE', 'HALT', 'HIGH', 'INTEGER', 'INRANGE', 'LENGTH', 'LONGCARD',
+        'LONGINT', 'LONGREAL', 'MAX', 'MIN', 'NEG', 'NEW', 'NEXTV', 'NIL',
+        'OCTET', 'ODD', 'ORD', 'PRED', 'PROC', 'READ', 'REAL', 'SUCC', 'TMAX',
+        'TMIN', 'TRUE', 'TSIZE', 'UNICHAR', 'VAL', 'WRITE', 'WRITEF',
+        # OO extensions, 3 pervasives
+        'OBJECT', 'NO', 'YES',
+    ]
+
+    gnu_reserved_words = [
+        # 10 additional reserved words
+        'ASM', '__ATTRIBUTE__', '__BUILTIN__', '__COLUMN__', '__DATE__',
+        '__FILE__', '__FUNCTION__', '__LINE__', '__MODULE__', 'VOLATILE',
+    ]
+
+    gnu_pervasives = [
+        # 21 identifiers, actually from pseudo-module SYSTEM
+        # but we will highlight them as if they were pervasives
+        'BITSET8', 'BITSET16', 'BITSET32', 'CARDINAL8', 'CARDINAL16',
+        'CARDINAL32', 'CARDINAL64', 'COMPLEX32', 'COMPLEX64', 'COMPLEX96',
+        'COMPLEX128', 'INTEGER8', 'INTEGER16', 'INTEGER32', 'INTEGER64',
+        'REAL8', 'REAL16', 'REAL32', 'REAL96', 'REAL128', 'THROW',
+    ]
+
+    def __init__(self, **options):
+        self.reserved_words = set()
+        self.pervasives = set()
+        # ISO Modula-2
+        if get_bool_opt(options, 'iso', False):
+            self.reserved_words.update(self.iso_reserved_words)
+            self.pervasives.update(self.iso_pervasives)
+        # Objective Modula-2
+        elif get_bool_opt(options, 'objm2', False):
+            self.reserved_words.update(self.objm2_reserved_words)
+            self.pervasives.update(self.objm2_pervasives)
+        # PIM Modula-2 (DEFAULT)
+        else:
+            self.reserved_words.update(self.pim_reserved_words)
+            self.pervasives.update(self.pim_pervasives)
+        # GNU extensions
+        if get_bool_opt(options, 'gm2ext', False):
+            self.reserved_words.update(self.gnu_reserved_words)
+            self.pervasives.update(self.gnu_pervasives)
+        # initialise
+        RegexLexer.__init__(self, **options)
+
+    def get_tokens_unprocessed(self, text):
+        for index, token, value in \
+            RegexLexer.get_tokens_unprocessed(self, text):
+            # check for reserved words and pervasives
+            if token is Name:
+                if value in self.reserved_words:
+                    token = Keyword.Reserved
+                elif value in self.pervasives:
+                    token = Keyword.Pervasive
+            # return result
+            yield index, token, value

tests/examplefiles/Sorting.mod

+IMPLEMENTATION MODULE Sorting;
+
+(* J. Andrea, Dec.16/91 *)
+(* This code may be freely used and distributed, it may not be sold. *)
+
+(* Adapted to ISO Module-2 by Frank Schoonjans  Feb 2004 *)
+
+FROM Storage IMPORT ALLOCATE;
+
+CONST
+   max_stack = 20;
+   n_small   = 6; (* use a simple sort for this size and smaller *)
+
+VAR
+  rtemp :REAL;
+  ctemp :CARDINAL;
+
+  L, R, n               :INTEGER;
+  top, bottom, lastflip :INTEGER;
+
+  tos            :CARDINAL;
+  Lstack, Rstack :ARRAY [1..max_stack] OF INTEGER;
+
+      (* --------------------------------------------------- *)
+      PROCEDURE CardQSortIndex( x :ARRAY OF CARDINAL; array_len :CARDINAL;
+                                VAR index :ARRAY OF CARDINAL );
+
+      VAR
+        median : CARDINAL;
+        i,j    : INTEGER;
+      BEGIN
+
+        n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
+
+        (* initialize the index *)
+        FOR i := 0 TO n DO
+          index[i] := VAL(CARDINAL,i);
+        END;
+
+        tos := 0;
+
+        L := 0;  R := n;
+
+        (* PUSH very first set *)
+        tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := R;
+
+        REPEAT
+
+          (* POP *)
+          L := Lstack[tos];  R := Rstack[tos];  tos := tos - 1;
+
+          IF R - L + 1 > n_small THEN
+
+            REPEAT
+              i := L;  j := R;    median := x[index[( L + R ) DIV 2]];
+
+              REPEAT
+                WHILE x[index[i]] < median DO
+                  i := i + 1;
+                END;
+                WHILE median < x[index[j]] DO
+                  j := j - 1;
+                END;
+
+                IF i <= j THEN (* swap *)
+                  ctemp := index[i];  index[i] := index[j];  index[j] := ctemp;
+                  i := i + 1;  j := j - 1;
+                END;
+              UNTIL i > j;
+
+              IF j - L < R - i THEN
+                IF i < R THEN (* PUSH *)
+                  tos := tos + 1;  Lstack[tos] := i;  Rstack[tos] := R;
+                END;
+                R := j;
+              ELSE
+                IF L < j THEN (* push *)
+                  tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := j;
+                END;
+                L := i;
+              END;
+
+            UNTIL L >= R;
+
+         ELSE
+
+           (* small sort for small number of values *)
+           FOR i := L TO R - 1 DO
+             FOR j := i TO R DO
+               IF x[index[i]] > x[index[j]] THEN
+                  ctemp    := index[i];
+                  index[i] := index[j];
+                  index[j] := ctemp
+               END;
+             END;
+           END;
+
+         END; (* check for small *)
+
+       UNTIL tos = 0;
+
+      END CardQSortIndex;
+
+      (* --------------------------------------------------- *)
+      PROCEDURE RealQSortIndex( x :ARRAY OF REAL; array_len :CARDINAL;
+                                VAR index :ARRAY OF CARDINAL );
+
+      VAR
+        median :REAL;
+        i,j    :INTEGER;
+      BEGIN
+
+        n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
+
+        (* initialize the index *)
+        FOR i := 0 TO n DO
+          index[i] := VAL(CARDINAL,i);
+        END;
+
+        tos := 0;
+
+        L := 0;  R := n;
+
+        (* PUSH very first set *)
+        tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := R;
+
+        REPEAT
+
+          (* POP *)
+          L := Lstack[tos];  R := Rstack[tos];  tos := tos - 1;
+
+          IF R - L + 1 > n_small THEN
+
+            REPEAT
+              i := L;  j := R;    median := x[index[( L + R ) DIV 2]];
+
+              REPEAT
+                WHILE x[index[i]] < median DO
+                  i := i + 1;
+                END;
+                WHILE median < x[index[j]] DO
+                  j := j - 1;
+                END;
+
+                IF i <= j THEN (* swap *)
+                  ctemp := index[i];  index[i] := index[j];  index[j] := ctemp;
+                  i := i + 1;  j := j - 1;
+                END;
+              UNTIL i > j;
+
+              IF j - L < R - i THEN
+                IF i < R THEN (* PUSH *)
+                  tos := tos + 1;  Lstack[tos] := i;  Rstack[tos] := R;
+                END;
+                R := j;
+              ELSE
+                IF L < j THEN (* push *)
+                  tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := j;
+                END;
+                L := i;
+              END;
+
+            UNTIL L >= R;
+
+         ELSE
+
+           (* small sort for small number of values *)
+           FOR i := L TO R - 1 DO
+             FOR j := i TO R DO
+               IF x[index[i]] > x[index[j]] THEN
+                  ctemp    := index[i];
+                  index[i] := index[j];
+                  index[j] := ctemp
+               END;
+             END;
+           END;
+
+         END; (* check for small *)
+
+       UNTIL tos = 0;
+
+      END RealQSortIndex;
+
+      (* --------------------------------------------------- *)
+      PROCEDURE CardQSort( VAR x :ARRAY OF CARDINAL; array_len :CARDINAL );
+
+      VAR
+        median : CARDINAL;
+        n,i,j  : INTEGER;
+      BEGIN
+
+        n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
+
+        tos := 0;
+
+        L := 0;  R := n;
+
+        (* PUSH very first set *)
+        tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := R;
+
+        REPEAT
+
+          (* POP *)
+          L := Lstack[tos];  R := Rstack[tos];  tos := tos - 1;
+
+          IF R - L + 1 > n_small THEN
+
+            REPEAT
+              i := L;  j := R;    median := x[( L + R ) DIV 2];
+
+              REPEAT
+                WHILE x[i] < median DO
+                  i := i + 1;
+                END;
+                WHILE median < x[j] DO
+                  j := j - 1;
+                END;
+
+                IF i <= j THEN (* swap *)
+                  ctemp := x[i];  x[i] := x[j];  x[j] := ctemp;
+                  i := i + 1;  j := j - 1;
+                END;
+              UNTIL i > j;
+
+              IF j - L < R - i THEN
+                IF i < R THEN (* PUSH *)
+                  tos := tos + 1;  Lstack[tos] := i;  Rstack[tos] := R;
+                END;
+                R := j;
+              ELSE
+                IF L < j THEN (* push *)
+                  tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := j;
+                END;
+                L := i;
+              END;
+
+            UNTIL L >= R;
+
+         ELSE
+
+           (* small sort for small number of values *)
+           FOR i := L TO R - 1 DO
+             FOR j := i TO R DO
+               IF x[i] > x[j] THEN
+                  ctemp := x[i];
+                  x[i]  := x[j];
+                  x[j]  := ctemp
+               END;
+             END;
+           END;
+
+         END; (* check for small *)
+
+       UNTIL tos = 0;
+
+      END CardQSort;
+
+      (* ----------------------------------------------------- *)
+      PROCEDURE CardBSort( VAR x :ARRAY OF CARDINAL; array_len :CARDINAL );
+      VAR i,j : INTEGER;
+      BEGIN
+        top    := 0;      (* open arrays are zero offset *)
+        bottom := VAL(INTEGER,array_len) - 1;
+
+        WHILE top < bottom DO
+
+          lastflip := top;
+
+          FOR i := top TO bottom-1 DO
+             IF x[i] > x[i+1] THEN    (* flip *)
+               ctemp  := x[i];
+               x[i]   := x[i+1];
+               x[i+1] := ctemp;
+               lastflip := i;
+             END;
+          END;
+
+          bottom := lastflip;
+
+          IF bottom > top THEN
+
+             i := bottom - 1;
+             FOR j := top TO bottom-1 DO
+               IF x[i] > x[i+1] THEN    (* flip *)
+                 ctemp  := x[i];
+                 x[i]   := x[i+1];
+                 x[i+1] := ctemp;
+                 lastflip := i;
+               END;
+               i := i - 1;
+             END;
+
+             top := lastflip + 1;
+
+          ELSE
+             (* force a loop failure *)
+             top := bottom + 1;
+          END;
+
+       END;
+
+      END CardBSort;
+
+
+      (* ----------------------------------------------------- *)
+      PROCEDURE RealBSort( VAR x :ARRAY OF REAL; array_len :CARDINAL );
+      VAR bottom,top : INTEGER;
+          i,j        : INTEGER;
+      BEGIN
+        top    := 0;      (* open arrays are zero offset *)
+        bottom := VAL(INTEGER,array_len) - 1;
+
+        WHILE top < bottom DO
+
+          lastflip := top;
+
+          FOR i := top TO bottom-1 DO
+             IF x[i] > x[i+1] THEN    (* flip *)
+               rtemp  := x[i];
+               x[i]   := x[i+1];
+               x[i+1] := rtemp;
+               lastflip := i;
+             END;
+          END;
+
+          bottom := lastflip;
+
+          IF bottom > top THEN
+
+             i := bottom - 1;
+             FOR j := top TO bottom-1 DO
+               IF x[i] > x[i+1] THEN    (* flip *)
+                 rtemp  := x[i];
+                 x[i]   := x[i+1];
+                 x[i+1] := rtemp;
+                 lastflip := i;
+               END;
+               i := i - 1;
+             END;
+
+             top := lastflip + 1;
+
+          ELSE
+             (* force a loop failure *)
+             top := bottom + 1;
+          END;
+
+       END;
+
+      END RealBSort;
+
+
+    (* ----------------------------------------------------- *)
+    PROCEDURE TopoSort( x, y :ARRAY OF CARDINAL; n_pairs :CARDINAL;
+                       VAR solution :ARRAY OF CARDINAL; VAR n_solution :CARDINAL;
+                       VAR error, sorted :BOOLEAN );
+    (*
+     This procedure needs some garbage collection added, i've tried but
+     will little success. J. Andrea, Dec.18/91
+    *)
+
+    TYPE
+      LPtr = POINTER TO Leader;
+      TPtr = POINTER TO Trailer;
+
+      Leader = RECORD
+                  key   :CARDINAL;
+                  count :INTEGER;
+                  trail :TPtr;
+                  next  :LPtr;
+               END;
+
+      Trailer = RECORD
+                  id   :LPtr;
+                  next :TPtr;
+                END;
+
+    VAR
+      p, q, head, tail :LPtr;
+      t                :TPtr;
+      i, max_solutions :CARDINAL;
+
+      (* -------------------------------------------- *)
+      PROCEDURE Find( w :CARDINAL ) :LPtr;
+      VAR h :LPtr;
+      BEGIN
+        h := head;   tail^.key := w;  (* sentinel *)
+        WHILE h^.key # w DO
+           h := h^.next;
+        END;
+        IF h = tail THEN
+          NEW( tail );
+          n := n + 1;
+          h^.count := 0;
+          h^.trail := NIL;
+          h^.next  := tail;
+        END;
+        RETURN h;
+      END Find;
+
+    BEGIN
+
+        error      := FALSE;
+        n_solution := 0;
+
+        IF n_pairs < 2 THEN
+          error := TRUE;
+        ELSE
+
+          max_solutions := HIGH( solution ) + 1;
+
+          NEW( head );  tail := head;  n := 0;
+
+          (* add all of the given pairs *)
+
+          FOR i := 0 TO n_pairs - 1 DO
+            p := Find( x[i] );   q := Find( y[i] );
+            NEW(t);
+            t^.id    := q;
+            t^.next  := p^.trail;
+            p^.trail := t;
+            q^.count := q^.count + 1;
+          END;
+
+          (* search for leaders without predecessors *)
+
+           p := head;  head := NIL;
+           WHILE p # tail DO
+            q := p;  p := q^.next;
+            IF q^.count = 0 THEN
+              (* insert q^ in new chain *)
+              q^.next := head;   head := q;
+            END;
+          END;
+
+          (* output phase *)
+
+          q := head;
+          WHILE ( NOT error ) & ( q # NIL ) DO
+            n_solution := n_solution + 1;
+            IF n_solution > max_solutions THEN
+              error := TRUE;
+            ELSE
+
+              solution[n_solution-1] := q^.key;
+              n := n - 1;
+              t := q^.trail;  q := q^.next;
+              WHILE t # NIL DO
+                p := t^.id;  p^.count := p^.count - 1;
+                IF p^.count = 0 THEN
+                  (* insert p^ in leader list *)
+                  p^.next := q;  q := p;
+                END;
+                t := t^.next;
+              END;
+            END;
+          END;
+
+          IF n # 0 THEN
+            sorted := FALSE;
+          ELSE
+            sorted := TRUE;
+          END;
+
+       END;
+
+    END TopoSort;
+
+BEGIN
+END Sorting.

tests/examplefiles/test.mod

+(* LIFO Storage Library
+ *
+ *  @file LIFO.mod
+ *  LIFO implementation
+ *
+ *  Universal Dynamic Stack
+ *
+ *  Author: Benjamin Kowarsch
+ *
+ *  Copyright (C) 2009 Benjamin Kowarsch. All rights reserved.
+ *
+ *  License:
+ *
+ *  Redistribution  and  use  in source  and  binary forms,  with  or  without
+ *  modification, are permitted provided that the following conditions are met
+ *
+ *  1) NO FEES may be charged for the provision of the software.  The software
+ *     may  NOT  be published  on websites  that contain  advertising,  unless
+ *     specific  prior  written  permission has been obtained.
+ *
+ *  2) Redistributions  of source code must retain the above copyright notice,
+ *     this list of conditions and the following disclaimer.
+ *
+ *  3) Redistributions  in binary form  must  reproduce  the  above  copyright
+ *     notice,  this list of conditions  and  the following disclaimer  in the
+ *     documentation and other materials provided with the distribution.
+ *
+ *  4) Neither the author's name nor the names of any contributors may be used
+ *     to endorse  or  promote  products  derived  from this software  without
+ *     specific prior written permission.
+ *
+ *  5) Where this list of conditions  or  the following disclaimer, in part or
+ *     as a whole is overruled  or  nullified by applicable law, no permission
+ *     is granted to use the software.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,  BUT NOT LIMITED TO,  THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY  AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED.  IN NO EVENT  SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE  FOR  ANY  DIRECT,  INDIRECT,  INCIDENTAL,  SPECIAL,  EXEMPLARY,  OR
+ * CONSEQUENTIAL  DAMAGES  (INCLUDING,  BUT  NOT  LIMITED  TO,  PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES;  LOSS OF USE,  DATA,  OR PROFITS; OR BUSINESS
+ * INTERRUPTION)  HOWEVER  CAUSED  AND ON ANY THEORY OF LIABILITY,  WHETHER IN
+ * CONTRACT,  STRICT LIABILITY,  OR TORT  (INCLUDING NEGLIGENCE  OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,  EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *  
+ *)
+
+
+IMPLEMENTATION (* OF *) MODULE LIFO;
+
+FROM SYSTEM IMPORT ADDRESS, ADR, TSIZE;
+FROM Storage IMPORT ALLOCATE, DEALLOCATE;
+
+
+(* ---------------------------------------------------------------------------
+// Private type : ListEntry
+// ---------------------------------------------------------------------------
+*)
+TYPE ListPtr = POINTER TO ListEntry;
+
+TYPE ListEntry = RECORD
+    value : DataPtr;
+    next  : ListPtr
+END; (* ListEntry *)
+
+
+(* ---------------------------------------------------------------------------
+// Opaque type : LIFO.Stack
+// ---------------------------------------------------------------------------
+// CAUTION:  Modula-2 does not support the use of variable length array fields
+// in records.  VLAs can  only  be implemented  using pointer arithmetic which
+// means  there is  no type checking  and  no boundary checking  on the array.
+// It also means that  array notation cannot be used on the array  which makes
+// the code  difficult to read  and maintain.  As a result,  Modula-2  is less
+// safe and less readable than C when it comes to using VLAs.  Great care must
+// be taken to make sure that the code accessing VLA fields is safe.  Boundary
+// checks must be inserted manually.  Size checks must be inserted manually to
+// compensate for the absence of type checks. *)
+
+TYPE Stack = POINTER TO StackDescriptor;
+
+TYPE StackDescriptor = RECORD
+    overflow   : ListPtr;
+    entryCount : StackSize;
+    arraySize  : StackSize;
+    array      : ADDRESS (* ARRAY OF DataPtr *)
+END; (* StackDescriptor *)
+
+
+(* ---------------------------------------------------------------------------
+// function:  LIFO.new( initial_size, status )
+// ---------------------------------------------------------------------------
+//
+// Creates  and  returns  a new LIFO stack object  with an initial capacity of
+// <initialSize>.  If  zero  is passed in  for <initialSize>,  then  the stack
+// will be created  with an  initial capacity  of  LIFO.defaultStackSize.  The
+// function fails  if a value greater than   LIFO.maximumStackSize  is  passed
+// in  for <initialSize> or if memory could not be allocated.
+//
+// The initial capacity of a stack is the number of entries that can be stored
+// in the stack without enlargement.
+//
+// The status of the operation  is passed back in <status>. *)
+
+PROCEDURE new ( initialSize : StackSize; VAR status : Status ) : Stack;
+
+VAR
+    newStack : Stack;
+    
+BEGIN
+
+    (* zero size means default *)
+    IF initialSize = 0 THEN
+        initialSize := defaultStackSize;
+    END; (* IF *)
+    
+    (* bail out if initial size is too high *)
+    IF initialSize > maximumStackSize THEN
+        status := invalidSize;
+        RETURN NIL;
+    END; (* IF *)
+    
+    (* allocate new stack object *)
+    ALLOCATE(newStack, TSIZE(Stack) + TSIZE(DataPtr) * (initialSize - 1));
+    
+    (* bail out if allocation failed *)
+    IF newStack = NIL THEN
+        status := allocationFailed;
+        RETURN NIL;
+    END; (* IF *)
+        
+    (* initialise meta data *)
+    newStack^.arraySize := initialSize;
+    newStack^.entryCount := 0;
+    newStack^.overflow := NIL;
+    
+    (* pass status and new stack to caller *)
+    status := success;
+    RETURN newStack
+    
+END new;
+
+
+(* ---------------------------------------------------------------------------
+// function:  LIFO.push( stack, value, status )
+// ---------------------------------------------------------------------------
+//
+// Adds a  new entry <value>  to the top of stack <stack>.  The  new entry  is
+// added by reference,  no data is copied.  However,  no entry is added if the
+// the stack is full,  that is  when the number of entries stored in the stack
+// has reached LIFO.maximumStackSize.  The function fails  if NIL is passed in
+// for <stack> or <value>,  or if memory could not be allocated.
+//
+// New entries are allocated dynamically  if the number of entries exceeds the
+// initial capacity of the stack.
+//
+// The status of the operation is passed back in <status>. *)
+
+PROCEDURE push ( VAR stack : Stack; value : DataPtr; VAR status : Status );
+VAR
+    newEntry : ListPtr;
+    valuePtr : POINTER TO DataPtr;
+
+BEGIN
+
+    (* bail out if stack is NIL *)
+    IF stack = NIL THEN
+        status := invalidStack;
+        RETURN;
+    END; (* IF *)
+    
+    (* bail out if value is NIL *)
+    IF value = NIL THEN
+        status := invalidData;
+        RETURN;
+    END; (* IF *)
+
+    (* bail out if stack is full *)
+    IF stack^.entryCount >= maximumStackSize THEN
+        status := stackFull;
+        RETURN;
+    END; (* IF *)
+
+    (* check if index falls within array segment *)
+    IF stack^.entryCount < stack^.arraySize THEN
+    
+        (* store value in array segment *)
+        
+        (* stack^.array^[stack^.entryCount] := value; *)
+        valuePtr := ADR(stack^.array) + TSIZE(DataPtr) * stack^.entryCount;
+        valuePtr^ := value;
+        
+    ELSE (* index falls within overflow segment *)
+    
+        (* allocate new entry slot *)
+        NEW(newEntry);
+        
+        (* bail out if allocation failed *)
+        IF newEntry = NIL THEN
+            status := allocationFailed;
+            RETURN;
+        END; (* IF *)
+        
+        (* initialise new entry *)
+        newEntry^.value := value;
+        
+        (* link new entry into overflow list *)
+        newEntry^.next := stack^.overflow;
+        stack^.overflow := newEntry;
+    
+    END; (* IF *)
+    
+    (* update entry counter *)
+    INC(stack^.entryCount);
+    
+    (* pass status to caller *)
+    status := success;
+    RETURN
+
+END push;
+
+
+(* ---------------------------------------------------------------------------
+// function:  LIFO.pop( stack, status )
+// ---------------------------------------------------------------------------
+//
+// Removes the top most value from stack <stack> and returns it.  If the stack
+// is empty,  that  is  when the  number  of  entries  stored in the stack has
+// reached zero,  then NIL is returned.
+//
+// Entries which were allocated dynamically (above the initial capacity) are
+// deallocated when their values are popped.
+//
+// The status of the operation is passed back in <status>. *)
+
+PROCEDURE pop ( VAR stack : Stack; VAR status : Status ) : DataPtr;
+
+VAR
+    thisValue : DataPtr;
+    thisEntry : ListPtr;
+    valuePtr : POINTER TO DataPtr;
+
+BEGIN
+
+    (* bail out if stack is NIL *)
+    IF stack = NIL THEN
+        status := invalidStack;
+        RETURN NIL;
+    END; (* IF *)
+    
+    (* bail out if stack is empty *)
+    IF stack^.entryCount = 0 THEN
+        status := stackEmpty;
+        RETURN NIL;
+    END; (* IF *)
+
+    DEC(stack^.entryCount);
+    
+    (* check if index falls within array segment *)
+    IF stack^.entryCount < stack^.arraySize THEN
+        
+        (* obtain value at index entryCount in array segment *)
+        
+        (* thisValue := stack^.array^[stack^.entryCount]; *)
+        valuePtr := ADR(stack^.array) + TSIZE(DataPtr) * stack^.entryCount;
+        thisValue := valuePtr^;
+        
+    ELSE (* index falls within overflow segment *)
+        
+        (* obtain value of first entry in overflow list *)
+        thisValue := stack^.overflow^.value;
+        
+        (* isolate first entry in overflow list *)
+        thisEntry := stack^.overflow;
+        stack^.overflow := stack^.overflow^.next;
+        
+        (* remove the entry from overflow list *)
+        DISPOSE(thisEntry);
+                
+    END; (* IF *)
+
+    (* return value and status to caller *)
+    status := success;
+    RETURN thisValue
+
+END pop;
+
+
+(* ---------------------------------------------------------------------------
+// function:  LIFO.stackSize( stack )
+// ---------------------------------------------------------------------------
+//
+// Returns the current capacity of <stack>.  The current capacity is the total
+// number of allocated entries. Returns zero if NIL is passed in for <stack>.
+*)
+PROCEDURE stackSize( VAR stack : Stack ) : StackSize;
+
+BEGIN
+
+    (* bail out if stack is NIL *)
+    IF stack = NIL THEN
+        RETURN 0;
+    END; (* IF *)
+
+    IF stack^.entryCount < stack^.arraySize THEN
+        RETURN stack^.arraySize;
+    ELSE
+        RETURN stack^.entryCount;
+    END; (* IF *)
+    
+END stackSize;
+
+
+(* ---------------------------------------------------------------------------
+// function:  LIFO.stackEntries( stack )
+// ---------------------------------------------------------------------------
+//
+// Returns  the  number of entries  stored in stack <stack>,  returns  zero if
+// NIL is passed in for <stack>. *)
+
+PROCEDURE stackEntries( VAR stack : Stack ) : StackSize;
+
+BEGIN
+
+    (* bail out if stack is NIL *)
+    IF stack = NIL THEN
+        RETURN 0;
+    END; (* IF *)
+
+    RETURN stack^.entryCount
+    
+END stackEntries;
+
+
+(* ---------------------------------------------------------------------------
+// function:  LIFO.dispose( stack )
+// ---------------------------------------------------------------------------
+//
+// Disposes of LIFO stack object <stack>.  Returns NIL. *)
+
+PROCEDURE dispose ( VAR stack : Stack ) : Stack;
+
+VAR
+    thisEntry : ListPtr;
+
+BEGIN
+
+    (* bail out if stack is NIL *)
+    IF stack = NIL THEN
+        RETURN NIL;
+    END; (* IF *)
+    
+    (* deallocate any entries in stack's overflow list *)
+    WHILE stack^.overflow # NIL DO
+        
+        (* isolate first entry in overflow list *)
+        thisEntry := stack^.overflow;
+        stack^.overflow := stack^.overflow^.next;
+        
+        (* deallocate the entry *)
+        DISPOSE(thisEntry);
+        
+    END; (* WHILE *)
+    
+    (* deallocate stack object and pass NIL to caller *)
+    DEALLOCATE(stack, TSIZE(Stack) + TSIZE(DataPtr) * (stack^.arraySize - 1));
+    RETURN NIL
+
+END dispose;
+
+
+END LIFO.
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.