From fee10c4735038988e0a58edfd0c4ca61c8b3a069 Mon Sep 17 00:00:00 2001 From: ceriel Date: Wed, 20 Apr 1988 10:43:48 +0000 Subject: [PATCH] Initial revision --- lang/m2/test/.distr | 5 + lang/m2/test/Thalmann/.distr | 5 + lang/m2/test/Thalmann/LifeGame.mod | 151 +++ lang/m2/test/Thalmann/Shoes.mod | 54 ++ lang/m2/test/Thalmann/StoreFetch.mod | 91 ++ lang/m2/test/Thalmann/bold.mod | 133 +++ lang/m2/test/Thalmann/characters.mod | 29 + lang/m2/test/Wirth/.distr | 5 + lang/m2/test/Wirth/PowersOf2.mod | 57 ++ lang/m2/test/Wirth/TableHandl.mod | 183 ++++ lang/m2/test/Wirth/XREF.mod | 153 +++ lang/m2/test/Wirth/makefile | 26 + lang/m2/test/getenv.mod | 29 + lang/m2/test/m2p.mod | 1305 ++++++++++++++++++++++++++ lang/m2/test/queens.mod | 55 ++ 15 files changed, 2281 insertions(+) create mode 100644 lang/m2/test/.distr create mode 100644 lang/m2/test/Thalmann/.distr create mode 100644 lang/m2/test/Thalmann/LifeGame.mod create mode 100644 lang/m2/test/Thalmann/Shoes.mod create mode 100644 lang/m2/test/Thalmann/StoreFetch.mod create mode 100644 lang/m2/test/Thalmann/bold.mod create mode 100644 lang/m2/test/Thalmann/characters.mod create mode 100644 lang/m2/test/Wirth/.distr create mode 100644 lang/m2/test/Wirth/PowersOf2.mod create mode 100644 lang/m2/test/Wirth/TableHandl.mod create mode 100644 lang/m2/test/Wirth/XREF.mod create mode 100644 lang/m2/test/Wirth/makefile create mode 100644 lang/m2/test/getenv.mod create mode 100644 lang/m2/test/m2p.mod create mode 100644 lang/m2/test/queens.mod diff --git a/lang/m2/test/.distr b/lang/m2/test/.distr new file mode 100644 index 000000000..35e4dd24b --- /dev/null +++ b/lang/m2/test/.distr @@ -0,0 +1,5 @@ +Thalmann +Wirth +getenv.mod +m2p.mod +queens.mod diff --git a/lang/m2/test/Thalmann/.distr b/lang/m2/test/Thalmann/.distr new file mode 100644 index 000000000..f76368222 --- /dev/null +++ b/lang/m2/test/Thalmann/.distr @@ -0,0 +1,5 @@ +LifeGame.mod +Shoes.mod +StoreFetch.mod +bold.mod +characters.mod diff --git a/lang/m2/test/Thalmann/LifeGame.mod b/lang/m2/test/Thalmann/LifeGame.mod new file mode 100644 index 000000000..f0216cebc --- /dev/null +++ b/lang/m2/test/Thalmann/LifeGame.mod @@ -0,0 +1,151 @@ +MODULE LifeGame; + +(* From: MODULA-2, An Introduction, by Daniel Thalmann, Springer-Verlag, + New York, 1985 + Figure 10.18 +*) + +(* John Horton Conway's game "life" *) + + FROM InOut IMPORT Write, WriteString, WriteLn, WriteCard, + ReadCard, Done; + + CONST + MaxInd = 20; + MaxInd1 = MaxInd+1; + + TYPE + IndRange = [1..MaxInd]; + IndRange1 = [0..MaxInd1]; + State = [0..1]; + Cells = ARRAY IndRange1, IndRange1 OF State; + IndStat = [0..17]; + + VAR + Generation, NbOfGen: CARDINAL; + PreviousNext: BOOLEAN; + CellsState: ARRAY BOOLEAN OF Cells; + Status: ARRAY IndStat OF State; + + PROCEDURE InitGame; + + PROCEDURE InitAndReadPos; + VAR + Line, Column: CARDINAL; + + BEGIN + FOR Line := 0 TO MaxInd1 DO + FOR Column := 0 TO MaxInd1 DO + CellsState[FALSE][Line, Column] := 0; + END; + END; + CellsState[TRUE] := CellsState[FALSE]; + + (* Read positions *) + ReadCard(Line); + WHILE Done DO + ReadCard(Column); + CellsState[FALSE][Line, Column] := 1; + ReadCard(Line); + END; + + PreviousNext := FALSE; + Generation := 0; + END InitAndReadPos; + + PROCEDURE InitStatus; + (* Ezra Gottheil method *) + VAR + Ind: IndStat; + BEGIN + FOR Ind := 0 TO 17 DO + Status[Ind] := 0; + END; + Status[3] := 1; + Status[11] := 1; + Status[12] := 1; + END InitStatus; + + BEGIN (* InitGame *) + WriteString("Please, enter the number of generations: "); + ReadCard(NbOfGen); + WriteLn; + WriteString(" line and column positions: "); + InitAndReadPos; + InitStatus; + END InitGame; + + PROCEDURE NextGeneration; + VAR + Line, Column: IndRange; + nbN: CARDINAL; + + PROCEDURE Neighbourhood(L, C: IndRange1; VAR nbn: CARDINAL); + VAR + Line1, Column1: IndRange1; + BEGIN + nbn := 0; + FOR Line1 := L - 1 TO L + 1 DO + FOR Column1 := C - 1 TO C + 1 DO + INC(nbn, CellsState[PreviousNext][Line1, Column1]); + END; + END; + DEC(nbn, CellsState[PreviousNext][L, C]); + END Neighbourhood; + + BEGIN (* NextGeneration *) + FOR Line := 1 TO MaxInd DO + FOR Column := 1 TO MaxInd DO + Neighbourhood(Line, Column, nbN); + CellsState[NOT PreviousNext][Line, Column] := + Status[CellsState[PreviousNext][Line, Column]*9 + nbN]; + END; + END; + PreviousNext := NOT PreviousNext; + END NextGeneration; + + PROCEDURE Impression; + VAR + N: CARDINAL; + Line, Column: IndRange; + BEGIN + WriteLn ; + WriteString(" GENERATION : "); + WriteCard(Generation, 3); + WriteLn; + WriteLn; + WriteString(" "); + FOR N := 1 TO 2 * MaxInd + 3 DO + Write("-"); + END; + WriteLn; + FOR Line := 1 TO MaxInd DO + WriteString(" |"); + FOR Column := 1 TO MaxInd DO + IF CellsState[PreviousNext][Line, Column] = 1 THEN + WriteString(" @"); + ELSE + WriteString(" ."); + END; + END; + WriteString(" |"); + WriteLn; + END; + WriteString(" "); + FOR N := 1 TO 2*MaxInd + 3 DO + Write("-"); + END; + WriteLn; + WriteLn; + END Impression; + +BEGIN + InitGame; + Impression; + LOOP + INC(Generation); + NextGeneration; + Impression; + IF Generation = NbOfGen THEN EXIT; END; + END; +END LifeGame. diff --git a/lang/m2/test/Thalmann/Shoes.mod b/lang/m2/test/Thalmann/Shoes.mod new file mode 100644 index 000000000..bf759c586 --- /dev/null +++ b/lang/m2/test/Thalmann/Shoes.mod @@ -0,0 +1,54 @@ +MODULE Shoes; + +(* From: MODULA-2, An Introduction, by Daniel Thalmann, Springer-Verlag, + New York, 1985 + Figure 21.3 +*) + + FROM SYSTEM IMPORT WORD, ADR, ADDRESS, NEWPROCESS, TRANSFER; + FROM InOut IMPORT Write, WriteLn; + + CONST + WorkLength = 200; + MaxShoes = 50; + MaxDif = 6; + + TYPE + WorkSpace = ARRAY [0..WorkLength-1] OF WORD; + + VAR + NbLeft, NbRight : INTEGER; + WSLeft, WSRight : WorkSpace; + Left, Right, Main : ADDRESS; + + PROCEDURE Leftp; + BEGIN + WHILE NbLeft < MaxShoes DO + INC(NbLeft); + Write("L"); + IF (NbLeft-NbRight>=MaxDif) OR (NbLeft>=MaxShoes) THEN + TRANSFER(Left,Right); + END; + END; + WriteLn; + END Leftp; + + PROCEDURE Rightp; + BEGIN + WHILE NbRight < MaxShoes DO + INC(NbRight); + Write("R"); + IF (NbRight-NbLeft>=MaxDif) OR (NbRight>=MaxShoes) THEN + TRANSFER(Right,Left); + END; + END; + WriteLn; + END Rightp; + +BEGIN + NbLeft := 0; + NbRight := 0; + NEWPROCESS(Leftp,ADR(WSLeft),SIZE(WSLeft),Left); + NEWPROCESS(Rightp,ADR(WSRight),SIZE(WSRight),Right); + TRANSFER(Main,Left); +END Shoes. diff --git a/lang/m2/test/Thalmann/StoreFetch.mod b/lang/m2/test/Thalmann/StoreFetch.mod new file mode 100644 index 000000000..c3863eb2b --- /dev/null +++ b/lang/m2/test/Thalmann/StoreFetch.mod @@ -0,0 +1,91 @@ +MODULE StoreFetch; + +(* From: MODULA-2, An Introduction, by Daniel Thalmann, Springer-Verlag, + New York, 1985 + Figure 20.3 +*) + + FROM InOut IMPORT ReadString, WriteString, WriteLn; + FROM Processes IMPORT SIGNAL, StartProcess, SEND, WAIT, Awaited, Init; + + MODULE SharedBuffer; + + IMPORT SIGNAL, SEND, WAIT, Awaited, Init; + + EXPORT Deposit, Remove; + + CONST N = 16; + + VAR n, in, out: CARDINAL; + NonFull, NonEmpty: SIGNAL; + Buffer: ARRAY [0..N-1] OF INTEGER; + + PROCEDURE Deposit(integer: INTEGER); + BEGIN + IF n=N THEN WAIT(NonFull) END; + INC(n); + Buffer[in] := integer; + in := (in+1) MOD N; + IF Awaited(NonEmpty) THEN SEND(NonEmpty) END; + END Deposit; + + PROCEDURE Remove(VAR integer: INTEGER); + BEGIN + IF n=0 THEN WAIT(NonEmpty) END; + DEC(n); + integer := Buffer[out]; + out := (out+1) MOD N; + IF Awaited(NonFull) THEN SEND(NonFull) END; + END Remove; + + BEGIN + n := 0; + in := 0; + out := 0; + Init(NonFull); + Init(NonEmpty); + END SharedBuffer; + + CONST Max = 80; + eos = 0C; + + TYPE StringType = ARRAY[0..Max-1] OF CHAR; + + VAR EndOfTransfer: SIGNAL; + + PROCEDURE Store; + VAR i: INTEGER; + String: StringType; + BEGIN + WriteString("Enter a string: "); + i := -1; + ReadString(String); + REPEAT + INC(i); + Deposit(ORD(String[i])); + UNTIL String[i] = eos; + WAIT(EndOfTransfer); + END Store; + + PROCEDURE Fetch; + VAR i, OrdOfChar: INTEGER; + String: StringType; + BEGIN + i := -1; + REPEAT + INC(i); + Remove(OrdOfChar); + String[i] := CHR(OrdOfChar); + UNTIL String[i] = eos; + WriteLn; + WriteString("After transfer: "); + WriteString(String); + WriteLn; + END Fetch; + +BEGIN + Init(EndOfTransfer); + StartProcess(Store, 500); + StartProcess(Fetch, 500); + WAIT(EndOfTransfer); +END StoreFetch. diff --git a/lang/m2/test/Thalmann/bold.mod b/lang/m2/test/Thalmann/bold.mod new file mode 100644 index 000000000..d375e2e6d --- /dev/null +++ b/lang/m2/test/Thalmann/bold.mod @@ -0,0 +1,133 @@ +MODULE BoldFormatter; + +(* From: MODULA-2, An Introduction, by Daniel Thalmann, Springer-Verlag, + New York, 1985 + Figure 18.2 +*) + + FROM InOut IMPORT Done, EOL, Read, Write, OpenInput, OpenOutput, CloseInput, CloseOutput; + + CONST + N = 40; + WordLength = 32; + + TYPE + alpha = ARRAY [0..14] OF CHAR; + + VAR + ch : CHAR; + i, j, k, l, m, r : CARDINAL; + id : ARRAY [0..WordLength] OF CHAR; + key : ARRAY [1..N] OF alpha; + + PROCEDURE copy; + BEGIN + Write(ch); Read(ch); + END copy; + + PROCEDURE InitTable; + BEGIN + key[ 1] := "AND "; + key[ 2] := "ARRAY "; + key[ 3] := "BEGIN "; + key[ 4] := "BY "; + key[ 5] := "CASE "; + key[ 6] := "CONST "; + key[ 7] := "DEFINITION "; + key[ 8] := "DIV "; + key[ 9] := "DO "; + key[10] := "ELSE "; + key[11] := "ELSIF "; + key[12] := "END "; + key[13] := "EXIT "; + key[14] := "EXPORT "; + key[15] := "FOR "; + key[16] := "FROM "; + key[17] := "IF "; + key[18] := "IMPLEMENTATION "; + key[19] := "IMPORT "; + key[20] := "IN "; + key[21] := "LOOP "; + key[22] := "MOD "; + key[23] := "MODULE "; + key[24] := "NOT "; + key[25] := "OF "; + key[26] := "OR "; + key[27] := "POINTER "; + key[28] := "PROCEDURE "; + key[29] := "QUALIFIED "; + key[30] := "RECORD "; + key[31] := "REPEAT "; + key[32] := "RETURN "; + key[33] := "SET "; + key[34] := "THEN "; + key[35] := "TO "; + key[36] := "TYPE "; + key[37] := "UNTIL "; + key[38] := "VAR "; + key[39] := "WHILE "; + key[40] := "WITH "; + END InitTable; + + PROCEDURE Identifier() : BOOLEAN; + + BEGIN + l := 1; r := N; id[k] := " "; + REPEAT + m := (l + r) DIV 2; + i := 0; + WHILE (id[i]=key[m,i]) AND (id[i]#" ") DO i := i+1; END; + + IF id[i] <= key[m,i] THEN r := m-1; END; + IF id[i] >= key[m,i] THEN l := m+1; END; + UNTIL l > r; + RETURN l = r+1; + END Identifier; + +BEGIN + InitTable; + OpenInput("mod"); + OpenOutput("text"); + IF NOT Done THEN HALT; END; + Read(ch); + REPEAT + IF (CAP(ch) >= "A") AND (CAP(ch) <= "Z") THEN + k := 0; + REPEAT + id[k] := ch; k := k+1; + Read(ch); + UNTIL (ch<"0") OR (ch>"9") AND (CAP(ch)<"A") OR (CAP(ch)>"Z"); + IF Identifier() THEN + FOR i:= 0 TO k-1 DO + Write(id[i]); + END; + ELSE + FOR i := 0 TO k-1 DO + Write(id[i]); Write(10C); Write(id[i]); Write(10C); Write(id[i]); + END; + END + ELSIF (ch >= "0") AND (ch <= "9") THEN + REPEAT copy; + UNTIL ((ch<"0") OR (ch>"9")) AND ((ch < "A") OR (ch > "Z")) + ELSIF ch="(" THEN + copy; + IF ch = "*" THEN + REPEAT + REPEAT + copy; + UNTIL ch = "*"; + copy; + UNTIL ch = ")"; + END + ELSIF ch = "'" THEN + REPEAT copy; UNTIL ch = "'"; + copy; + ELSIF ch='"' THEN + REPEAT copy; UNTIL ch = '"'; + copy + ELSE copy; + END; + UNTIL NOT Done; + CloseInput; + CloseOutput; +END BoldFormatter. diff --git a/lang/m2/test/Thalmann/characters.mod b/lang/m2/test/Thalmann/characters.mod new file mode 100644 index 000000000..bd3347005 --- /dev/null +++ b/lang/m2/test/Thalmann/characters.mod @@ -0,0 +1,29 @@ +MODULE Characters; + +(* From: MODULA-2, An Introduction, by Daniel Thalmann, Springer-Verlag, + New York, 1985 + Figure 8.8 + Changed a little, to have an ELSE part in the CASE statement +*) + + FROM InOut IMPORT WriteLn, WriteString, Write; + + CONST + StrByLine = 4; + + VAR + c : CHAR; + + BEGIN + FOR c := 0C TO 177C DO + IF ORD(c) MOD StrByLine = 0 THEN WriteLn; END; + CASE c OF + 0C..37C, 177C : WriteString("Control character ") | + "0".."9": WriteString("Digit ") | + "a".."z": WriteString("Lower case letter ") | + "A"..'Z': WriteString("Upper case LETTER ") + ELSE WriteString("Special character ") + END; + END; + END Characters. + diff --git a/lang/m2/test/Wirth/.distr b/lang/m2/test/Wirth/.distr new file mode 100644 index 000000000..eb6417b09 --- /dev/null +++ b/lang/m2/test/Wirth/.distr @@ -0,0 +1,5 @@ +PowersOf2.mod +TableHandl.def +TableHandl.mod +XREF.mod +makefile diff --git a/lang/m2/test/Wirth/PowersOf2.mod b/lang/m2/test/Wirth/PowersOf2.mod new file mode 100644 index 000000000..962dd97f2 --- /dev/null +++ b/lang/m2/test/Wirth/PowersOf2.mod @@ -0,0 +1,57 @@ +MODULE PowersOf2; + FROM InOut IMPORT Write, WriteLn, WriteString, WriteCard; + + CONST + M = 11; (* M ~ N*log(2) *) + N = 32; + VAR + i,j,k,exp: CARDINAL; + c,r,t: CARDINAL; + d: ARRAY [0..M] OF CARDINAL; + f: ARRAY[0..N] OF CARDINAL; + BEGIN + d[0] := 1; + k := 1; + FOR exp := 1 TO N DO + (* compute d = 2 ^ exp by d = 2*d *) + c := 0; (* carry *) + FOR i := 0 TO k-1 DO + t := 2 * d[i] + c; + IF t >= 10 THEN + d[i] := t - 10; + c := 1; + ELSE + d[i] := t; + c := 0; + END + END; + IF c > 0 THEN + d[k] := 1; + k := k + 1 + END; + (* output d[k-1] .. d[0] *) + i := M; + REPEAT + i := i - 1; + Write(" ") + UNTIL i = k; + REPEAT + i := i - 1; + Write(CHR(d[i]+ORD("0"))) + UNTIL i = 0; + WriteCard(exp, 4); + (* compute and output f = 2^(-exp) by f := f DIV 2 *) + WriteString(" 0."); + r := 0; (* remainder *) + FOR j := 1 TO exp-1 DO + r := 10 * r + f[j]; + f[j] := r DIV 2; + r := r MOD 2; + Write(CHR(f[j]+ORD("0"))) + END; + f[exp] := 5; + Write("5"); + WriteLn + END + END PowersOf2. + diff --git a/lang/m2/test/Wirth/TableHandl.mod b/lang/m2/test/Wirth/TableHandl.mod new file mode 100644 index 000000000..ff39f2343 --- /dev/null +++ b/lang/m2/test/Wirth/TableHandl.mod @@ -0,0 +1,183 @@ +IMPLEMENTATION MODULE TableHandler; + + FROM InOut IMPORT Write, WriteLn, WriteInt; + FROM Storage IMPORT Allocate; + + CONST TableLength = 3000; + + TYPE + TreePtr = POINTER TO Word; + ListPtr = POINTER TO Item; + Item = RECORD + num: INTEGER; + next: ListPtr + END; + Word = RECORD + key: CARDINAL; (* table index *) + first: ListPtr; (* list head *) + left, right: TreePtr + END; + Table = TreePtr; + + VAR + id: ARRAY [0..WordLength] OF CHAR; + ascinx: CARDINAL; + asc: ARRAY [0..TableLength-1] OF CHAR; + + PROCEDURE InitTable(VAR t: Table); + BEGIN + Allocate(t, SIZE(Word)); + t^.right := NIL + END InitTable; + + PROCEDURE Search(p: TreePtr): TreePtr; + (* search node with name equal to id + *) + TYPE Relation = (less, equal, greater); + VAR q: TreePtr; + r: Relation; + i: CARDINAL; + + PROCEDURE rel(k: CARDINAL): Relation; + (* compare id with asc[k] + *) + VAR i: CARDINAL; + R: Relation; + x,y: CHAR; + BEGIN + i := 0; + R := equal; + LOOP + x := id[i]; + y := asc[k]; + IF CAP(x) # CAP(y) THEN EXIT END; + IF x <= " " THEN RETURN R END; + IF x < y THEN R := less ELSIF x > y THEN R := greater END; + i := i+1; + k := k+1; + END; + IF CAP(x) > CAP(y) THEN RETURN greater ELSE RETURN less END + END rel; + + BEGIN (* Search *) + q := p^.right; + r := greater; + WHILE q # NIL DO + p := q; + r := rel(p^.key); + IF r = equal THEN RETURN p + ELSIF r = less THEN q := p^.left + ELSE q := p^.right + END + END; + Allocate(q, SIZE(Word)); (* not found, hence insert *) + IF q # NIL THEN + WITH q^ DO + key := ascinx; + first := NIL; + left := NIL; + right := NIL + END; + IF r = less THEN p^.left := q ELSE p^.right := q END; + i := 0; (* copy identifier into asc table *) + WHILE id[i] > " " DO + IF ascinx = TableLength THEN + asc[ascinx] := " "; + id[i] := " "; + overflow := 1 + ELSE + asc[ascinx] := id[i]; + ascinx := ascinx + 1; + i := i + 1 + END + END; + asc[ascinx] := " "; + ascinx := ascinx + 1; + END; + RETURN q; + END Search; + + PROCEDURE Record(t: Table; VAR x: ARRAY OF CHAR; n: INTEGER); + VAR p: TreePtr; + q: ListPtr; + i: CARDINAL; + BEGIN + i := 0; + REPEAT + id[i] := x[i]; + i := i + 1 + UNTIL (id[i-1] = " ") OR (i = WordLength); + p := Search(t); + IF p = NIL THEN + overflow := 2 + ELSE + Allocate(q, SIZE(Item)); + IF q = NIL THEN + overflow := 3; + ELSE + q^.num := n; + q^.next := p^.first; + p^.first := q + END + END + END Record; + + PROCEDURE Tabulate(t: Table); + + PROCEDURE PrintItem(p: TreePtr); + CONST L = 6; + N = (LineWidth - WordLength) DIV L; + VAR ch: CHAR; + i, k: CARDINAL; + q: ListPtr; + BEGIN + i := WordLength + 1; + k := p^.key; + REPEAT + ch := asc[k]; + i := i - 1; + k := k + 1; + Write(ch) + UNTIL ch <= " "; + WHILE i > 0 DO + Write(" "); + i := i-1 + END; + q := p^.first; + i := N; + WHILE q # NIL DO + IF i = 0 THEN + WriteLn; + i := WordLength+1; + REPEAT + Write(" "); + i := i-1 + UNTIL i = 0; + i := N + END; + WriteInt(q^.num, L); + q := q^.next; + i := i - 1 + END; + WriteLn + END PrintItem; + + PROCEDURE TraverseTree(p: TreePtr); + BEGIN + IF p # NIL THEN + TraverseTree(p^.left); + PrintItem(p); + TraverseTree(p^.right) + END + END TraverseTree; + + BEGIN (* Tabulate *) + WriteLn; + TraverseTree(t^.right) + END Tabulate; + +BEGIN + ascinx := 0; + id[WordLength] := " "; + overflow := 0 +END TableHandler. diff --git a/lang/m2/test/Wirth/XREF.mod b/lang/m2/test/Wirth/XREF.mod new file mode 100644 index 000000000..557741636 --- /dev/null +++ b/lang/m2/test/Wirth/XREF.mod @@ -0,0 +1,153 @@ +MODULE XREF; + FROM InOut IMPORT Done, EOL, OpenInput, OpenOutput, Read, Write, + WriteCard, WriteString, CloseInput, CloseOutput; + + FROM TableHandler IMPORT + WordLength, Table, overflow, InitTable, Record, + Tabulate; + + TYPE Alfa = ARRAY [0..9] OF CHAR; + + CONST N = 45; (* number of keywords *) + + VAR ch: CHAR; + i,k,l,m,r,lno: CARDINAL; + T: Table; + id: ARRAY [0..WordLength-1] OF CHAR; + key: ARRAY [1..N] OF Alfa; + + PROCEDURE copy; + BEGIN + Write(ch); + Read(ch) + END copy; + + PROCEDURE heading; + BEGIN + lno := lno + 1; + WriteCard(lno, 5); + WriteString(" ") + END heading; + +BEGIN + InitTable(T); + key[1] := "AND "; + key[2] := "ARRAY "; + key[3] := "BEGIN "; + key[4] := "BITSET "; + key[5] := "BOOLEAN "; + key[6] := "BY "; + key[7] := "CASE "; + key[8] := "CARDINAL "; + key[9] := "CHAR "; + key[10] := "CONST "; + key[11] := "DIV "; + key[12] := "DO "; + key[13] := "ELSE "; + key[14] := "ELSIF "; + key[15] := "END "; + key[16] := "EXIT "; + key[17] := "EXPORT "; + key[18] := "FALSE "; + key[19] := "FOR "; + key[20] := "FROM "; + key[21] := "IF "; + key[22] := "IMPORT "; + key[23] := "IN "; + key[24] := "INTEGER "; + key[25] := "LOOP "; + key[26] := "MOD "; + key[27] := "MODULE "; + key[28] := "NOT "; + key[29] := "OF "; + key[30] := "OR "; + key[31] := "POINTER "; + key[32] := "PROCEDURE "; + key[33] := "QUALIFIED "; + key[34] := "RECORD "; + key[35] := "REPEAT "; + key[36] := "RETURN "; + key[37] := "SET "; + key[38] := "THEN "; + key[39] := "TO "; + key[40] := "TRUE "; + key[41] := "TYPE "; + key[42] := "UNTIL "; + key[43] := "VAR "; + key[44] := "WHILE "; + key[45] := "WITH "; + + OpenInput("mod"); + IF NOT Done THEN HALT END; + OpenOutput("xref"); + lno := 0; + Read(ch); + IF Done THEN + heading; + REPEAT + IF (CAP(ch) >= "A") & (CAP(ch) <= "Z") THEN + k := 0; + REPEAT + id[k] := ch; + k := k + 1; + copy + UNTIL (ch < "0") OR + (ch > "9") & (CAP(ch) < "A") OR + (CAP(ch) > "Z"); + l := 1; + r := N; + id[k] := " "; + REPEAT (* binary search *) + m := (l + r) DIV 2; + i := 0; + WHILE (id[i] = key[m,i]) & (id[i] > " ") DO + i := i+1; + END; + IF id[i] <= key[m,i] THEN r := m-1 END; + IF id[i] >= key[m,i] THEN l := m+1 END; + UNTIL l > r; + IF l = r+1 THEN Record(T, id, lno) END + ELSIF (ch >= "0") & (ch <= "9") THEN + REPEAT + copy + UNTIL ((ch<"0") OR (ch>"9"))&((ch<"A") OR (ch>"Z")) + ELSIF ch = "(" THEN + copy; + IF ch = "*" THEN (* comment *) + REPEAT + REPEAT + IF ch = EOL THEN + copy; + heading + ELSE + copy + END + UNTIL ch = "*"; + copy + UNTIL ch = ")"; + copy + END + ELSIF ch = "'" THEN + REPEAT copy UNTIL ch = "'"; + copy + ELSIF ch = '"' THEN + REPEAT copy UNTIL ch = '"'; + copy + ELSIF ch = EOL THEN + copy; + IF Done THEN heading END + ELSE + copy + END + UNTIL NOT Done OR (overflow # 0) + END; + IF overflow > 0 THEN + WriteString("Table overflow"); + WriteCard(overflow, 6); + Write(EOL) + END; + Write(14C); + Tabulate(T); + CloseInput; + CloseOutput +END XREF. diff --git a/lang/m2/test/Wirth/makefile b/lang/m2/test/Wirth/makefile new file mode 100644 index 000000000..4b28e094e --- /dev/null +++ b/lang/m2/test/Wirth/makefile @@ -0,0 +1,26 @@ +IFLAGS = +M2FLAGS = +MOD = ack +SUFFIX = o + +all: PowersOf2 XREF + +PowersOf2.$(SUFFIX): PowersOf2.mod /proj/em/Work/lib/m2/InOut.def + $(MOD) -c $(M2FLAGS) $(IFLAGS) PowersOf2.mod +TableHandl.$(SUFFIX): TableHandl.mod TableHandl.def /proj/em/Work/lib/m2/InOut.def /proj/em/Work/lib/m2/Storage.def + $(MOD) -c $(M2FLAGS) $(IFLAGS) TableHandl.mod +XREF.$(SUFFIX): XREF.mod /proj/em/Work/lib/m2/InOut.def TableHandl.def + $(MOD) -c $(M2FLAGS) $(IFLAGS) XREF.mod + +OBS_PowersOf2 = \ + PowersOf2.$(SUFFIX) + +PowersOf2: $(OBS_PowersOf2) + $(MOD) -.mod -o PowersOf2 $(M2FLAGS) $(OBS_PowersOf2) + +OBS_XREF = \ + XREF.$(SUFFIX)\ + TableHandl.$(SUFFIX) + +XREF: $(OBS_XREF) + $(MOD) -.mod -o XREF $(M2FLAGS) $(OBS_XREF) diff --git a/lang/m2/test/getenv.mod b/lang/m2/test/getenv.mod new file mode 100644 index 000000000..b9c4b18f3 --- /dev/null +++ b/lang/m2/test/getenv.mod @@ -0,0 +1,29 @@ +MODULE PrEnv; +FROM InOut IMPORT WriteString, WriteLn, ReadString, Done; +FROM Arguments IMPORT GetEnv, Argv, Argc; +VAR Buf: ARRAY[1..256] OF CHAR; + i: INTEGER; +BEGIN + FOR i := 0 TO INTEGER(Argc) - 1 DO + IF Argv(i, Buf) > SIZE(Buf) THEN + WriteString("Argument too long"); + WriteLn; + HALT; + END; + WriteString(Buf); + WriteString(" "); + END; + WriteLn; + LOOP + WriteString("Environment name: "); + ReadString(Buf); + IF NOT Done THEN EXIT; END; + IF GetEnv(Buf, Buf) = 0 THEN + WriteString("No environment variable"); + ELSE + WriteString(Buf); + END; + WriteLn; + END; + WriteLn; +END PrEnv. diff --git a/lang/m2/test/m2p.mod b/lang/m2/test/m2p.mod new file mode 100644 index 000000000..c4e88ed14 --- /dev/null +++ b/lang/m2/test/m2p.mod @@ -0,0 +1,1305 @@ +MODULE Modula2PrettyPrinter; + +FROM InOut IMPORT + Done, Read, Write, WriteLn, WriteString, OpenInput, OpenOutput, + CloseInput, CloseOutput; + +(* +** Modula-2 Prettyprinter, November 1985. +** +** by Ken Yap, U of Rochester, CS Dept. +** +** Permission to copy, modify, and distribute, but not for profit, +** is hereby granted, provided that this note is included. +** +** adapted from a Pascal Program Formatter +** by J. E. Crider, Shell Oil Company, +** Houston, Texas 77025 +** +** This program formats Modula-2 programs according +** to structured formatting principles +** +** A valid Modula-2 program is read from the input and +** a formatted program is written to the output. +** It is basically a recursive descent parser with actions +** intermixed with syntax scanning. +** +** The actions of the program are as follows: +** +** FORMATTING: Each structured statement is formatted +** in the following pattern (with indentation "indent"): +** +** XXXXXX header XXXXXXXX +** XXXXXXXXXXXXXXXXXX +** XXXXX body XXXXXX +** XXXXXXXXXXXXXXXXXX +** END +** +** where the header is one of: +** +** IF THEN +** ELSIF THEN +** ELSE +** WHILE DO +** FOR := DO +** WITH DO +** REPEAT +** LOOP +** CASE OF +** : +** +** and the last line begins with UNTIL or is END. +** Other program parts are formatted similarly. The headers are: +** +** ; +** CONST +** TYPE +** VAR +** BEGIN +** (various FOR records AND RECORD variants) +** +** COMMENTS: Each comment that starts before or on a specified +** column on an input line (program constant "commthresh") is +** copied without shifting or reformatting. Each comment that +** starts after "commthresh" is reformatted and left-justified +** following the aligned comment base column ("alcommbase"). +** +** SPACES AND BLANK LINES: Spaces not at line breaks are copied from +** the input. Blank lines are copied from the input if they appear +** between statements (or appropriate declaration units). A blank +** line is inserted above each significant part of each program/ +** procedure if one is not already there. +** +** CONTINUATION: Lines that are too long for an output line are +** continued with additional indentation ("contindent"). +*) + +CONST + TAB = 11C; + NEWLINE = 12C; (* for Unix *) + FF = 14C; + maxrwlen = 15; (* size of reserved word strings *) + ordminchar = 0; (* ord of lowest char in char set *) + ordmaxchar = 127; (* ord of highest char in char set *) +(* The following parameters may be adjusted for the installation: *) + maxinlen = 255; (* maximum width of input line + 1 *) + maxoutlen = 80; (* maximum width of output line *) + tabinterval = 8; (* interval between tab columns *) + initmargin = 0; (* initial value of output margin *) + commthresh = tabinterval; (* column threshhold in input for + comments to be aligned *) + alcommbase = 40; (* aligned comments in output start + after this column *) + indent = tabinterval; (* RECOMMENDED indentation increment *) + contindent = tabinterval; (* continuation indentation, >indent *) + commindent = tabinterval; (* comment continuation indentation *) + +TYPE + natural = INTEGER[0..32767]; + inrange = INTEGER[0..maxinlen]; + outrange = INTEGER[0..maxoutlen]; + + errortype = (longline, noendcomm, notquote, longword, notdo, notof, + notend, notthen, notbegin, notuntil, notident, notsemicolon, notcolon, + notperiod, notparen, noeof); + + chartype = (illegal, special, chapostrophe, chleftparen, chrightparen, + chperiod, digit, chcolon, chsemicolon, chlessthan, chgreaterthan, + letter, chleftbrace, chbar); + + chartypeset = SET OF chartype; (* for reserved word recognition *) + + resword = ( (* reserved words ordered by length *) + rwif, rwdo, rwof, rwto, rwin, rwor, + (* length: 2 *) + rwend, rwfor, rwvar, rwdiv, rwmod, rwset, rwand, rwnot, rwnil, + (* length: 3 *) + rwthen, rwelse, rwwith, rwcase, rwtype, rwloop, rwfrom, + (* length: 4 *) + rwbegin, rwelsif, rwuntil, rwwhile, rwarray, rwconst, + (* length: 5 *) + rwrepeat, rwrecord, rwmodule, rwimport, rwexport, + (* length: 6 *) + rwpointer, (* length: 7 *) + rwprocedure, rwqualified, (* length: 9 *) + rwdefinition, (* length: 10 *) + rwimplementation, (* length: 14 *) + rwx); (* length: 15 for table sentinel *) + rwstring = ARRAY [1..maxrwlen] OF CHAR; + + firstclass = ( (* class of word if on new line *) + newclause, (* start of new clause *) + continue, (* continuation of clause *) + alcomm, (* start of aligned comment *) + contalcomm, (* continuation of aligned comment *) + uncomm, (* start of unaligned comment *) + contuncomm); (* continuation of unaligned comment *) + + wordtype = RECORD (* data record for word *) + whenfirst : firstclass; (* class of word if on new line *) + puncfollows : BOOLEAN; (* to reduce dangling punctuation *) + blanklncount : natural; (* number of preceding blank lines *) + spaces : INTEGER; (* number of spaces preceding word *) + base : [-1..maxinlen]; (* inline.buf[base] precedes word *) + size : inrange; + END; (* length of word in inline.buf *) + + symboltype = ( (* symbols for syntax analysis *) + symodule, sydefinition, syimplementation, syfrom, syimport, syexport, + syqual, syproc, declarator, sybegin, syend, syif, sythen, syelsif, + syelse, syloop, sycase, syof, syuntil, syrepeat, forwhilewith, sydo, + syrecord, ident, intconst, semicolon, leftparen, rightparen, period, + colon, bar, othersym, otherword, comment, syeof); + symbolset = SET OF symboltype; + +VAR + inline : RECORD (* input line data *) + endoffile : BOOLEAN; (* end of file on input? *) + ch : CHAR; (* current char, buf[index] *) + index : inrange; (* subscript of current char *) + len : natural; (* length of input line in buf *) + buf : ARRAY [1..maxinlen] OF CHAR; + END; + outline : RECORD (* output line data *) + blanklns : natural; (* number of preceding blank lines *) + len : outrange; (* number of chars in buf *) + buf : ARRAY [1..maxoutlen] OF CHAR; + END; + curword : wordtype; (* current word *) + margin : outrange; (* left margin *) + lnpending : BOOLEAN; (* new line before next symbol? *) + inheader : BOOLEAN; (* are we scanning a proc header? *) + symbol : symboltype; (* current symbol *) + + (* Structured Constants *) + headersyms : symbolset; (* headers for program parts *) + strucsyms : symbolset; (* symbols that begin structured + statements *) + stmtendsyms : symbolset; (* symbols that follow statements *) + stopsyms : symbolset; (* symbols that stop expression scan *) + recendsyms : symbolset; (* symbols that stop record scan *) + datawords : symbolset; (* to reduce dangling punctuation *) + firstrw : ARRAY [1..maxrwlen] OF resword; + rwword : ARRAY [rwif..rwimplementation] OF rwstring; + rwsy : ARRAY [rwif..rwimplementation] OF symboltype; + charclass : ARRAY CHAR OF chartype; + symbolclass : ARRAY chartype OF symboltype; + +PROCEDURE StrCmp(a, b : rwstring) : BOOLEAN; +VAR + i : INTEGER; +BEGIN + FOR i := 1 TO maxrwlen DO + IF a[i] # b[i] THEN + RETURN FALSE; + END; + END; + RETURN TRUE; +END StrCmp; + +PROCEDURE StructConsts; +(* establish values of structured constants *) +VAR + i : [ordminchar..ordmaxchar]; (* loop index *) + ch : CHAR; (* loop index *) + +PROCEDURE BuildResWord(rw : resword; symword : rwstring; symbol : symboltype); +BEGIN + rwword[rw] := symword; (* reserved word string *) + rwsy[rw] := symbol; (* map to symbol *) +END BuildResWord; + +BEGIN (* StructConsts *) +(* symbol sets for syntax analysis *) + headersyms := symbolset{symodule, syproc, declarator, sybegin, syend, + syeof}; + strucsyms := symbolset{sycase, syrepeat, syif, forwhilewith, syloop}; + stmtendsyms := symbolset{semicolon, bar, syend, syuntil, syelsif, + syelse, syeof}; + stopsyms := headersyms + strucsyms + stmtendsyms; + recendsyms := symbolset{rightparen, syend, syeof}; + datawords := symbolset{otherword, intconst, ident, syend}; + +(* constants for recognizing reserved words *) + firstrw[1] := rwif; (* length: 1 *) + firstrw[2] := rwif; (* length: 2 *) + BuildResWord(rwif, 'IF ', syif); + BuildResWord(rwdo, 'DO ', sydo); + BuildResWord(rwof, 'OF ', syof); + BuildResWord(rwto, 'TO ', othersym); + BuildResWord(rwin, 'IN ', othersym); + BuildResWord(rwor, 'OR ', othersym); + firstrw[3] := rwend; (* length: 3 *) + BuildResWord(rwend, 'END ', syend); + BuildResWord(rwfor, 'FOR ', forwhilewith); + BuildResWord(rwvar, 'VAR ', declarator); + BuildResWord(rwdiv, 'DIV ', othersym); + BuildResWord(rwmod, 'MOD ', othersym); + BuildResWord(rwset, 'SET ', othersym); + BuildResWord(rwand, 'AND ', othersym); + BuildResWord(rwnot, 'NOT ', othersym); + BuildResWord(rwnil, 'NIL ', otherword); + firstrw[4] := rwthen; (* length: 4 *) + BuildResWord(rwthen, 'THEN ', sythen); + BuildResWord(rwelse, 'ELSE ', syelse); + BuildResWord(rwwith, 'WITH ', forwhilewith); + BuildResWord(rwloop, 'LOOP ', syloop); + BuildResWord(rwfrom, 'FROM ', syfrom); + BuildResWord(rwcase, 'CASE ', sycase); + BuildResWord(rwtype, 'TYPE ', declarator); + firstrw[5] := rwbegin; (* length: 5 *) + BuildResWord(rwbegin, 'BEGIN ', sybegin); + BuildResWord(rwelsif, 'ELSIF ', syelsif); + BuildResWord(rwuntil, 'UNTIL ', syuntil); + BuildResWord(rwwhile, 'WHILE ', forwhilewith); + BuildResWord(rwarray, 'ARRAY ', othersym); + BuildResWord(rwconst, 'CONST ', declarator); + firstrw[6] := rwrepeat; (* length: 6 *) + BuildResWord(rwrepeat, 'REPEAT ', syrepeat); + BuildResWord(rwrecord, 'RECORD ', syrecord); + BuildResWord(rwmodule, 'MODULE ', symodule); + BuildResWord(rwimport, 'IMPORT ', syimport); + BuildResWord(rwexport, 'EXPORT ', syexport); + firstrw[7] := rwpointer; (* length: 7 *) + BuildResWord(rwpointer, 'POINTER ', othersym); + firstrw[8] := rwprocedure; (* length: 8 *) + firstrw[9] := rwprocedure; (* length: 9 *) + BuildResWord(rwprocedure, 'PROCEDURE ', syproc); + BuildResWord(rwqualified, 'QUALIFIED ', syqual); + firstrw[10] := rwdefinition; (* length: 10 *) + BuildResWord(rwdefinition, 'DEFINITION ', sydefinition); + firstrw[11] := rwimplementation;(* length: 11 *) + firstrw[12] := rwimplementation;(* length: 12 *) + firstrw[13] := rwimplementation;(* length: 13 *) + firstrw[14] := rwimplementation;(* length: 14 *) + BuildResWord(rwimplementation, 'IMPLEMENTATION ', syimplementation); + firstrw[15] := rwx; (* length: 15 FOR table sentinel *) + +(* constants for lexical scan *) + FOR i := ordminchar TO ordmaxchar DO + charclass[CHR(i)] := illegal; + END; + FOR ch := 'a' TO 'z' DO + charclass[ch] := letter; + charclass[CAP(ch)] := letter; + END; + FOR ch := '0' TO '9' DO + charclass[ch] := digit; + END; + charclass[' '] := special; + charclass['"'] := chapostrophe; + charclass['#'] := special; + charclass['&'] := special; + charclass["'"] := chapostrophe; + charclass['('] := chleftparen; + charclass[')'] := chrightparen; + charclass['*'] := special; + charclass['+'] := special; + charclass[','] := special; + charclass['-'] := special; + charclass['.'] := chperiod; + charclass['/'] := special; + charclass[':'] := chcolon; + charclass[';'] := chsemicolon; + charclass['<'] := chlessthan; + charclass['='] := special; + charclass['>'] := chgreaterthan; + charclass['@'] := special; + charclass['['] := special; + charclass[']'] := special; + charclass['^'] := special; + charclass['{'] := special; + charclass['|'] := chbar; + charclass['}'] := special; + symbolclass[illegal] := othersym; + symbolclass[special] := othersym; + symbolclass[chapostrophe] := otherword; + symbolclass[chleftparen] := leftparen; + symbolclass[chrightparen] := rightparen; + symbolclass[chperiod] := period; + symbolclass[digit] := intconst; + symbolclass[chcolon] := colon; + symbolclass[chsemicolon] := semicolon; + symbolclass[chlessthan] := othersym; + symbolclass[chgreaterthan] := othersym; + symbolclass[chbar] := bar; + symbolclass[letter] := ident; +END StructConsts; + +(* FlushLine/WriteError/ReadLine convert between files and lines. *) + +PROCEDURE FlushLine; +(* Write buffer into output file *) +VAR + i, j, vircol : outrange; (* loop index *) + nonblankseen : BOOLEAN; +BEGIN + WITH outline DO + WHILE blanklns > 0 DO + WriteLn; + blanklns := blanklns - 1; + END; + IF len > 0 THEN + vircol := 0; + nonblankseen := FALSE; + (* set this to TRUE if you don't want + blanks to tab conversion *) + FOR i := 0 TO len - 1 DO + IF buf[i+1] <> ' ' THEN + IF NOT nonblankseen THEN + LOOP + j := (vircol DIV + tabinterval + 1) * + tabinterval; + IF j > i THEN + EXIT; + END; + Write(TAB); + vircol := j; + END; + END; + nonblankseen := TRUE; + WHILE vircol < i DO + Write(' '); + vircol := vircol + 1; + END; + Write(buf[i+1]); + vircol := i + 1; + END; + END; + WriteLn; + len := 0; + END; + END; +END FlushLine; + +PROCEDURE WriteError(error : errortype; nm : ARRAY OF CHAR); +(* report error to output *) +VAR + i, ix : inrange; (* loop index, limit *) +BEGIN + FlushLine; + WriteString('(* !!! error, '); + WriteString(nm); + CASE error OF + longline: + WriteString('shorter line'); + | noendcomm: + WriteString('END OF comment'); + | notquote: + WriteString("final ' on line"); + | longword: + WriteString('shorter word'); + | notdo: + WriteString('"DO"'); + | notof: + WriteString('"OF"'); + | notend: + WriteString('"END"'); + | notthen: + WriteString('"THEN"'); + | notbegin: + WriteString('"BEGIN"'); + | notuntil: + WriteString('"UNTIL"'); + | notident: + WriteString('"identifier"'); + | notsemicolon: + WriteString('";"'); + | notperiod: + WriteString('"."'); + | notcolon: + WriteString('":"'); + | notparen: + WriteString('")"'); + | noeof: + WriteString('END OF file'); + END; + WriteString(' expected'); + IF error >= longword THEN + WriteString(', NOT "'); + WITH inline DO + WITH curword DO + IF size > maxrwlen THEN + ix := maxrwlen + ELSE + ix := size; + END; + FOR i := 1 TO ix DO + Write(buf[base + i]); + END; + END; + END; + Write('"'); + END; + IF error = noeof THEN + WriteString(', FORMATTING STOPS'); + END; + WriteString(' !!! *)'); + WriteLn; +END WriteError; + +PROCEDURE ReadLine; +(* Read line into input buffer *) +VAR + c : CHAR; (* input character *) +BEGIN + WITH inline DO + len := 0; + LOOP + Read(c); + IF NOT Done THEN + endoffile := TRUE; + EXIT; + END; + IF c = NEWLINE THEN + EXIT; + END; + IF c < ' ' THEN (* convert ISO control chars (except + leading form feed) to spaces *) + IF c = TAB THEN + (* ISO TAB char *) + c := ' '; + (* add last space at end *) + WHILE len MOD 8 <> 7 DO + len := len + 1; + IF len < maxinlen THEN + buf[len] := c; + END; + END; + (* END tab handling *) + ELSIF (c <> FF) OR (len > 0) THEN + c := ' '; + END; + END; (* END ISO control char conversion *) + len := len + 1; + IF len < maxinlen THEN + buf[len] := c; + END; + END; + IF NOT endoffile THEN + IF len >= maxinlen THEN + (* input line too long *) + WriteError(longline, "(ReadLine), "); + len := maxinlen - 1; + END; + WHILE (len > 0) AND (buf[len] = ' ') DO + len := len - 1; + END; + END; + len := len + 1; (* add exactly ONE trailing blank *) + buf[len] := ' '; + index := 0; + END; +END ReadLine; + +PROCEDURE GetChar; +(* get next char from input buffer *) +BEGIN + WITH inline DO + index := index + 1; + ch := buf[index]; + END; +END GetChar; + +PROCEDURE NextChar() : CHAR; +(* look at next char in input buffer *) +BEGIN + RETURN inline.buf[inline.index + 1]; +END NextChar; + +PROCEDURE StartWord(startclass : firstclass); +(* note beginning of word, and count preceding lines and spaces *) +VAR + first : BOOLEAN; (* is word the first on input line? *) +BEGIN + first := FALSE; + WITH inline DO + WITH curword DO + whenfirst := startclass; + blanklncount := 0; + WHILE (index >= len) AND NOT endoffile DO + IF len = 1 THEN + blanklncount := blanklncount + 1; + END; + IF startclass = contuncomm THEN + FlushLine + ELSE + first := TRUE; + END; + ReadLine; + (* with exactly ONE trailing blank *) + GetChar; + IF ch = FF THEN + FlushLine; + Write(FF); + blanklncount := 0; + GetChar; + END; + END; + spaces := 0; (* count leading spaces *) + IF NOT endoffile THEN + WHILE ch = ' ' DO + spaces := spaces + 1; + GetChar; + END; + END; + IF first THEN + spaces := 1; + END; + base := index - 1; + END; + END; +END StartWord; + +PROCEDURE FinishWord; +(* note end of word *) +BEGIN + WITH inline DO + WITH curword DO + puncfollows := (symbol IN datawords) AND (ch <> ' '); + size := index - base - 1; + END; + END; +END FinishWord; + +PROCEDURE CopyWord(newline : BOOLEAN; pword : wordtype); +(* copy word from input buffer into output buffer *) +VAR + i : INTEGER; (* outline.len excess, loop index *) +BEGIN + WITH pword DO + WITH outline DO + i := maxoutlen - len - spaces - size; + IF newline OR (i < 0) OR ((i = 0) AND puncfollows) THEN + FlushLine; + END; + IF len = 0 THEN (* first word on output line *) + blanklns := blanklncount; + CASE whenfirst OF + (* update LOCAL word.spaces *) + newclause: + spaces := margin; + | continue: + spaces := margin; + | alcomm: + spaces := alcommbase; + | contalcomm: + spaces := alcommbase + commindent; + | uncomm: + spaces := base; + | contuncomm: + (* spaces := spaces *); + END; + IF spaces + size > maxoutlen THEN + spaces := maxoutlen - size; + (* reduce spaces *) + IF spaces < 0 THEN + WriteError(longword, + "(CopyWord), "); + size := maxoutlen; + spaces := 0; + END; + END; + END; + FOR i := 1 TO spaces DO + (* put out spaces *) + len := len + 1; + buf[len] := ' '; + END; + FOR i := 1 TO size DO + (* copy actual word *) + len := len + 1; + buf[len] := inline.buf[base + i]; + END; + END; + END; +END CopyWord; + +PROCEDURE DoComment; (* copy aligned or unaligned comment *) + +PROCEDURE CopyComment(commclass : firstclass; commbase : inrange); +(* copy words of comment *) +VAR + endcomment : BOOLEAN; (* end of comment? *) +BEGIN + WITH curword DO (* copy comment begin symbol *) + whenfirst := commclass; + spaces := commbase - outline.len; + CopyWord((spaces < 0) OR (blanklncount > 0), curword); + END; + commclass := VAL(firstclass, ORD(commclass)+1); + WITH inline DO + REPEAT (* loop for successive words *) + StartWord(commclass); + endcomment := endoffile; + (* premature end? *) + IF endcomment THEN + WriteError(noendcomm, "(CopyComment), ") + ELSE + REPEAT + IF ch = '*' THEN + GetChar; + IF ch = ')' THEN + endcomment := TRUE; + GetChar; + END; + ELSE + GetChar; + END; + UNTIL (ch = ' ') OR endcomment; + END; + FinishWord; + CopyWord(FALSE, curword) + UNTIL endcomment; + END; +END CopyComment; + +BEGIN (* DoComment *) + IF curword.base < commthresh THEN + (* copy comment without alignment *) + CopyComment(uncomm, curword.base) + ELSE (* align AND format comment *) + CopyComment(alcomm, alcommbase); + END; +END DoComment; + +PROCEDURE GetSymbol; +(* get next non-comment symbol *) + +PROCEDURE CopySymbol(symbol : symboltype; pword : wordtype); +(* copy word(s) of symbol *) +BEGIN + IF symbol = comment THEN + DoComment; (* NOTE: DoComment uses global word! *) + lnpending := TRUE; + ELSIF symbol = semicolon THEN + CopyWord(FALSE, pword); + lnpending := NOT inheader; + ELSE + CopyWord(lnpending, pword); + lnpending := FALSE; + END; +END CopySymbol; + +PROCEDURE FindSymbol; +(* find next symbol in input buffer *) + +VAR + termch : CHAR; (* string terminator *) + chclass : chartype; (* classification of leading char *) + +PROCEDURE CheckResWord; +(* check if current identifier is reserved word/symbol *) +VAR + rw, rwbeyond : resword; (* loop index, limit *) + symword : rwstring; (* copy of symbol word *) + i : [-1..maxrwlen]; (* loop index *) +BEGIN + WITH curword DO + WITH inline DO + size := index - base - 1; + IF size < maxrwlen THEN + symword := ' '; + FOR i := 1 TO size DO + symword[i] := CAP(buf[ base + i]); + END; + rw := firstrw[size]; + rwbeyond := firstrw[size + 1]; + symbol := semicolon; + REPEAT + IF rw >= rwbeyond THEN + symbol := ident + ELSIF StrCmp(symword, rwword[rw]) THEN + symbol := rwsy[rw] + ELSE + rw := VAL(resword,ORD(rw)+1); + END; + UNTIL symbol <> semicolon; + END; + whenfirst := newclause; + END; + END; +END CheckResWord; + +PROCEDURE GetName; +BEGIN + WHILE charclass[inline.ch] IN chartypeset{letter, digit} DO + GetChar; + END; + CheckResWord; +END GetName; + +PROCEDURE GetNumber; +BEGIN + WITH inline DO + WHILE charclass[ch] = digit DO + GetChar; + END; + IF ch = '.' THEN + IF charclass[NextChar()] = digit THEN + (* NOTE: NextChar is a function! *) + symbol := otherword; + GetChar; + WHILE charclass[ch] = digit DO + GetChar; + END; + END; + END; + IF CAP(ch) = 'E' THEN + symbol := otherword; + GetChar; + IF (ch = '+') OR (ch = '-') THEN + GetChar; + END; + WHILE charclass[ch] = digit DO + GetChar; + END; + END; + END; +END GetNumber; + +PROCEDURE GetStringLiteral; +VAR + endstring : BOOLEAN; (* end of string literal? *) +BEGIN + WITH inline DO + endstring := FALSE; + REPEAT + GetChar; + IF ch = termch THEN + endstring := TRUE; + ELSIF index >= len THEN + (* error, final "'" not on line *) + WriteError(notquote, "(GetStringLiteral), "); + symbol := syeof; + endstring := TRUE; + END; + UNTIL endstring; + GetChar; + END; +END GetStringLiteral; + +BEGIN (* FindSymbol *) + StartWord(continue); + WITH inline DO + IF endoffile THEN + symbol := syeof + ELSE + termch := ch; (* save for string literal routine *) + chclass := charclass[ch]; + symbol := symbolclass[chclass]; + GetChar; (* second CHAR *) + CASE chclass OF + chsemicolon, chrightparen, chleftbrace, special, + illegal: ; + | letter: + GetName; + | digit: + GetNumber; + | chapostrophe: + GetStringLiteral; + | chcolon: + IF ch = '=' THEN + symbol := othersym; + GetChar; + END; + | chlessthan: + IF (ch = '=') OR (ch = '>') THEN + GetChar; + END; + | chgreaterthan: + IF ch = '=' THEN + GetChar; + END; + | chleftparen: + IF ch = '*' THEN + symbol := comment; + GetChar; + END; + | chperiod: + IF ch = '.' THEN + symbol := colon; + GetChar; + END; (* Added by me (CJ): *) + ELSE + END; + FinishWord; + END; + END; (* FindSymbol *) +END FindSymbol; + +BEGIN (* GetSymbol *) + REPEAT + CopySymbol(symbol, curword); + (* copy word for symbol to output *) + FindSymbol (* get next symbol *) + UNTIL symbol <> comment; +END GetSymbol; + +PROCEDURE StartClause; +(* (this may be a simple clause, or the start of a header) *) +BEGIN + curword.whenfirst := newclause; + lnpending := TRUE; +END StartClause; + +PROCEDURE PassSemicolons; +(* pass consecutive semicolons *) +BEGIN + WHILE symbol = semicolon DO + GetSymbol; + StartClause; + END; +END PassSemicolons; + +PROCEDURE StartBody; +(* finish header, start body of structure *) +BEGIN + StartClause; + margin := margin + indent; +END StartBody; + +PROCEDURE FinishBody; +(* retract margin *) +BEGIN + margin := margin - indent; +END FinishBody; + +PROCEDURE PassPhrase(finalsymbol : symboltype); +(* process symbols until significant symbol encountered *) +VAR + endsyms : symbolset; (* complete set of stopping symbols *) +BEGIN + IF symbol <> syeof THEN + endsyms := stopsyms; + INCL(endsyms, finalsymbol); + REPEAT + GetSymbol + UNTIL symbol IN endsyms; + END; +END PassPhrase; + +PROCEDURE Expect(expectedsym : symboltype; error : errortype; syms : symbolset; +nm : ARRAY OF CHAR); +(* fail if current symbol is not the expected one, then recover *) +BEGIN + IF symbol = expectedsym THEN + GetSymbol + ELSE + WriteError(error, nm); + INCL(syms, expectedsym); + WHILE NOT (symbol IN syms) DO + GetSymbol; + END; + IF symbol = expectedsym THEN + GetSymbol; + END; + END; +END Expect; + +PROCEDURE Heading; +(* process heading for program or procedure *) + +PROCEDURE MatchParens; (* process parentheses in heading *) +VAR + endsyms : symbolset; +BEGIN + GetSymbol; + WHILE NOT (symbol IN recendsyms) DO + IF symbol = leftparen THEN + MatchParens + ELSE + GetSymbol; + END; + END; + endsyms := stopsyms + recendsyms; + Expect(rightparen, notparen, endsyms, "(MatchParens), "); +END MatchParens; + +BEGIN (* heading *) + GetSymbol; + PassPhrase(leftparen); + IF symbol = leftparen THEN + inheader := TRUE; + MatchParens; + inheader := FALSE; + END; + IF symbol = colon THEN + PassPhrase(semicolon); + END; + Expect(semicolon, notsemicolon, stopsyms, "(Heading), "); + +END Heading; + +PROCEDURE DoRecord; +(* process record declaration *) +BEGIN + GetSymbol; + StartBody; + PassFields(FALSE); + FinishBody; + Expect(syend, notend, recendsyms, "(DoRecord), "); +END DoRecord; + +PROCEDURE DoVariant; +(* process (case) variant part *) +BEGIN + PassPhrase(syof); + Expect(syof, notof, stopsyms, "(Dovariant), "); + StartBody; + PassFields(TRUE); + FinishBody; +END DoVariant; + +PROCEDURE DoParens(forvariant : BOOLEAN); +(* process parentheses in record *) +BEGIN + GetSymbol; + IF forvariant THEN + StartBody; + END; + PassFields(FALSE); + lnpending := FALSE; (* for empty field list *) + Expect(rightparen, notparen, recendsyms, "(DoParens), "); + IF forvariant THEN + FinishBody; + END; +END DoParens; + +PROCEDURE PassFields(forvariant : BOOLEAN); +(* process declarations *) +BEGIN + WHILE NOT (symbol IN recendsyms) DO + IF symbol = semicolon THEN + PassSemicolons + ELSIF symbol = syrecord THEN + DoRecord + ELSIF symbol = sycase THEN + DoVariant + ELSIF symbol = leftparen THEN + DoParens(forvariant) + ELSE + GetSymbol; + END; + END; +END PassFields; + +PROCEDURE Statement; +(* process statement *) +BEGIN + CASE symbol OF + sycase: + CaseStatement; + Expect(syend, notend, stmtendsyms, "(Case), "); + | syif: + IfStatement; + Expect(syend, notend, stmtendsyms, "(If), "); + | syloop: + LoopStatement; + Expect(syend, notend, stmtendsyms, "(Loop), "); + | syrepeat: + RepeatStatement; + | forwhilewith: + ForWhileWithStatement; + Expect(syend, notend, stmtendsyms, "(ForWhileWith), "); + | ident: + AssignmentProccall; + | semicolon: ; (*!!! Added by me (CJ) *) + ELSE ; + END; +END Statement; + +PROCEDURE AssignmentProccall; +(* pass an assignment statement or procedure call *) +BEGIN + WHILE NOT (symbol IN stmtendsyms) DO + GetSymbol; + END; +END AssignmentProccall; + +PROCEDURE StatementSequence; +(* process sequence of statements *) +BEGIN + Statement; + LOOP + IF symbol <> semicolon THEN + EXIT; + END; + GetSymbol; + Statement; + END; +END StatementSequence; + +PROCEDURE IfStatement; +(* process if statement *) +BEGIN + PassPhrase(sythen); + Expect(sythen, notthen, stopsyms, "(Ifstatement), "); + StartBody; + StatementSequence; + FinishBody; + WHILE symbol = syelsif DO + StartClause; + PassPhrase(sythen); + Expect(sythen, notthen, stopsyms, "(Elseif), "); + StartBody; (* new line after 'THEN' *) + StatementSequence; + FinishBody; + END; + IF symbol = syelse THEN + StartClause; + GetSymbol; + StartBody; (* new line after 'ELSE' *) + StatementSequence; + FinishBody; + END; +END IfStatement; + +PROCEDURE CaseStatement; +(* process case statement *) +BEGIN + PassPhrase(syof); + Expect(syof, notof, stopsyms, "(caseStatement), "); + StartClause; + OneCase; + WHILE symbol = bar DO + GetSymbol; + OneCase; + END; + IF symbol = syelse THEN + GetSymbol; + StartBody; + StatementSequence; + FinishBody; + END; +END CaseStatement; + +PROCEDURE OneCase; +(* process one case clause *) +BEGIN + IF NOT (symbol IN symbolset{bar, syelse}) THEN + PassPhrase(colon); + Expect(colon, notcolon, stopsyms, "(OneCase), "); + StartBody; (* new line, indent after colon *) + StatementSequence; + FinishBody; (* left-indent after case *) + END; +END OneCase; + +PROCEDURE RepeatStatement; +(* process repeat statement *) +BEGIN + GetSymbol; + StartBody; (* new line, indent after 'REPEAT' *) + StatementSequence; + FinishBody; (* left-ident after UNTIL *) + StartClause; (* new line before UNTIL *) + Expect(syuntil, notuntil, stmtendsyms, "(repeatstatement), "); + PassPhrase(semicolon); +END RepeatStatement; + +PROCEDURE LoopStatement; +(* process loop statement *) +BEGIN + GetSymbol; + StartBody; (* new line, indent after LOOP *) + StatementSequence; + FinishBody; (* left-ident before END *) +END LoopStatement; + +PROCEDURE ForWhileWithStatement; +(* process for, while, or with statement *) +BEGIN + PassPhrase(sydo); + Expect(sydo, notdo, stopsyms, "(ForWhileWithstatement), "); + StartBody; + StatementSequence; + FinishBody; +END ForWhileWithStatement; + +PROCEDURE ProcedureDeclaration; +(* pass a procedure declaration *) +BEGIN + ProcedureHeading; + Block; + Expect(ident, notident, stmtendsyms, "(Proceduredeclaration)1, "); + Expect(semicolon, notsemicolon, stmtendsyms, + "(Proceduredeclaration)2, "); +END ProcedureDeclaration; + +PROCEDURE ProcedureHeading; +BEGIN + StartClause; + Heading; +END ProcedureHeading; + +PROCEDURE Block; +BEGIN + WHILE symbol IN symbolset{declarator, symodule, syproc} DO + Declaration; + END; + IF symbol = sybegin THEN + GetSymbol; + StartBody; + StatementSequence; + FinishBody; + END; + Expect(syend, notend, stmtendsyms, "(Block), "); +END Block; + +PROCEDURE Declaration; +BEGIN + IF symbol = declarator THEN + StartClause; (* CONST, TYPE, VAR *) + GetSymbol; + StartBody; + REPEAT + PassPhrase(syrecord); + IF symbol = syrecord THEN + DoRecord; + END; + IF symbol = semicolon THEN + PassSemicolons; + END; + UNTIL symbol IN headersyms; + FinishBody; + ELSIF symbol = symodule THEN + ModuleDeclaration; + ELSIF symbol = syproc THEN + ProcedureDeclaration; + END; +END Declaration; + +PROCEDURE ModuleDeclaration; +BEGIN + PassPhrase(semicolon); + PassSemicolons; + WHILE symbol IN symbolset{syimport, syexport, syfrom} DO + ImportExport; + END; + Block; + Expect(ident, notident, stmtendsyms, "(ModuleDeclaration), "); +END ModuleDeclaration; + +PROCEDURE ImportExport; +BEGIN + IF symbol = syfrom THEN + PassPhrase(syimport); + END; + IF symbol = syimport THEN + GetSymbol; + ELSIF symbol = syexport THEN + GetSymbol; + IF symbol = syqual THEN + GetSymbol; + END; + END; + StartBody; + PassPhrase(semicolon); + FinishBody; + GetSymbol; +END ImportExport; + +PROCEDURE OneDefinition; +BEGIN + IF symbol = declarator THEN + Declaration; + ELSIF symbol = syproc THEN + ProcedureHeading; + END; +END OneDefinition; + +PROCEDURE DefinitionModule; +BEGIN + GetSymbol; + PassPhrase(semicolon); + GetSymbol; + WHILE symbol IN symbolset{syimport, syexport, syfrom} DO + ImportExport; + END; + WHILE symbol IN symbolset{declarator, syproc} DO + OneDefinition; + END; + Expect(syend, notend, stmtendsyms, "DefinitionModule1, " ); + GetSymbol; + Expect(period, notperiod, stmtendsyms, 'DefintionModule2, '); +END DefinitionModule; + +PROCEDURE ProgramModule; +BEGIN + ModuleDeclaration; + Expect(period, notperiod, stmtendsyms, "ProgramModule, "); +END ProgramModule; + +PROCEDURE CompilationUnit; +BEGIN + IF symbol = syimplementation THEN + GetSymbol; + ProgramModule; + ELSIF symbol = sydefinition THEN + DefinitionModule; + ELSE + ProgramModule; + END; +END CompilationUnit; + +PROCEDURE CopyRemainder; +(* copy remainder of input *) +BEGIN + WriteError(noeof, "(Copyremainder), "); + WITH inline DO + REPEAT + CopyWord(FALSE, curword); + StartWord(contuncomm); + IF NOT endoffile THEN + REPEAT + GetChar + UNTIL ch = ' '; + END; + FinishWord; + UNTIL endoffile; + END; +END CopyRemainder; + +PROCEDURE Initialize; +(* initialize global variables *) +BEGIN + WITH inline DO + endoffile := FALSE; + ch := ' '; + index := 0; + len := 0; + END; + WITH outline DO + blanklns := 0; + len := 0; + END; + WITH curword DO + whenfirst := contuncomm; + puncfollows := FALSE; + blanklncount := 0; + spaces := 0; + base := 0; + size := 0; + END; + margin := initmargin; + lnpending := FALSE; + symbol := othersym; +END Initialize; + +BEGIN + StructConsts; + Initialize; +(* Files may be opened here. *) + OpenInput("mod"); + OpenOutput("mod"); + GetSymbol; + CompilationUnit; + IF NOT inline.endoffile THEN + CopyRemainder; + END; + FlushLine; + CloseInput; + CloseOutput; +END Modula2PrettyPrinter. diff --git a/lang/m2/test/queens.mod b/lang/m2/test/queens.mod new file mode 100644 index 000000000..52797615a --- /dev/null +++ b/lang/m2/test/queens.mod @@ -0,0 +1,55 @@ +MODULE queen; +FROM InOut IMPORT WriteString, WriteLn; + TYPE row = ARRAY[1..8] OF INTEGER; + VAR maxpos: INTEGER; + d: row; + PROCEDURE free(i,j: INTEGER): BOOLEAN; + VAR k: INTEGER; + BEGIN + FOR k := 1 TO i-1 DO + IF (d[k]=j) OR (j-d[k]=i-k) OR (d[k]-j=i-k) THEN + RETURN FALSE; + END; + END; + RETURN TRUE; + END free; + + PROCEDURE print; + VAR i,j: INTEGER; + BEGIN + FOR j := maxpos TO 1 BY -1 DO + FOR i := 1 TO maxpos DO + IF d[i] = j THEN + WriteString("D "); + ELSE + WriteString(". "); + END; + END; + WriteLn; + END; + WriteLn; + END print; + + PROCEDURE queen(k: INTEGER); + VAR i: INTEGER; + BEGIN + IF k = maxpos THEN + FOR i := 1 TO maxpos DO + IF free(k,i) THEN + d[k] := i; + print(); + END; + END; + ELSE + FOR i := 1 TO maxpos DO + IF free(k,i) THEN + d[k] := i; + queen(k+1); + END; + END; + END; + END queen; +BEGIN + maxpos := 8; + queen(1); +END queen. -- 2.34.1