diff options
| -rw-r--r-- | AUTHORS | 1 | ||||
| -rw-r--r-- | CHANGES | 1 | ||||
| -rw-r--r-- | pygments/lexers/_mapping.py | 1 | ||||
| -rw-r--r-- | pygments/lexers/compiled.py | 198 | ||||
| -rw-r--r-- | tests/examplefiles/Sorting.mod | 470 | ||||
| -rw-r--r-- | tests/examplefiles/test.mod | 374 |
6 files changed, 1044 insertions, 1 deletions
@@ -34,6 +34,7 @@ Other contributors, listed alphabetically, are: * 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 @@ -14,6 +14,7 @@ Version 1.3 * Ada * Coldfusion + * Modula-2 * haXe * R console * Objective-J diff --git a/pygments/lexers/_mapping.py b/pygments/lexers/_mapping.py index f90251d0..cdaf56a1 100644 --- a/pygments/lexers/_mapping.py +++ b/pygments/lexers/_mapping.py @@ -121,6 +121,7 @@ LEXERS = { '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',), ()), diff --git a/pygments/lexers/compiled.py b/pygments/lexers/compiled.py index a6069611..cf2bc737 100644 --- a/pygments/lexers/compiled.py +++ b/pygments/lexers/compiled.py @@ -25,7 +25,8 @@ from pygments.lexers.functional import OcamlLexer __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): @@ -2169,3 +2170,198 @@ class AdaLexer(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 diff --git a/tests/examplefiles/Sorting.mod b/tests/examplefiles/Sorting.mod new file mode 100644 index 00000000..d6a27c1f --- /dev/null +++ b/tests/examplefiles/Sorting.mod @@ -0,0 +1,470 @@ +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. diff --git a/tests/examplefiles/test.mod b/tests/examplefiles/test.mod new file mode 100644 index 00000000..ba972e30 --- /dev/null +++ b/tests/examplefiles/test.mod @@ -0,0 +1,374 @@ +(* 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. |