[ { "path": "LICENSE.txt", "content": "MIT License\n\nCopyright (c) 2017 Luca Boasso\n\nPermission is hereby granted, free of charge, to any person obtaining a copy\nof this software and associated documentation files (the \"Software\"), to deal\nin the Software without restriction, including without limitation the rights\nto use, copy, modify, merge, publish, distribute, sublicense, and/or sell\ncopies of the Software, and to permit persons to whom the Software is\nfurnished to do so, subject to the following conditions:\n\nThe above copyright notice and this permission notice shall be included in all\ncopies or substantial portions of the Software.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR\nIMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,\nFITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE\nAUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER\nLIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,\nOUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\nSOFTWARE.\n" }, { "path": "Makefile", "content": ".POSIX:\n.SUFFIXES:\n\nJAVA_SOURCES = src/java/Files_FileDesc.java src/java/Files.java \\\n src/java/OberonRuntime.java src/java/Os.java src/java/Out.java \\\n src/java/In.java src/java/Math.java\nMOD_SOURCES = src/Out.Mod src/Os.Mod src/Files.Mod src/Strings.Mod src/OJS.Mod \\\n src/CpCache.Mod src/Opcodes.Mod src/ClassFormat.Mod src/OJB.Mod \\\n src/OJG.Mod src/OJP.Mod src/oberonc.Mod src/In.Mod src/Math.Mod\n\nOBERON_BIN = ./bin\n\nbuild:\n\tmkdir -p out/\n\tjavac -d out $(JAVA_SOURCES)\n\tOBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc out $(MOD_SOURCES)\n\nbootstrap:\n\tjavac -d bin $(JAVA_SOURCES)\n\tOBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc bin $(MOD_SOURCES)\n\nbootstrapTest:\n\trm -rf bootstrapOut/\n\tmkdir -p bootstrapOut/\n\tOBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc bootstrapOut $(MOD_SOURCES)\n\tsha1sum -b bootstrapOut/* > sha1sums0.txt\n\tsed s/bootstrapOut/bin/ sha1sums0.txt > sha1sums1.txt\n\tsha1sum -c --quiet sha1sums1.txt\n\trm sha1sums0.txt sha1sums1.txt\n\nrunFern:\n\trm -rf examples/fern/out/\n\tmkdir -p examples/fern/out/\n\tjavac -cp $(OBERON_BIN) -d examples/fern/out examples/fern/java/*.java\n\tOBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc examples/fern/out \\\n\t examples/fern/RandomNumbers.Mod \\\n\t examples/fern/XYplane.Mod examples/fern/IFS.Mod\n\tjava -cp $(OBERON_BIN):examples/fern/out IFS\n\ntest:\n\trm -rf tests/out/\n\tmkdir -p tests/out/\n\tjavac -cp $(OBERON_BIN) -d tests/out tests/TestRunner.java\n\tOBERON_BIN=${OBERON_BIN} java -Dfile.encoding=UTF-8 -cp $(OBERON_BIN):tests/out TestRunner\n\nclean:\n\trm -rf out/ tests/out/ bootstrapOut/ examples/fern/out/\n" }, { "path": "README.md", "content": "\n# Oberon-07 compiler\n\n`oberonc` is a single pass, self-hosting compiler for the\n[Oberon-07](https://en.wikipedia.org/wiki/Oberon_(programming_language))\nprogramming language. It targets the Java Virtual Machine (version >= 1.8).\n\nThis project was started to showcase Niklaus Wirth's approach to writing\ncompilers (see\n[\"Compiler Construction -\nThe Art of Niklaus Wirth\"](https://github.com/lboasso/oberonc/blob/master/doc/Moe00b.pdf)\nby Hanspeter Mössenböck for more details).\n\n`oberonc` is inspired by Niklaus Wirth's compiler for a RISC processor available\n[here](http://www.inf.ethz.ch/personal/wirth/).\n\nThe compiler is compact and does not depend on any third party libraries. It\nproduces Java bytecode in one pass while parsing the source file. Although\ngenerating code for a stack machine is straightforward, this task is exacerbated\nby a complex class file format and the fact that the JVM was designed with the\nJava language in mind. In fact the JVM lacks many of the primitives required to\nsupport Oberon's features, specifically:\n\n* value types\n* pass by reference evaluation strategy\n* procedure variables (pointer to functions) and relative structural\n compatibility of types\n\nImplementing those features with workarounds increased significantly the size\nof the compiler, totaling roughly 6000 lines of Oberon.\n\nThe source code is written following as much as possible Niklaus Wirth's\ncoding style. `oberonc` compile itself in less than 300 ms on an old\nIntel i5 @ 2.80GHz (~ 100 ms with a hot VM).\n\n## How to build\n\nYou can build the compiler on Linux or Windows, you need a JDK >= 1.8\ninstalled, with java and javac in the environment path.\n\nBecause you need an Oberon compiler to compile the sources in `src`, I have\nadded to the repository the binaries of the compiler to perform the\nbootstrapping.\n\nBy typing `make build` on the shell, the compiler will compile itself and\nwrite the files in the `out` folder. The `make bootstrap` command is equivalent\nto `make build`, but it overwrites the files in the `bin` folder.\n\nTo run the compiler, you need to have the OBERON_BIN environmental variable set\nto the `bin` folder of the repository. This is taken care for you when\nusing `make`.\n\n## How to run the tests\n\nOne typical test is to make sure that, by compiling the compiler, we get the\nsame (bit by bit) class files originally included in the `bin` folder.\nTo run this test simply type `make bootstrapTest` (available only on Linux).\nThis will compile the sources into the `bootstrapOut` folder and compare these\nresulting class files with the ones in `bin`. If something goes wrong\n`sha1sums` will complain.\n\nTo run the tests included in the `tests` folder, type `make test`. The output\nshould look like this:\n\n ...\n TOTAL: 101\n SUCCESSFUL: 101\n FAILED: 0\n\n## Using the compiler\n\nTo use the compiler, you need to have the OBERON_BIN environmental variable set\nto the `bin` folder of the repository, for example on Linux\n`export OBERON_BIN=~/oberonc/bin` or `set OBERON_BIN=C:\\oberonc\\bin`\non Windows.\nThe command line syntax of `oberonc` is simple.\nLet's compile examples/Hello.Mod:\n\n MODULE Hello;\n IMPORT Out; (* Import Out to print on the console *)\n BEGIN\n Out.String(\"Hello 世界\");\n Out.Ln (* print a new line *)\n END Hello.\n\nAssuming you are at the root of the repository, the following command will\ncompile the Hello.Mod example and place the generated classes in the current\nfolder:\n\n Linux\n java -cp $OBERON_BIN oberonc . examples/Hello.Mod\n\n Windows\n java -cp %OBERON_BIN% oberonc . examples/Hello.Mod\n\nThe first argument of oberonc is `.`, this is the existing folder where the\ngenerated class will be written, the next arguments specify module files to\nbe compiled.\n\nThis will generate Hello.class and Hello.smb. The second file is a symbol file,\nit is used only during compilation and enables `oberonc` to perform separate\ncompilation of modules that import Hello. In this simple case Hello.Mod\ndoes not export anything, but the other modules in the `examples` folder do.\n\nTo run Hello.class, you need the OberonRuntime.class and Out.class. These are\npresent in the `bin` folder so they are already in the class path, we just need\nto include the current folder as well to locate Hello.class:\n\n Linux\n java -cp $OBERON_BIN:. Hello\n\n Windows\n java -cp %OBERON_BIN%;. Hello\n\nIf you want to compile and run automatically a simple example called `fern`,\ntype `make runFern`. It should open a window like this one:\n\n![Fern](examples/fern/fern.png)\n\nLastly, `make clean` will delete the output folders generated by `build`,\n`test`, `runFern` and `bootstrapTest`.\n\n## License\n\nThe compiler is distributed under the MIT license found in the LICENSE.txt file.\n" }, { "path": "doc/TypeRules.md", "content": "# Type rules\n\n## Same types [A]\nTwo variables *a* and *b* with types *Ta* and *Tb* are of the *same* type if\n1. *Ta* and *Tb* are both denoted by the same type identifier, or\n2. *Ta* is declared in a type declaration of the form *Ta* = *Tb*, or\n3. *a* and *b* appear in the same identifier list in a variable, record field,\n or formal parameter declaration.\n\n## Equal types [B]\nTwo types *Ta* and *Tb* are *equal* if\n1. *Ta* and *Tb* are the *same* type, or\n2. *Ta* and *Tb* are open array types with *equal* element types, or\n3. *Ta* and *Tb* are array types with *equal* element types and length, or\n4. *Ta* and *Tb* are procedure types whose formal parameter lists *match*, or\n5. *Ta* and *Tb* are pointer types with *equal* base types.\n\n## Matching formal parameter lists [C]\nTwo formal parameter lists *match* if\n1. they have the same number of parameters, and\n2. they have either *equal* function result types or none, and\n3. parameters at corresponding positions have *equal* types, and\n4. parameters at corresponding positions are both either value or VAR\n parameters.\n\n## Type extension (base type) [D]\nGiven a type declaration *Tb* = RECORD (*Ta*) ... END, *Tb* is a\n*direct extension* of *Ta*, and *Ta* is a *direct base type* of *Tb*. A type\n*Tb* is an *extension* of a type *Ta* (*Ta* is a *base type* of *Tb*) if\n1. *Ta* and *Tb* are the *same* types, or\n2. *Tb* is a *direct extension* of an *extension* of *Ta*.\n\nIf *Pa* = POINTER TO *Ta* and *Pb* = POINTER TO *Tb*, *Pb* is an *extension* of\n*Pa* (*Pa* is a *base type* of *Pb*) if *Tb* is an *extension* of *Ta*.\n\n## Assignment compatible [E]\nAn expression *e* of type *Te* is *assignment compatible* with a variable *v*\nof type *Tv* if one of the following conditions hold:\n1. *Te* and *Tv* are *equal* and are not open array types;\n2. *Te* and *Tv* are record types and *Te* is an *extension* of *Tv* and the\n dynamic type of *v* is *Tv*;\n3. *Te* and *Tv* are pointer types and *Te* is an *extension* of *Tv*;\n4. *Tv* is a pointer or a procedure type and *e* is NIL;\n5. *Tv* is array of CHAR, *e* is a string constant with *n* characters,\n and *n* < *LEN(v)*;\n6. *Tv* is ARRAY *n* OF *Ta*, *e* is ARRAY OF *Tb* where *Ta* and *Tb* are\n *equal* and *LEN(e) <= LEN(v)*;\n7. *Tv* is a procedure type and *e* is the name of a procedure whose formal\n parameters *match* those of *Tv*.\n\n## Parameters\n\nLet *f* be the formal parameter and *a* the corresponding actual parameter. If\n*f* is an open array, then *a* must be *array compatible* to *f* and the lengths\nof *f* are taken from *a*. Otherwise *a* must be *parameter compatible* to *f*.\n\n### Array compatible [F]\nAn actual parameter *a* of type *Ta* is *array compatible* with a formal\nparameter *f* of type *Tf* if\n1. *Tf* and *Ta* are *equal* types, or\n2. *Tf* is an open array, *Ta* is any array, and their element types are *array\n compatible*, or\n3. *f* is a value parameter of type ARRAY OF CHAR and *a* is a string.\n\n### Parameter compatible [G]\nAn actual parameter *a* of type *Ta* is *parameter compatible* with a formal\nparameter *f* of type *Tf* if:\n1. *Tf* and *Ta* are *equal* types, or\n2. *f* is a value parameter and *Ta* is *assignment compatible* (except E.5 and\n E.6) with *Tf*, or\n3. *f* is an VAR parameter and *Tf* and *Ta* are record types and *Ta* is an\n *extension* of *Tf*, or\n4. *f* is a parameter of type ARRAY *m* OF BYTE and *Ta* is any type with size\n *n* = *m* bytes.\n\n## RETURN expression [H]\nThe type of the expression must be *assignment compatible* with the result type\nspecified in the procedure heading and can be neither a record nor an array.\n\n## BYTE and INTEGER [I]\nThe type BYTE is compatible with the type INTEGER, and vice versa.\n\n## String and CHAR [J]\nA string of length 1 can be used wherever a character constant is allowed and\nvice versa.\n" }, { "path": "doc/oberon07.g", "content": "// ANTLR v3 grammar\ngrammar oberon07;\n\n// LL(1) with few ambiguities resolved with the help of the symbol table\noptions {k = 1;}\n\nmodule : 'MODULE' IDENT ';' (importList)?\n declarationSequence ('BEGIN' statementSequence)? 'END' IDENT '.' ;\nimportList : 'IMPORT' import_ (',' import_)* ';';\nimport_ : IDENT (':=' IDENT)? ;\nqualident : (IDENT '.')? IDENT;\nidentdef : IDENT ('*')?;\nconstDeclaration : identdef '=' constExpression;\nconstExpression : expression;\ntypeDeclaration : identdef '=' type;\ntype : qualident | arrayType | recordType | pointerType | procedureType;\narrayType : 'ARRAY' length (',' length)* 'OF' type;\nlength : constExpression;\nrecordType : 'RECORD' ('(' baseType ')')? (fieldListSequence)? 'END';\nbaseType : qualident;\nfieldListSequence : fieldList (';' fieldList)*;\nfieldList : identList ':' type;\nidentList : identdef (',' identdef)*;\npointerType : 'POINTER' 'TO' type;\nprocedureType : 'PROCEDURE' (formalParameters)?;\nvariableDeclaration : identList ':' type;\nexpression : simpleExpression (relation simpleExpression)?;\nrelation : '=' | '#' | '<' | '<=' | '>' | '>=' | 'IN' | 'IS';\nsimpleExpression : ('+' | '-')? term (addOperator term)*;\naddOperator : '+' | '-' | 'OR';\nterm : factor (mulOperator factor)*;\nmulOperator : '*' | '/' | 'DIV' | 'MOD' | '&';\nfactor : number | STRING | 'NIL' | 'TRUE' | 'FALSE' | set |\n designator (actualParameters)? | '(' expression ')' | '~' factor;\ndesignator : qualident (selector)*;\nselector : '.' IDENT | '[' expList ']' | '^' | '(' qualident ')';\nset : '{' (element (',' element)*)?'}';\nelement : expression ('..' expression)?;\nexpList : expression (',' expression)*;\nactualParameters : '(' (expList)? ')' ;\nstatement : (assignment | procedureCall | ifStatement | caseStatement |\n whileStatement | repeatStatement | forStatement)?;\nassignment : designator ':=' expression;\nprocedureCall : designator (actualParameters)?;\nstatementSequence : statement (';' statement)*;\nifStatement : 'IF' expression 'THEN' statementSequence\n ('ELSIF' expression 'THEN' statementSequence)*\n ('ELSE' statementSequence)? 'END';\ncaseStatement : 'CASE' expression 'OF' case ('|' case)* 'END';\ncase : (caseLabelList ':' statementSequence)?;\ncaseLabelList : labelRange (',' labelRange)*;\nlabelRange : label ('..' label)?;\nlabel : INTEGER | STRING | qualident;\nwhileStatement : 'WHILE' expression 'DO' statementSequence\n ('ELSIF' expression 'DO' statementSequence)* 'END';\nrepeatStatement : 'REPEAT' statementSequence 'UNTIL' expression;\nforStatement : 'FOR' IDENT ':=' expression 'TO' expression\n ('BY' constExpression)? 'DO' statementSequence 'END';\nprocedureDeclaration : procedureHeading ';' procedureBody IDENT;\nprocedureHeading : 'PROCEDURE' identdef (formalParameters)?;\nprocedureBody : declarationSequence ('BEGIN' statementSequence)?\n ('RETURN 'expression)? 'END';\ndeclarationSequence : ('CONST' (constDeclaration ';')*)?\n ('TYPE' (typeDeclaration ';')*)?\n ('VAR' (variableDeclaration ';')*)?\n (procedureDeclaration ';')*;\nformalParameters : '(' (fpsection (';' fpsection)*)? ')' (':' qualident)?;\nfpsection : ('VAR')? IDENT (',' IDENT)* ':' formalType;\nformalType : ('ARRAY' 'OF')* qualident;\n\nnumber : INTEGER | REAL;\n\nINTEGER : DIGIT (DIGIT)* | DIGIT (HEX_DIGIT)* 'H';\n\nfragment\nSTR : '\"' ( ~('\"') )* '\"' ;\n\nfragment\nDIGIT : ('0'..'9') ;\n\nfragment\nHEX_DIGIT : ('0'..'9'|'a'..'f'|'A'..'F') ;\n\nfragment\nREAL : DIGIT (DIGIT)* '.' (DIGIT)* (SCALE_FACTOR)?;\n\nfragment\nSCALE_FACTOR : 'E' ('+' | '-')? DIGIT (DIGIT)*;\n\nSTRING : STR | DIGIT (HEX_DIGIT)* 'X';\n\nIDENT : ('a'..'z'|'A'..'Z') ('a'..'z'|'A'..'Z'|'0'..'9')* ;\n\nCOMMENT : '(*' ( options {greedy=false;} : . )* '*)' {$channel=HIDDEN;} ;\n\nWS : (' ' | '\\t' | '\\r' | '\\n') {$channel=HIDDEN;} ;\n" }, { "path": "examples/GuessNumber.Mod", "content": "MODULE GuessNumber;\n IMPORT In, Out;\n VAR\n name: ARRAY 20 OF CHAR;\n number, left, right, old: INTEGER;\n choice: CHAR;\n\nPROCEDURE CharLn(VAR ch: CHAR);\nVAR discard: CHAR;\nBEGIN\n In.Char(ch);\n REPEAT\n In.Char(discard)\n UNTIL In.Done & (discard = 0AX);\nEND CharLn;\n\nBEGIN\n Out.String(\"What's your name? \");\n In.String(name);\n Out.String(\"Hi \"); Out.String(name); Out.Char(\"!\"); Out.Ln;\n Out.String(\"Please think of a number from 0 to 50 and I'll guess it.\");\n Out.Ln;\n left := 0;\n right := 50;\n number := 27;\n REPEAT\n REPEAT\n Out.String(\"Is \"); Out.Int(number, 3);\n Out.String(\" the correct number? [(h)igher (l)ower (c)orrect] \");\n CharLn(choice)\n UNTIL In.Done & ((choice = \"h\") OR (choice = \"l\") OR (choice = \"c\"));\n IF choice = \"h\" THEN left := number + 1\n ELSIF choice = \"l\" THEN right := number - 1\n END ;\n old := number;\n number := left + (right - left) DIV 2;\n IF (choice # \"c\") & (number = old) THEN\n Out.Ln; Out.String(\"You lied :)\");\n choice := \"c\"\n END\n UNTIL choice = \"c\";\n Out.Ln\nEND GuessNumber.\n" }, { "path": "examples/Hello.Mod", "content": "MODULE Hello;\n IMPORT Out; (* Import Out to print on the console *)\nBEGIN\n Out.String(\"Hello 世界\");\n Out.Ln (* print a new line *)\nEND Hello.\n" }, { "path": "examples/Powers.Mod", "content": "MODULE Powers; (*Tabulate positive and negative powers of 2*)\n IMPORT Out, Util;\n CONST N = 32; M = 11; (*M ~ N*log2*)\n\n PROCEDURE Power(n: INTEGER);\n VAR i, k, exp: INTEGER;\n c, r, t: INTEGER;\n d: ARRAY M OF INTEGER;\n f: ARRAY N OF INTEGER;\n BEGIN\n d[0] := 1; k := 1; exp := 1;\n WHILE exp < n DO\n (*compute d = 2^exp*)\n c := 0; (*carry*) i := 0;\n WHILE i < k DO\n t := 2*d[i] + c;\n IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ;\n i := i+1\n END ;\n IF c = 1 THEN d[k] := 1; k := k+1 END ;\n (*write d*) i := M;\n WHILE i > k DO i := i-1; Out.Char(\" \") END ;\n WHILE i > 0 DO i := i-1; Out.Char(CHR(d[i] + ORD(\"0\"))) END ;\n Out.Int(exp, 5);\n (*compute f = 2^-exp*)\n Out.String(\" \"); Out.Char(\"0\"); Out.Char(\".\");\n r := 0; i := 1;\n WHILE i < exp DO\n r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2;\n Out.Char(CHR(f[i] + ORD(\"0\"))); i := i+1\n END ;\n f[exp] := 5; Out.Char(\"5\"); Out.Ln; exp := exp + 1\n END\n END Power;\n\n PROCEDURE Main;\n VAR n, i: INTEGER;\n arg: ARRAY 3 OF CHAR;\n BEGIN\n n := ARGNUM();\n IF n # 1 THEN\n Out.String(\"usage: Powers number in [0..32]\");\n Out.Ln\n ELSE\n ARGS(0, arg);\n i := Util.strToInt(arg);\n IF i <= 32 THEN Power(i) END\n END\n END Main;\nEND Powers.\n" }, { "path": "examples/PrimeNumbers.Mod", "content": "MODULE PrimeNumbers; (*Tabulate prime numbers*)\n IMPORT Out, Util;\n\n PROCEDURE Primes(n: INTEGER);\n VAR i, k, m, x, inc, lim, sqr: INTEGER;\n prim: BOOLEAN;\n p: ARRAY 400 OF INTEGER;\n v: ARRAY 20 OF INTEGER;\n BEGIN\n x := 1; inc := 4;\n lim := 1; sqr := 4;\n m := 0; i := 3;\n WHILE i <= n DO\n REPEAT x := x + inc; inc := 6 - inc;\n IF sqr <= x THEN (*sqr = p[lim]^2*)\n v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim]\n END ;\n k := 2; prim := TRUE;\n WHILE prim & (k < lim) DO\n k := k+1;\n IF v[k] < x THEN v[k] := v[k] + p[k] END ;\n prim := x # v[k]\n END\n UNTIL prim;\n p[i] := x; Out.Int(x, 5);\n IF m = 10 THEN Out.Ln; m := 0 ELSE m := m+1 END ;\n i := i+1\n END ;\n IF m > 0 THEN Out.Ln END\n END Primes;\n\n PROCEDURE Main;\n VAR n: INTEGER;\n arg: ARRAY 3 OF CHAR;\n BEGIN\n n := ARGNUM();\n IF n # 1 THEN\n Out.String(\"usage: PrimeNumbers number in [0..99]\");\n Out.Ln\n ELSE\n ARGS(0, arg);\n Primes(Util.strToInt(arg))\n END\n END Main;\nEND PrimeNumbers.\n" }, { "path": "examples/Util.Mod", "content": "MODULE Util;\n\n PROCEDURE strToInt*(str: ARRAY OF CHAR): INTEGER;\n VAR res, i, x: INTEGER;\n BEGIN\n res := 0;\n FOR i := 0 TO LEN(str)-1 DO\n x := ORD(str[i]) - ORD(\"0\");\n IF (x >= 0) & (x <= 9) THEN res := res * 10 + x END\n END\n RETURN res\n END strToInt;\n\nEND Util.\n\n" }, { "path": "examples/fern/IFS.Mod", "content": "MODULE IFS;\n IMPORT RandomNumbers, XYplane;\n\n VAR\n a1, b1, c1, d1, e1, f1, p1: REAL; (* IFS parameters *)\n a2, b2, c2, d2, e2, f2, p2: REAL; (* IFS parameters *)\n a3, b3, c3, d3, e3, f3, p3: REAL; (* IFS parameters *)\n a4, b4, c4, d4, e4, f4, p4: REAL; (* IFS parameters *)\n X, Y: REAL; (* the position of the pen *)\n x0: INTEGER; (* Distance of origin fm left edge[pixels] *)\n y0: INTEGER; (* Distance of origin from bottom edge[pixels] *)\n e: INTEGER; (* Size of unit interval [pixels] *)\n\n PROCEDURE Draw;\n VAR\n x, y: REAL; (* new position *)\n xi, eta: INTEGER; (* pixel coordinates of pen *)\n rn: REAL;\n i : INTEGER;\n BEGIN\n i := 0;\n REPEAT\n rn := RandomNumbers.Uniform();\n IF rn < p1 THEN\n x := a1 * X + b1 * Y + e1; y := c1 * X + d1 * Y + f1\n ELSIF rn < (p1 + p2) THEN\n x := a2 * X + b2 * Y + e2; y := c2 * X + d2 * Y + f2\n ELSIF rn < (p1 + p2 + p3) THEN\n x := a3 * X + b3 * Y + e3; y := c3 * X + d3 * Y + f3\n ELSE\n x := a4 * X + b4 * Y + e4; y := c4 * X + d4 * Y + f4\n END;\n X := x; xi := x0 + FLOOR(X*FLT(e));\n Y := y; eta := y0 + FLOOR(Y*FLT(e));\n XYplane.Dot(xi, eta, XYplane.draw);\n INC(i)\n UNTIL i = 100000\n END Draw;\n\n PROCEDURE Init;\n BEGIN\n X := 0.0; Y := 0.0; (* Initial position of pen *)\n RandomNumbers.InitSeed(1);\n x0 := 320; y0 := 75; e := 64;\n a1 := 0.0; a2 := 0.85; a3 := 0.2; a4 := -0.15;\n b1 := 0.0; b2 := 0.04; b3 := -0.26; b4 := 0.28;\n c1 := 0.0; c2 := -0.04; c3 := 0.23; c4 := 0.26;\n d1 := 0.16; d2 := 0.85; d3 := 0.22; d4 := 0.24;\n e1 := 0.0; e2 := 0.0; e3 := 0.0; e4 := 0.0;\n f1 := 0.0; f2 := 1.6; f3 := 1.6; f4 := 0.44;\n p1 := 0.01; p2 := 0.85; p3 := 0.07; p4 := 0.07;\n END Init;\n\nBEGIN\n XYplane.Open; Init; Draw\nEND IFS.\n" }, { "path": "examples/fern/RandomNumbers.Mod", "content": "MODULE RandomNumbers;\n IMPORT Math;\n\n VAR Z: INTEGER;\n\n PROCEDURE Uniform*(): REAL;\n CONST\n a = 16807; m = 2147483647;\n q = m DIV a; r = m MOD a;\n VAR g: INTEGER;\n BEGIN\n g := a*(Z MOD q) - r*(Z DIV q);\n IF g > 0 THEN Z := g ELSE Z := g + m END;\n RETURN FLT(Z)*(1.0/FLT(m))\n END Uniform;\n\n PROCEDURE Exp*(mu: REAL): REAL;\n BEGIN\n RETURN -Math.ln(Uniform())/mu\n END Exp;\n\n PROCEDURE InitSeed*(seed: INTEGER);\n BEGIN\n Z := seed\n END InitSeed;\n\nBEGIN\n Z := 1;\nEND RandomNumbers.\n" }, { "path": "examples/fern/XYplane.Mod", "content": "DEFINITION XYplane; \n CONST erase = 0; draw = 1;\n VAR X, Y, W, H: INTEGER;\n\n PROCEDURE Open;\n PROCEDURE Dot(x, y, mode: INTEGER);\n PROCEDURE IsDot(x, y: INTEGER): BOOLEAN;\n PROCEDURE Key(): CHAR;\n PROCEDURE Clear;\nEND XYplane." }, { "path": "examples/fern/java/XYplane.java", "content": "import java.awt.Color;\nimport java.awt.Dimension;\nimport java.awt.Graphics;\nimport java.awt.Graphics2D;\nimport java.awt.image.BufferedImage;\nimport javax.swing.JFrame;\nimport javax.swing.JPanel;\nimport javax.swing.WindowConstants;\n\npublic final class XYplane {\n public static final int erase = 0;\n public static final int draw = 1;\n public static int X, Y, W, H;\n private static char key;\n private static Viewer viewer;\n private static final int white = Color.WHITE.getRGB();\n private static final int black = Color.BLACK.getRGB();\n\n // Ensure non-instantiability\n private XYplane() {}\n\n public static void Open() {\n W = 800;\n H = 800;\n JFrame frame = new JFrame(\"XYPlane\");\n viewer = new Viewer(W, H);\n frame.add(viewer);\n frame.pack();\n frame.setVisible(true);\n frame.setResizable(false);\n frame.setDefaultCloseOperation(WindowConstants.EXIT_ON_CLOSE);\n }\n\n public static void Dot(int x, int y, int mode) {\n y = H - y - 1;\n if(mode == erase) {\n viewer.canvas.setRGB(x, y, black);\n } else {\n viewer.canvas.setRGB(x, y, white);\n }\n viewer.updateUI();\n }\n\n public static boolean isDot(int x, int y) {\n y = H - y - 1;\n return viewer.canvas.getRGB(x, y) == white;\n }\n\n public static char Key() {\n return key;\n }\n\n public static void Clear() {\n viewer.fillCanvas(black);\n }\n\n private static class Viewer extends JPanel {\n private BufferedImage canvas;\n\n public Viewer(int width, int height) {\n canvas = new BufferedImage(width, height, BufferedImage.TYPE_INT_ARGB);\n fillCanvas(black);\n setFocusable(true);\n requestFocus(true);\n }\n\n public Dimension getPreferredSize() {\n return new Dimension(canvas.getWidth(), canvas.getHeight());\n }\n\n public void paintComponent(Graphics g) {\n super.paintComponent(g);\n Graphics2D g2 = (Graphics2D) g;\n g2.drawImage(canvas, null, null);\n }\n\n public void fillCanvas(int color) {\n for(int x = 0; x < canvas.getWidth(); x++) {\n for(int y = 0; y < canvas.getHeight(); y++) {\n canvas.setRGB(x, y, color);\n }\n }\n repaint();\n }\n }\n}\n" }, { "path": "make.bat", "content": "@echo off\r\n\r\nset JAVA_SOURCES=src/java/Files_FileDesc.java src/java/Files.java src/java/OberonRuntime.java src/java/Os.java src/java/Out.java src/java/In.java src/java/Math.java\r\nset MOD_SOURCES=src/Out.Mod src/Os.Mod src/Files.Mod src/Strings.Mod src/OJS.Mod src/CpCache.Mod src/Opcodes.Mod src/ClassFormat.Mod src/OJB.Mod src/OJG.Mod src/OJP.Mod src/oberonc.Mod src/In.Mod src/Math.Mod\r\n\r\nset OBERON_BIN=./bin\r\n\r\nif \"%~1\"==\"\" goto build\r\nif \"%~1\"==\"build\" goto build\r\nif \"%~1\"==\"bootstrap\" goto bootstrap\r\nif \"%~1\"==\"runFern\" goto runFern\r\nif \"%~1\"==\"test\" goto test\r\nif \"%~1\"==\"clean\" goto clean\r\n\r\necho \"%~1\": invalid target\r\ngoto end\r\n\r\n:build\r\nmkdir \"out/\"\r\njavac -d out %JAVA_SOURCES%\r\njava -cp %OBERON_BIN% oberonc out %MOD_SOURCES%\r\necho build done\r\ngoto end\r\n\r\n:bootstrap\r\njavac -d bin %JAVA_SOURCES%\r\njava -cp %OBERON_BIN% oberonc bin %MOD_SOURCES%\r\necho bootstrap done\r\ngoto end\r\n\r\n:runFern\r\nmkdir \"examples/fern/out/\"\r\njavac -cp %OBERON_BIN% -d examples/fern/out examples/fern/java/*.java\r\njava -cp %OBERON_BIN% oberonc examples/fern/out examples/fern/RandomNumbers.Mod examples/fern/XYplane.Mod examples/fern/IFS.Mod\r\njava -cp %OBERON_BIN%;examples/fern/out IFS\r\ngoto end\r\n\r\n:test\r\nmkdir \"tests/out/\"\r\njavac -cp %OBERON_BIN% -d tests/out tests/TestRunner.java\r\njava -Dfile.encoding=UTF-8 -cp %OBERON_BIN%;tests/out TestRunner\r\ngoto end\r\n\r\n:clean\r\nrmdir out /s /q\r\nrmdir tests\\out /s /q\r\nrmdir examples\\fern\\out /s /q\r\n\r\n:end\r\n\r\n" }, { "path": "src/ClassFormat.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*\n This module deals with the low level generation of a class file according to\n the Java Virtual Machine Specification. It uses CpCache to keep track of the\n constant pool entries written so far in the CFDesc record.\n*)\nMODULE ClassFormat;\n IMPORT Strings, Files, CpCache, Opcodes, OJS;\n\n CONST\n nestedIdLen* = 5;\n CpMax = 10000H;\n DescLenMax = 500;\n FieldsMax = CpMax;\n LineNumTabMax = CpMax;\n CodeMax = CpMax;\n MethodsMax = 34 + LineNumTabMax + CodeMax;\n ClassMax = 32 + CpMax + MethodsMax + FieldsMax;\n ShortMaxValue = 32767;\n UTF8 = 1;\n CLASS = 7;\n NAMExTYPE = 12;\n METH = 10;\n FIELD = 9;\n STR = 8;\n INT* = 3;\n FLOAT* = 4;\n\n TYPE\n Descriptor* = ARRAY DescLenMax OF CHAR;\n CF* = POINTER TO CFDesc;\n CFDesc = RECORD\n constantPool: ARRAY CpMax OF BYTE;\n cpCount, cpIndex: INTEGER;\n access: INTEGER;\n thisIndex, superIndex, sourceFileIndex: INTEGER;\n methods: ARRAY MethodsMax OF BYTE;\n methIndex, methCount: INTEGER;\n fields: ARRAY FieldsMax OF BYTE;\n fieldsIndex, fieldsCount: INTEGER;\n cpCache, procMap: CpCache.Cache;\n END;\n MethodInfo* = POINTER TO MethodInfoDesc;\n MethodInfoDesc = RECORD\n cf: CF;\n access: INTEGER;\n name: ARRAY OJS.IdLen + nestedIdLen OF CHAR;\n descriptor: ARRAY DescLenMax OF CHAR;\n code: ARRAY CodeMax OF BYTE;\n i*: INTEGER;\n maxStack, curStack*, maxLocals: INTEGER;\n lineNumTab: ARRAY LineNumTabMax OF BYTE;\n lineIndex: INTEGER;\n END;\n\n VAR classMap: CpCache.Cache;\n\n PROCEDURE Init*;\n BEGIN\n NEW(classMap)\n END Init;\n\n PROCEDURE lengthUTF8(s: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER;\n VAR\n i,j, length: INTEGER;\n c: CHAR;\n BEGIN\n length := LEN(s);\n i := 0;\n j := 0;\n WHILE (j < length) & (s[j] # 0X) DO\n c := s[j];\n IF (c >= 1X) & (c <= 7FX) THEN INC(i)\n ELSIF c > 7FFX THEN INC(i,3)\n ELSE INC(i, 2)\n END;\n INC(j);\n END;\n IF add0X THEN INC(i, 2) END\n RETURN i\n END lengthUTF8;\n\n PROCEDURE putUTF8(VAR buf: ARRAY OF BYTE; i: INTEGER; s: ARRAY OF CHAR;\n add0X: BOOLEAN): INTEGER;\n VAR\n j, c, slen, buflen: INTEGER;\n BEGIN\n slen := LEN(s);\n buflen := LEN(buf);\n j := 0;\n WHILE (j < slen) & (ORD(s[j]) # 0H) DO\n c := ORD(s[j]);\n IF (c >= 1H) & (c <= 7FH) & (i < buflen) THEN\n buf[i] := c;\n INC(i)\n ELSIF (c > 7FFH) & (i+2 < buflen) THEN\n buf[i] := BOR(0E0H, AND(ASR(c, 12), 0FH));\n buf[i+1] := BOR(80H, AND(ASR(c, 6), 3FH));\n buf[i+2] := BOR(80H, AND(c, 3FH));\n INC(i, 3)\n ELSIF (c >= 80H) & (c <= 7FFH) & (i+1 < buflen) THEN\n buf[i] := BOR(0C0H, AND(ASR(c, 6), 1FH));\n buf[i+1] := BOR(80H, AND(c, 3FH));\n INC(i, 2)\n ELSE\n OJS.Mark(\"Class file buffer limit reached\");\n j := slen\n END;\n INC(j);\n END;\n IF add0X & (i+1 < buflen) THEN\n buf[i] := 0C0H;\n buf[i+1] := 80H;\n INC(i, 2)\n END\n RETURN i\n END putUTF8;\n\n PROCEDURE putByte(VAR buf: ARRAY OF BYTE; i, x: INTEGER): INTEGER;\n BEGIN\n IF i < LEN(buf) THEN\n buf[i] := x;\n INC(i)\n ELSE OJS.Mark(\"Class file buffer limit reached\") END\n RETURN i\n END putByte;\n\n PROCEDURE putNBytes(VAR buf: ARRAY OF BYTE; i: INTEGER; x: BYTE;\n n: INTEGER): INTEGER;\n BEGIN\n n := n + i;\n IF n-1 < LEN(buf) THEN\n WHILE(i < n) DO\n buf[i] := x;\n INC(i)\n END\n ELSE OJS.Mark(\"Class file buffer limit reached\") END\n RETURN i\n END putNBytes;\n\n PROCEDURE putInt(VAR buf: ARRAY OF BYTE; i, x: INTEGER): INTEGER;\n BEGIN\n IF i+3 < LEN(buf) THEN\n buf[i] := ASR(x, 24);\n buf[i+1] := ASR(x, 16);\n buf[i+2] := ASR(x, 8);\n buf[i+3] := x;\n INC(i, 4)\n ELSE OJS.Mark(\"Class file buffer limit reached\") END\n RETURN i\n END putInt;\n\n PROCEDURE putShort(VAR buf: ARRAY OF BYTE; i, x: INTEGER): INTEGER;\n BEGIN\n IF i+1 < LEN(buf) THEN\n buf[i] := ASR(x, 8);\n buf[i+1] := x;\n INC(i, 2)\n ELSE OJS.Mark(\"Class file buffer limit reached\") END\n RETURN i\n END putShort;\n\n PROCEDURE putArray(VAR buf: ARRAY OF BYTE; i: INTEGER; x: ARRAY OF BYTE;\n len: INTEGER): INTEGER;\n VAR j: INTEGER;\n BEGIN\n j := 0;\n IF i+len-1 < LEN(buf) THEN\n WHILE j < len DO\n buf[i+j] := x[j];\n INC(j)\n END;\n INC(i, j)\n ELSE OJS.Mark(\"Class file buffer limit reached\") END\n RETURN i\n END putArray;\n\n PROCEDURE cpWriteUTF8(cf: CF; s: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER;\n VAR\n i, z: INTEGER;\n key: CpCache.Key;\n BEGIN\n z := Strings.Write(s, key, 0);\n IF add0X THEN\n z := Strings.WriteChar(\"$\", key, z)\n END;\n z := Strings.WriteInt(UTF8, 0, key, z);\n IF z = -1 THEN\n OJS.Mark(\"internal cache buffer limit reached\")\n END;\n i := CpCache.get(cf.cpCache, key);\n IF i = -1 THEN\n i := cf.cpCount;\n cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, UTF8);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, lengthUTF8(s, add0X));\n cf.cpIndex := putUTF8(cf.constantPool, cf.cpIndex, s, add0X);\n INC(cf.cpCount);\n CpCache.put(cf.cpCache, key, i);\n END\n RETURN i\n END cpWriteUTF8;\n\n PROCEDURE cpWriteClass(cf: CF; s: ARRAY OF CHAR): INTEGER;\n VAR\n i, j, z: INTEGER;\n key: CpCache.Key;\n BEGIN\n z := Strings.Write(s, key, 0);\n z := Strings.WriteInt(CLASS, 0, key, z);\n IF z = -1 THEN\n OJS.Mark(\"internal cache buffer limit reached\")\n END;\n j := CpCache.get(cf.cpCache, key);\n IF j = -1 THEN\n i := cpWriteUTF8(cf, s, FALSE);\n j := cf.cpCount;\n cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, CLASS);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i);\n INC(cf.cpCount);\n CpCache.put(cf.cpCache, key, j)\n END\n RETURN j\n END cpWriteClass;\n\n PROCEDURE cpWriteNameAndType(cf: CF; name, desc: ARRAY OF CHAR): INTEGER;\n VAR\n i, j, k, z: INTEGER;\n key: CpCache.Key;\n BEGIN\n z := Strings.Write(name, key, 0);\n z := Strings.Write(desc, key, z);\n z := Strings.WriteInt(NAMExTYPE, 0, key, z);\n IF z = -1 THEN\n OJS.Mark(\"internal cache buffer limit reached\")\n END;\n k := CpCache.get(cf.cpCache, key);\n IF k = -1 THEN\n i := cpWriteUTF8(cf, name, FALSE);\n j := cpWriteUTF8(cf, desc, FALSE);\n k := cf.cpCount;\n cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, NAMExTYPE);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, j);\n INC(cf.cpCount);\n CpCache.put(cf.cpCache, key, k)\n END\n RETURN k\n END cpWriteNameAndType;\n\n PROCEDURE cpWriteString(cf: CF; val: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER;\n VAR\n i, j, z: INTEGER;\n key: CpCache.Key;\n BEGIN\n z := Strings.Write(val, key, 0);\n IF add0X THEN\n z := Strings.WriteChar(\"$\", key, z)\n END;\n z := Strings.WriteInt(STR, 0, key, z);\n IF z = -1 THEN\n OJS.Mark(\"internal cache buffer limit reached\")\n END;\n j := CpCache.get(cf.cpCache, key);\n IF j = -1 THEN\n i := cpWriteUTF8(cf, val, add0X);\n j := cf.cpCount;\n cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, STR);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i);\n INC(cf.cpCount);\n CpCache.put(cf.cpCache, key, j)\n END\n RETURN j\n END cpWriteString;\n\n PROCEDURE cpWriteConst(cf: CF; tag, val: INTEGER): INTEGER;\n VAR\n i, z: INTEGER;\n key: CpCache.Key;\n BEGIN\n z := Strings.WriteInt(tag, 0, key, 0);\n z := Strings.WriteInt(val, 0, key, z);\n IF z = -1 THEN\n OJS.Mark(\"internal cache buffer limit reached\")\n END;\n i := CpCache.get(cf.cpCache, key);\n IF i = -1 THEN\n i := cf.cpCount;\n cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, tag);\n cf.cpIndex := putInt(cf.constantPool, cf.cpIndex, val);\n INC(cf.cpCount);\n CpCache.put(cf.cpCache, key, i)\n END\n RETURN i\n END cpWriteConst;\n\n PROCEDURE cpWriteRef(cf: CF; tag: INTEGER;\n owner, name, desc: ARRAY OF CHAR): INTEGER;\n VAR\n i, j, k, z: INTEGER;\n key: CpCache.Key;\n BEGIN\n z := Strings.Write(owner, key, 0);\n z := Strings.Write(name, key, z);\n z := Strings.Write(desc, key, z);\n z := Strings.WriteInt(tag, 0, key, z);\n IF z = -1 THEN\n OJS.Mark(\"internal cache buffer limit reached\")\n END;\n k := CpCache.get(cf.cpCache, key);\n IF k = -1 THEN\n i := cpWriteClass(cf, owner);\n j := cpWriteNameAndType(cf, name, desc);\n k := cf.cpCount;\n cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, tag);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i);\n cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, j);\n INC(cf.cpCount);\n CpCache.put(cf.cpCache, key, k)\n END\n RETURN k\n END cpWriteRef;\n\n PROCEDURE cpWriteFiledRef(cf: CF; owner, name, desc: ARRAY OF CHAR): INTEGER;\n RETURN cpWriteRef(cf, FIELD, owner, name, desc)\n END cpWriteFiledRef;\n\n PROCEDURE cpWriteMethodRef(cf: CF; owner, name, desc: ARRAY OF CHAR): INTEGER;\n RETURN cpWriteRef(cf, METH, owner, name, desc)\n END cpWriteMethodRef;\n\n PROCEDURE addField*(cf: CF; access: INTEGER; name, desc: ARRAY OF CHAR);\n BEGIN\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, access);\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex,\n cpWriteUTF8(cf, name, FALSE));\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex,\n cpWriteUTF8(cf, desc, FALSE));\n (* attribute_count *)\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, 0);\n INC(cf.fieldsCount)\n END addField;\n\n PROCEDURE addConstField*(cf: CF; name, desc: ARRAY OF CHAR; val: INTEGER);\n VAR i: INTEGER;\n BEGIN\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex,\n Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL +\n Opcodes.ACCxSTATIC);\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex,\n cpWriteUTF8(cf, name, FALSE));\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex,\n cpWriteUTF8(cf, desc, FALSE));\n (* attribute_count: ConstantValue *)\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, 1);\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex,\n cpWriteUTF8(cf, \"ConstantValue\", FALSE));\n cf.fieldsIndex := putInt(cf.fields, cf.fieldsIndex, 2);\n IF desc[0] = \"F\" THEN\n i := cpWriteConst(cf, FLOAT, val)\n ELSE\n i := cpWriteConst(cf, INT, val)\n END;\n cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, i);\n INC(cf.fieldsCount)\n END addConstField;\n\n PROCEDURE finalizeMethod*(cf: CF; mi: MethodInfo);\n BEGIN\n cf.methIndex := putShort(cf.methods, cf.methIndex, mi.access);\n cf.methIndex := putShort(cf.methods, cf.methIndex,\n cpWriteUTF8(cf, mi.name, FALSE));\n cf.methIndex := putShort(cf.methods, cf.methIndex,\n cpWriteUTF8(cf, mi.descriptor, FALSE));\n IF AND(mi.access, Opcodes.ACCxABSTRACT) = 0 THEN (* is abstract? *)\n (* attribute_count: code *)\n cf.methIndex := putShort(cf.methods, cf.methIndex, 1);\n cf.methIndex := putShort(cf.methods, cf.methIndex,\n cpWriteUTF8(cf, \"Code\", FALSE));\n (* attribute_length *)\n cf.methIndex := putInt(cf.methods, cf.methIndex,\n 20 + mi.i + mi.lineIndex);\n cf.methIndex := putShort(cf.methods, cf.methIndex, mi.maxStack);\n cf.methIndex := putShort(cf.methods, cf.methIndex, mi.maxLocals);\n cf.methIndex := putInt(cf.methods, cf.methIndex, mi.i);\n cf.methIndex := putArray(cf.methods, cf.methIndex, mi.code, mi.i);\n (* exception_table_length *)\n cf.methIndex := putShort(cf.methods, cf.methIndex, 0);\n (* attribute_count: LineNumberTable *)\n cf.methIndex := putShort(cf.methods, cf.methIndex, 1);\n cf.methIndex := putShort(cf.methods, cf.methIndex,\n cpWriteUTF8(cf, \"LineNumberTable\", FALSE));\n (* attribute_length *)\n cf.methIndex := putInt(cf.methods, cf.methIndex, 2 + mi.lineIndex);\n (* line_number_table_length *)\n cf.methIndex := putShort(cf.methods, cf.methIndex, mi.lineIndex DIV 4);\n cf.methIndex := putArray(cf.methods, cf.methIndex,\n mi.lineNumTab, mi.lineIndex)\n ELSE\n (* attribute_count: code *)\n cf.methIndex := putShort(cf.methods, cf.methIndex, 0)\n END;\n INC(cf.methCount)\n END finalizeMethod;\n\n PROCEDURE toFile*(cf: CF; path: ARRAY OF CHAR);\n VAR\n out: ARRAY ClassMax OF BYTE;\n i, err, sourceFile: INTEGER;\n f: Files.File;\n BEGIN\n (* CpCache.debug(cf.cpCache); *)\n sourceFile := cpWriteUTF8(cf, \"SourceFile\", FALSE);\n i := putInt(out, 0, 0CAFEBABEH); (* magic *)\n i := putInt(out, i, 49); (* Java 1.5 *)\n i := putShort(out, i, cf.cpCount);\n i := putArray(out, i, cf.constantPool, cf.cpIndex);\n i := putShort(out, i, cf.access);\n i := putShort(out, i, cf.thisIndex);\n i := putShort(out, i, cf.superIndex);\n i := putShort(out, i, 0); (* interfaces_count *)\n i := putShort(out, i, cf.fieldsCount);\n i := putArray(out, i, cf.fields, cf.fieldsIndex);\n i := putShort(out, i, cf.methCount);\n i := putArray(out, i, cf.methods, cf.methIndex);\n i := putShort(out, i, 1); (* attributes_count: SourceFile *)\n i := putShort(out, i, sourceFile);\n i := putInt(out, i, 2); (* attribute_length *)\n i := putShort(out, i, cf.sourceFileIndex);\n err := Files.IOERROR;\n IF OJS.errcnt = 0 THEN\n f := Files.Create(path);\n IF f # NIL THEN\n Files.WriteNBytes(f, out, i);\n Files.Close(f);\n err := Files.Status(f)\n END\n END;\n IF (err # Files.OK) & (OJS.errcnt = 0) THEN\n OJS.MarkAppend(\"Failed to write \", path)\n END\n END toFile;\n\n PROCEDURE NewCF*(acc: INTEGER; n, sn: ARRAY OF CHAR): CF;\n VAR\n cf: CF;\n className: Descriptor;\n BEGIN\n NEW(cf);\n Strings.Append(n, className);\n Strings.Append(\".Mod\", className);\n cf.access := acc;\n cf.cpCount := 1;\n cf.cpCache := CpCache.New();\n cf.procMap := CpCache.New();\n cf.methCount := 0;\n cf.fieldsCount := 0;\n cf.thisIndex := cpWriteClass(cf, n);\n cf.sourceFileIndex := cpWriteUTF8(cf, className, FALSE);\n cf.superIndex := cpWriteClass(cf, sn);\n IF CpCache.get(classMap, n) = 1 THEN\n OJS.Mark(\"type names must be unique\")\n ELSE\n CpCache.put(classMap, n, 1)\n END\n RETURN cf\n END NewCF;\n\n PROCEDURE NewMI*(classFormat: CF; acc: INTEGER;\n n, desc: ARRAY OF CHAR): MethodInfo;\n VAR mi: MethodInfo;\n BEGIN\n NEW(mi);\n mi.cf := classFormat;\n mi.access := acc;\n mi.name := n;\n mi.descriptor := desc;\n mi.maxStack := 0;\n mi.maxLocals := 0;\n mi.curStack := 0;\n mi.lineIndex := 0;\n mi.i := 0;\n IF CpCache.get(mi.cf.procMap, mi.name) = 1 THEN\n OJS.Mark(\"procedure names must be unique\")\n ELSE\n CpCache.put(mi.cf.procMap, mi.name, 1)\n END\n RETURN mi\n END NewMI;\n\n PROCEDURE setMaxStack(mi: MethodInfo);\n BEGIN\n IF mi.curStack > mi.maxStack THEN\n mi.maxStack := mi.curStack\n END\n END setMaxStack;\n\n PROCEDURE fix(mi: MethodInfo; at, with: INTEGER);\n VAR x: INTEGER;\n BEGIN\n x := putShort(mi.code, at+1, with)\n END fix;\n\n PROCEDURE FixLink*(mi: MethodInfo; L: INTEGER);\n VAR L1: INTEGER;\n BEGIN\n WHILE (L # 0) & (OJS.errcnt = 0) DO\n L1 := BOR(LSL(mi.code[L + 1], 8), mi.code[L + 2]);\n fix(mi, L, mi.i-L);\n L := L1\n END\n END FixLink;\n\n PROCEDURE FixLinkWith*(mi: MethodInfo; L0, dst: INTEGER);\n VAR L1: INTEGER;\n BEGIN\n WHILE (L0 # 0) & (OJS.errcnt = 0) DO\n L1 := BOR(LSL(mi.code[L0 + 1], 8), mi.code[L0 + 2]);\n fix(mi, L0, dst-L0);\n L0 := L1\n END\n END FixLinkWith;\n\n PROCEDURE merged*(mi: MethodInfo; L0, L1: INTEGER): INTEGER;\n VAR L2, L3: INTEGER;\n BEGIN\n IF L0 # 0 THEN\n L3 := L0;\n REPEAT\n L2 := L3;\n L3 := BOR(LSL(mi.code[L2 + 1], 8), mi.code[L2 + 2]);\n UNTIL L3 = 0;\n fix(mi, L2, L1);\n L1 := L0\n END\n RETURN L1\n END merged;\n\n PROCEDURE putMethodInsn*(mi: MethodInfo; opcode: INTEGER;\n owner, name, desc: ARRAY OF CHAR; args: INTEGER);\n BEGIN\n IF (opcode = Opcodes.INVOKEVIRTUAL) OR\n (opcode = Opcodes.INVOKESPECIAL) OR\n (opcode = Opcodes.INVOKEINTERFACE) THEN\n mi.curStack := mi.curStack - (args + 1)\n ELSE\n mi.curStack := mi.curStack - args;\n END;\n IF desc[Strings.Length(desc)-1] # \"V\" THEN\n INC(mi.curStack)\n END;\n setMaxStack(mi);\n mi.i := putByte(mi.code, mi.i, opcode);\n mi.i := putShort(mi.code, mi.i, cpWriteMethodRef(mi.cf, owner, name, desc));\n END putMethodInsn;\n\n PROCEDURE addLineNumber*(mi: MethodInfo; line: INTEGER);\n BEGIN\n mi.lineIndex := putShort(mi.lineNumTab, mi.lineIndex, mi.i);\n mi.lineIndex := putShort(mi.lineNumTab, mi.lineIndex, line)\n END addLineNumber;\n\n PROCEDURE incStack(mi: MethodInfo; opcode: INTEGER);\n BEGIN\n CASE opcode OF\n Opcodes.AALOAD, Opcodes.ASTORE, Opcodes.ATHROW, Opcodes.BALOAD,\n Opcodes.CALOAD, Opcodes.D2I, Opcodes.FADD, Opcodes.FALOAD,\n Opcodes.FCMPG, Opcodes.FCMPL, Opcodes.FDIV, Opcodes.FMUL,\n Opcodes.FSTORE, Opcodes.FSUB, Opcodes.IADD, Opcodes.IALOAD,\n Opcodes.IAND, Opcodes.IFEQ, Opcodes.IFGE, Opcodes.IFGT,\n Opcodes.IFLE, Opcodes.IFLT, Opcodes.IFNE, Opcodes.IFNONNULL,\n Opcodes.IFNULL, Opcodes.IMUL, Opcodes.IOR, Opcodes.ISHL,\n Opcodes.ISHR, Opcodes.ISTORE, Opcodes.ISUB, Opcodes.IXOR,\n Opcodes.POP, Opcodes.PUTSTATIC, Opcodes.TABLESWITCH:\n INC(mi.curStack, -1)\n | Opcodes.IFACMPEQ, Opcodes.IFACMPNE, Opcodes.IFICMPEQ,\n Opcodes.IFICMPGE, Opcodes.IFICMPGT, Opcodes.IFICMPLE,\n Opcodes.IFICMPLT, Opcodes.IFICMPNE, Opcodes.POP2,\n Opcodes.PUTFIELD:\n INC(mi.curStack, -2)\n | Opcodes.AASTORE, Opcodes.BASTORE, Opcodes.CASTORE,\n Opcodes.FASTORE, Opcodes.IASTORE:\n INC(mi.curStack, -3)\n | Opcodes.DUP2:\n INC(mi.curStack, 2)\n | Opcodes.ACONSTNULL, Opcodes.ALOAD, Opcodes.BIPUSH,\n Opcodes.DUP, Opcodes.F2D, Opcodes.FCONST0, Opcodes.FCONST1,\n Opcodes.FCONST2, Opcodes.FLOAD, Opcodes.GETSTATIC,\n Opcodes.ICONSTM1, Opcodes.ICONST0, Opcodes.ICONST1,\n Opcodes.ICONST2, Opcodes.ICONST3, Opcodes.ICONST4,\n Opcodes.ICONST5, Opcodes.ILOAD, Opcodes.LDC, Opcodes.NEW,\n Opcodes.SIPUSH:\n INC(mi.curStack, 1)\n | Opcodes.ANEWARRAY, Opcodes.ARETURN, Opcodes.ARRAYLENGTH,\n Opcodes.CHECKCAST, Opcodes.FNEG, Opcodes.FRETURN,\n Opcodes.GETFIELD, Opcodes.GOTO, Opcodes.I2F, Opcodes.IINC,\n Opcodes.INEG, Opcodes.INSTANCEOF, Opcodes.IRETURN,\n Opcodes.NEWARRAY, Opcodes.RETURNx, Opcodes.SWAP:\n (* nothing to do *)\n END;\n setMaxStack(mi)\n END incStack;\n\n PROCEDURE putTypeInsn*(mi: MethodInfo; opcode: INTEGER; type: ARRAY OF CHAR);\n BEGIN\n incStack(mi, opcode);\n mi.i := putByte(mi.code, mi.i, opcode);\n mi.i := putShort(mi.code, mi.i, cpWriteClass(mi.cf, type))\n END putTypeInsn;\n\n PROCEDURE putMultiANewArrayInsn*(mi: MethodInfo; desc: ARRAY OF CHAR;\n dims: INTEGER);\n BEGIN\n mi.curStack := mi.curStack - (dims - 1);\n setMaxStack(mi);\n mi.i := putByte(mi.code, mi.i, Opcodes.MULTIANEWARRAY);\n mi.i := putShort(mi.code, mi.i, cpWriteClass(mi.cf, desc));\n mi.i := putByte(mi.code, mi.i, dims)\n END putMultiANewArrayInsn;\n\n PROCEDURE putTableSwitchInsn*(mi: MethodInfo; min, max, dflt, nLables: INTEGER;\n labels: ARRAY OF INTEGER);\n VAR j: INTEGER;\n BEGIN\n incStack(mi, Opcodes.TABLESWITCH);\n mi.i := putByte(mi.code, mi.i, Opcodes.TABLESWITCH);\n mi.i := putNBytes(mi.code, mi.i, 0, (4 - mi.i MOD 4) MOD 4);\n mi.i := putInt(mi.code, mi.i, dflt);\n mi.i := putInt(mi.code, mi.i, min);\n mi.i := putInt(mi.code, mi.i, max);\n FOR j := 0 TO nLables-1 DO\n mi.i := putInt(mi.code, mi.i, labels[j])\n END\n END putTableSwitchInsn;\n\n PROCEDURE putIincInsn*(mi: MethodInfo; var, increment: INTEGER);\n BEGIN\n incStack(mi, Opcodes.IINC);\n mi.i := putByte(mi.code, mi.i, Opcodes.IINC);\n mi.i := putByte(mi.code, mi.i, var);\n mi.i := putByte(mi.code, mi.i, increment)\n END putIincInsn;\n\n PROCEDURE putLdcInsnInt*(mi: MethodInfo; type, c: INTEGER);\n VAR x: INTEGER;\n BEGIN\n incStack(mi, Opcodes.LDC);\n x := cpWriteConst(mi.cf, type, c);\n IF x <= 255 THEN\n mi.i := putByte(mi.code, mi.i, Opcodes.LDC);\n mi.i := putByte(mi.code, mi.i, x)\n ELSE\n mi.i := putByte(mi.code, mi.i, Opcodes.LDCW);\n mi.i := putShort(mi.code, mi.i, x)\n END\n END putLdcInsnInt;\n\n PROCEDURE putLdcInsnStr*(mi: MethodInfo; c: ARRAY OF CHAR; add0X: BOOLEAN);\n VAR x: INTEGER;\n BEGIN\n incStack(mi, Opcodes.LDC);\n x := cpWriteString(mi.cf, c, add0X);\n IF x <= 255 THEN\n mi.i := putByte(mi.code, mi.i, Opcodes.LDC);\n mi.i := putByte(mi.code, mi.i, x)\n ELSE\n mi.i := putByte(mi.code, mi.i, Opcodes.LDCW);\n mi.i := putShort(mi.code, mi.i, x)\n END\n END putLdcInsnStr;\n\n PROCEDURE putVarInsn*(mi: MethodInfo; opcode, var: INTEGER);\n VAR opt: INTEGER;\n BEGIN\n incStack(mi, opcode);\n IF var < 4 THEN\n IF opcode < Opcodes.ISTORE THEN\n (* ILOAD_0 *)\n opt := 26 + LSL((opcode - Opcodes.ILOAD), 2) + var\n ELSE\n (* ISTORE_0 *)\n opt := 59 + LSL((opcode - Opcodes.ISTORE), 2) + var\n END;\n mi.i := putByte(mi.code, mi.i, opt)\n ELSE\n mi.i := putByte(mi.code, mi.i, opcode);\n mi.i := putByte(mi.code, mi.i, var)\n END\n END putVarInsn;\n\n PROCEDURE putFieldInsn*(mi: MethodInfo; opcode: INTEGER;\n owner, name, desc: ARRAY OF CHAR);\n BEGIN\n incStack(mi, opcode);\n mi.i := putByte(mi.code, mi.i, opcode);\n mi.i := putShort(mi.code, mi.i, cpWriteFiledRef(mi.cf, owner, name, desc))\n END putFieldInsn;\n\n PROCEDURE putIntInsn*(mi: MethodInfo; opcode, operand: INTEGER);\n BEGIN\n incStack(mi, opcode);\n mi.i := putByte(mi.code, mi.i, opcode);\n IF opcode = Opcodes.SIPUSH THEN\n mi.i := putByte(mi.code, mi.i, ASR(operand, 8));\n mi.i := putByte(mi.code, mi.i, operand)\n ELSE (* BIPUSH or NEWARRAY *)\n mi.i := putByte(mi.code, mi.i, operand)\n END\n END putIntInsn;\n\n PROCEDURE putJumpInsn*(mi: MethodInfo; opcode, to: INTEGER);\n BEGIN\n incStack(mi, opcode);\n mi.i := putByte(mi.code, mi.i, opcode);\n mi.i := putShort(mi.code, mi.i, to)\n END putJumpInsn;\n\n PROCEDURE putGotoInsn*(mi: MethodInfo; to, incr: INTEGER);\n BEGIN\n INC(mi.curStack, incr);\n IF to <= ShortMaxValue THEN\n mi.i := putByte(mi.code, mi.i, Opcodes.GOTO);\n mi.i := putShort(mi.code, mi.i, to)\n ELSE\n mi.i := putByte(mi.code, mi.i, Opcodes.GOTOW);\n mi.i := putInt(mi.code, mi.i, to)\n END\n END putGotoInsn;\n\n PROCEDURE putInsn*(mi: MethodInfo; opcode: INTEGER);\n BEGIN\n incStack(mi, opcode);\n mi.i := putByte(mi.code, mi.i, opcode)\n END putInsn;\n\n PROCEDURE setMaxVars*(mi: MethodInfo; locals: INTEGER);\n BEGIN\n mi.maxLocals := locals\n END setMaxVars;\nEND ClassFormat.\n" }, { "path": "src/CpCache.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(* A string to integer map used by ClassFormat *)\nMODULE CpCache;\n IMPORT Strings, OJS;\n CONST\n N = 997; (* prime number *)\n R = 31; (* prime number *)\n MaxKey* = OJS.stringBufSize;\n\n TYPE\n Node = POINTER TO NodeDesc;\n Key* = ARRAY MaxKey OF CHAR;\n NodeDesc = RECORD\n key: Key;\n val: INTEGER;\n next: Node\n END;\n Cache* = POINTER TO CacheDesc;\n CacheDesc* = RECORD\n map: ARRAY N OF Node;\n END;\n\n\n PROCEDURE hash(s: ARRAY OF CHAR): INTEGER;\n VAR h, i, len: INTEGER;\n BEGIN\n h := 0;\n i := 0;\n len := LEN(s);\n WHILE (i < len) & (s[i] # 0X) DO\n h := R * h + ORD(s[i]);\n INC(i)\n END\n (* MOD is >= 0 when N > 0 *)\n RETURN h MOD N\n END hash;\n\n PROCEDURE get*(m: Cache; k: ARRAY OF CHAR): INTEGER;\n VAR h, ret: INTEGER;\n c: Node;\n BEGIN\n h := hash(k);\n c := m.map[h];\n WHILE (c # NIL) & (c.key # k) DO\n c := c.next\n END;\n IF c = NIL THEN\n ret := -1\n ELSE\n ret := c.val\n END;\n RETURN ret\n END get;\n\n PROCEDURE put*(m: Cache; k: ARRAY OF CHAR; v: INTEGER);\n VAR h: INTEGER;\n r, c, tmp: Node;\n BEGIN\n h := hash(k);\n r := m.map[h];\n c := r;\n WHILE (c # NIL) & (c.key # k) DO\n c := c.next\n END;\n IF c = NIL THEN\n NEW(tmp);\n Strings.Copy(k, tmp.key);\n tmp.val := v;\n tmp.next := r;\n m.map[h] := tmp\n ELSE\n c.val := v\n END\n END put;\n\n PROCEDURE New*(): Cache;\n VAR c: Cache;\n BEGIN\n NEW(c);\n RETURN c\n END New;\nEND CpCache.\n" }, { "path": "src/Files.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\nDEFINITION Files;\n CONST\n OK = 0;\n EOF = -1;\n IOERROR = -2;\n UTF8ERROR = -3;\n\n TYPE\n File = POINTER TO FileDesc;\n FileDesc = RECORD END;\n VAR\n SEPARATOR: ARRAY 2 OF CHAR;\n\n PROCEDURE Create(name: ARRAY OF CHAR): File;\n PROCEDURE Open(name: ARRAY OF CHAR): File;\n PROCEDURE Close(file: File);\n\n PROCEDURE WriteAsciiStr(file: File; str: ARRAY OF CHAR);\n PROCEDURE WriteStr(file: File; str: ARRAY OF CHAR);\n PROCEDURE Write(file: File; b: BYTE);\n PROCEDURE WriteChar(file: File; c: CHAR);\n PROCEDURE WriteBytes(file: File; b: ARRAY OF BYTE);\n PROCEDURE WriteNBytes(file: File; b: ARRAY OF BYTE; len: INTEGER);\n PROCEDURE WriteInt(file: File; x: INTEGER);\n PROCEDURE WriteNum(file: File; x: INTEGER);\n\n PROCEDURE ReadNum(file: File): INTEGER;\n PROCEDURE Read(file: File): BYTE;\n PROCEDURE ReadChar(file: File): CHAR;\n PROCEDURE ReadInt(file: File): INTEGER;\n PROCEDURE ReadBytes(file: File; VAR b: ARRAY OF BYTE; VAR n: INTEGER);\n PROCEDURE ReadAsciiStr(file: File; VAR str: ARRAY OF CHAR);\n PROCEDURE ReadStr(file: File; VAR str: ARRAY OF CHAR): INTEGER;\n\n PROCEDURE Status(file: File): INTEGER;\n PROCEDURE Rename(from, to: ARRAY OF CHAR): INTEGER;\n PROCEDURE Exists(name: ARRAY OF CHAR): BOOLEAN;\n PROCEDURE Delete(name: ARRAY OF CHAR): INTEGER;\n PROCEDURE Seek(file: File; pos: INTEGER): INTEGER;\n PROCEDURE Size(file: File): INTEGER;\nEND Files.\n" }, { "path": "src/In.Mod", "content": "(*\n Copyright 2019 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*\n Simple procedures to read from standard input in an interactive fashion.\n\n Done. Indicates the success of an input operation. If Done is TRUE after an\n input operation, the operation was successful and its result is valid.\n An unsuccessful input operation sets Done to FALSE; it remains FALSE until\n the next successful input operation.\n\n Each procedure reads the input stream and fills its parameter with\n input data when successful. String reads an entire line of input.\n*)\nDEFINITION In;\n VAR Done: BOOLEAN;\n PROCEDURE Char(VAR ch: CHAR);\n PROCEDURE String(VAR str: ARRAY OF CHAR);\n PROCEDURE Real(VAR x: REAL);\n PROCEDURE Int(VAR x: INTEGER);\nEND In.\n" }, { "path": "src/Math.Mod", "content": "(*\n Copyright 2020 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(* Math provides a basic set of general purpose mathematical functions using\n REAL arithmetic. It implements the interface described in \"The Oakwood\n Guidelines for Oberon-2 Compiler Developers\". *)\nDEFINITION Math;\n CONST\n pi = 3.14159265358979323846;\n e = 2.71828182845904523536;\n\n (* sqrt returns the square root of x, where x must be positive *)\n PROCEDURE sqrt(x: REAL): REAL;\n\n (* power returns base raised to the power of x. *)\n PROCEDURE power(x, base: REAL): REAL;\n\n (* exp returns Math.e raised to the power of x: power(x, e)*)\n PROCEDURE exp(x: REAL): REAL;\n\n (* ln returns the natural logarithm (base e) of x. *)\n PROCEDURE ln(x: REAL): REAL;\n\n (* log returns the logarithm of x base b. All positive arguments are allowed.\n The base b must be positive.*)\n PROCEDURE log(x, b: REAL): REAL;\n\n (* If the fraction part of x is in range 0.0 to 0.5 (excluded) then the result\n of round is the largest integer not greater than x, otherwise the result\n is x rounded up to the next highest whole number.\n Note that integer values cannot always be exactly represented in REAL\n format. *)\n PROCEDURE round(x: REAL): REAL;\n\n (* sin returns the sine value of x, where x is in radians. *)\n PROCEDURE sin(x: REAL): REAL;\n\n (* cos returns the cosine value of x, where x is in radians. *)\n PROCEDURE cos(x: REAL): REAL;\n\n (* tan returns the tangent value of x, where x is in radians. *)\n PROCEDURE tan(x: REAL): REAL;\n\n (* arcsin returns the arcsine value in radians of x, where x is\n in the sine value. *)\n PROCEDURE arcsin(x: REAL): REAL;\n\n (* arcos returns the arcos value in radians of x, where x is\n in the cosine value. *)\n PROCEDURE arccos(x: REAL): REAL;\n\n (* arctan returns the arctan value in radians of x, where x is\n in the tangent value. *)\n PROCEDURE arctan(x: REAL): REAL;\n\n (* arctan2 returns the quadrant-correct arc tangent atan(x/y).\n If the denominator y is zero, then the numerator x must not be zero.\n All arguments are legal except x = y = 0. *)\n PROCEDURE arctan2(x, y: REAL): REAL;\n\n (* sinh returns the hyperbolic sine of x. *)\n PROCEDURE sinh(x: REAL): REAL;\n\n (* cosh returns the hyperbolic cosine of x. *)\n PROCEDURE cosh(x: REAL): REAL;\n\n (* tanh returns the hyperbolic tangent of x. *)\n PROCEDURE tanh(x: REAL): REAL;\n\n (* arcsinh returns the arc hyperbolic sine of x. *)\n PROCEDURE arcsinh(x: REAL): REAL;\n\n (* arccosh returns the arc hyperbolic cosine of x. All arguments greater than\n or equal to 1 are legal. *)\n PROCEDURE arccosh(x: REAL): REAL;\n\n (* arctanh returns the arc hyperbolic tangent of x. *)\n PROCEDURE arctanh(x: REAL): REAL;\nEND Math.\n" }, { "path": "src/OJB.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*\n Definition of data types Object, Type, and Module which together form the data\n structure called \"symbol table\". Contains procedures for creation of\n Objects, and for search.\n Handling of import and export, i.e. reading and writing of \"symbol files\"\n is done by procedures Import and Export. This module contains the list of\n standard identifiers, with which the symbol table (universe), and that of the\n pseudo-module SYSTEM are initialized.\n*)\nMODULE OJB;\n IMPORT Files, OJS, ClassFormat, Strings, Os;\n\n CONST versionkey = 1; keypos = 2;\n MaxTyptab = 500; MaxLModtab = 100; MaxGModtab = 200;\n\n (* class values *) Head = 0;\n Const* = 1; Var* = 2; Par* = 3; ParStruct* = 4;\n Fld* = 5; Typ* = 6; SProc* = 7; SFunc* = 8; Mod* = 9;\n\n (* form values *)\n Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;\n Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10; String* = 11;\n Array* = 12; Record* = 13;\n\n TYPE Object* = POINTER TO ObjDesc;\n Type* = POINTER TO TypeDesc;\n\n ObjDesc* = RECORD\n class*, modref: INTEGER;\n (*\n when class = Typ, lev <= 0 -> mno = -lev, 0 is the compiling module\n otherwise lev >= 0 -> scope level, 0 is the global scope\n *)\n lev*: INTEGER;\n expo*, rdo*: BOOLEAN; (*exported / read-only*)\n used: BOOLEAN;\n next*, dsc*: Object;\n type*: Type;\n recordType*, caseOrgType*: Type; (* computed, not serialized *)\n name*: OJS.Ident;\n (*\n Nested procedures and types (lev > 1, expo = FALSE) must have an unique\n bytecode name, as the nesting is flattened during code generation.\n nestedId is an unique integer that is appended to name in the bytecode.\n A valid nestedId is >= 1.\n *)\n nestedId*: INTEGER;\n val*, len*: INTEGER\n END ;\n\n TypeDesc* = RECORD\n form*, ref*: INTEGER; (*ref is only used for import/export*)\n nofpar*: INTEGER; (*for procedures, extension level for records*)\n len*: INTEGER; (*for arrays, len < 0 -> open array*)\n dsc*, typobj*: Object;\n base*: Type; (*for arrays, records, pointers*)\n signature*: ClassFormat.Descriptor;\n END;\n\n VAR topScope*, universe, system*: Object;\n byteType*, boolType*, charType*: Type;\n intType*, realType*, setType*, nilType*, noType*, strType*: Type;\n nofGMods, nofLMods, nofLTypes, anonRecIdx: INTEGER;\n GModtab: ARRAY MaxGModtab OF Object; (* GModtab[0] = compiling module *)\n LModtab: ARRAY MaxLModtab OF Object;\n LTyptab: ARRAY MaxTyptab OF Type; (* LTyptab[0] = NIL *)\n outFolder, homeFolder: ARRAY OJS.maxPath OF CHAR;\n\n PROCEDURE getOutputFolder*(VAR folder: ARRAY OF CHAR): INTEGER;\n VAR i: INTEGER;\n BEGIN\n i := Strings.Write(outFolder, folder, 0)\n RETURN i\n END getOutputFolder;\n\n PROCEDURE GetModFrom*(obj: Object): Object;\n VAR modIdx: INTEGER;\n BEGIN\n modIdx := 0;\n IF (obj # NIL) & (obj.lev < 0) THEN\n (* external type *)\n modIdx := -obj.lev;\n END\n RETURN GModtab[modIdx]\n END GetModFrom;\n\n (*insert new Object with name id*)\n PROCEDURE InsertObj*(id: OJS.Ident; class: INTEGER): Object;\n VAR new, x, obj: Object;\n BEGIN x := topScope;\n WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;\n IF x.next = NIL THEN\n NEW(new); new.name := id; new.nestedId := 0;\n new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;\n new.modref := -1; (*un-marked*); new.lev := 0; new.len := 0; new.val := 0;\n new.expo := FALSE; new.type := noType; new.recordType := NIL;\n new.caseOrgType := NIL; new.used := FALSE;\n x.next := new; obj := new\n ELSE obj := x.next; OJS.Mark(\"mult def\")\n END ;\n RETURN obj\n END InsertObj;\n\n PROCEDURE generateAnonymousTypeObj*(type: Type): Object;\n VAR anon: Object;\n BEGIN\n NEW(anon);\n Strings.Append(\"$Anonymous\", anon.name);\n Strings.AppendInt(anonRecIdx, 0, anon.name);\n anon.class := Typ;\n anon.type := type;\n anon.lev := 0;\n anon.expo := FALSE;\n type.typobj := anon;\n INC(anonRecIdx)\n RETURN anon\n END generateAnonymousTypeObj;\n\n PROCEDURE thisObj*(name: ARRAY OF CHAR): Object;\n VAR s, x: Object;\n BEGIN s := topScope;\n REPEAT x := s.next;\n WHILE (x # NIL) & (x.name # name) DO x := x.next END ;\n IF (x # NIL) & (s # topScope) & (x.lev > 0) & (* no local or global *)\n (x.class IN {Var, Par, ParStruct}) THEN\n OJS.Mark(\"not accessible\");\n x := NIL\n END ;\n s := s.dsc\n UNTIL (x # NIL) OR (s = NIL);\n IF x # NIL THEN x.used := TRUE END\n RETURN x\n END thisObj;\n\n PROCEDURE thisimport*(mod: Object; name: ARRAY OF CHAR): Object;\n VAR obj: Object;\n BEGIN\n obj := NIL;\n IF (mod # NIL) & (mod.class = Mod) THEN\n obj := mod.dsc;\n WHILE (obj # NIL) & (~obj.expo OR (obj.name # name)) DO\n obj := obj.next\n END\n END\n RETURN obj\n END thisimport;\n\n PROCEDURE thisfield*(rec: Type): Object;\n VAR fld: Object;\n BEGIN fld := rec.dsc;\n WHILE (fld # NIL) & (fld.name # OJS.id) DO fld := fld.next END ;\n RETURN fld\n END thisfield;\n\n PROCEDURE FindObj*(modid, modName, name: ARRAY OF CHAR): Object;\n VAR obj: Object;\n BEGIN\n IF modid # modName THEN\n obj := thisObj(modName);\n obj := thisimport(obj, name)\n ELSE\n obj := thisObj(name)\n END\n RETURN obj\n END FindObj;\n\n PROCEDURE OpenScope*;\n VAR s: Object;\n BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s\n END OpenScope;\n\n PROCEDURE CheckUnused*(parsNum: INTEGER);\n VAR err: ARRAY OJS.IdLen*30 OF CHAR;\n i: INTEGER; x: Object;\n BEGIN\n x := topScope.next;\n i := 0;\n (* skip parameters *)\n WHILE i < parsNum DO x := x.next; INC(i) END;\n i := 0;\n WHILE x # NIL DO\n IF ~x.expo & ~x.used & ((x.class = Var) OR (x.class = Mod)) THEN\n i := Strings.Write(x.name, err, i);\n i := Strings.WriteChar(\" \", err, i)\n END ;\n x := x.next\n END ;\n IF i # 0 THEN OJS.MarkAppend(\"Unused: \", err) END\n END CheckUnused;\n\n PROCEDURE CloseScope*;\n BEGIN topScope := topScope.dsc\n END CloseScope;\n\n (*------------------------------- Import ---------------------------------*)\n\n PROCEDURE MakeFileName*(useHome: BOOLEAN; VAR FName: ARRAY OF CHAR;\n name, ext: ARRAY OF CHAR);\n VAR i: INTEGER;\n BEGIN\n IF useHome THEN\n i := Strings.Write(homeFolder, FName, 0)\n ELSE\n i := getOutputFolder(FName)\n END ;\n i := Strings.Write(Files.SEPARATOR, FName, i);\n i := Strings.Write(name, FName, i);\n i := Strings.Write(ext, FName, i);\n IF i = -1 THEN OJS.Mark(\"Maximum file path length reached\") END\n END MakeFileName;\n\n PROCEDURE findSymFile(VAR fname: ARRAY OF CHAR;\n modName: ARRAY OF CHAR): Files.File;\n VAR f: Files.File;\n BEGIN\n MakeFileName(FALSE, fname, modName, \".smb\");\n f := Files.Open(fname);\n IF f = NIL THEN\n MakeFileName(TRUE, fname, modName, \".smb\");\n f := Files.Open(fname)\n END\n RETURN f\n END findSymFile;\n\n PROCEDURE InsertImport(obj, mod: Object): Object;\n VAR prev, cur: Object;\n BEGIN\n IF mod.dsc = NIL THEN\n mod.dsc := obj\n ELSE\n prev := NIL;\n cur := mod.dsc;\n WHILE (cur # NIL) & (cur.name # obj.name) DO\n prev := cur;\n cur := cur.next\n END ;\n IF cur = NIL THEN prev.next := obj ELSE obj := cur END\n END ;\n obj.lev := mod.lev\n RETURN obj\n END InsertImport;\n\n PROCEDURE InsertMod(name: OJS.Ident; key: INTEGER): Object;\n VAR mod: Object; i: INTEGER;\n BEGIN\n i := 0;\n WHILE (i < nofGMods) & (name # GModtab[i].name) DO INC(i) END;\n IF i < nofGMods THEN (* module already imported *)\n mod := GModtab[i];\n IF mod.val # key THEN OJS.Mark(\"key inconsistency of imported module\") END\n ELSE\n NEW(mod); mod.class := Mod; mod.rdo := TRUE; mod.expo := FALSE;\n Strings.Copy(name, mod.name); mod.val := key;\n mod.lev := -nofGMods; mod.type := noType;\n mod.dsc := NIL; mod.next := NIL;\n mod.modref := -1;\n IF nofGMods < MaxGModtab THEN\n GModtab[nofGMods] := mod; INC(nofGMods)\n ELSE\n OJS.Mark(\"too many imported modules\")\n END\n END\n RETURN mod\n END InsertMod;\n\n PROCEDURE InMod(f: Files.File; selfName: OJS.Ident): Object;\n VAR\n ref, key: INTEGER;\n name: OJS.Ident;\n mod: Object;\n BEGIN\n ref := Files.ReadNum(f);\n IF ref > 0 THEN (* first occurrence *)\n key := Files.ReadInt(f);\n Files.ReadAsciiStr(f, name);\n IF name = selfName THEN OJS.Mark(\"recursive import not allowed\") END;\n mod := InsertMod(name, key);\n IF nofLMods < MaxLModtab THEN\n LModtab[nofLMods] := mod; INC(nofLMods)\n ELSE\n OJS.Mark(\"too many imported modules\")\n END\n ELSE\n mod := LModtab[-ref]\n END\n RETURN mod\n END InMod;\n\n PROCEDURE InType(f: Files.File; selfName: OJS.Ident): Type;\n VAR\n class, form, np: INTEGER;\n fld, par, obj, last, mod: Object;\n typ, htyp: Type;\n name: OJS.Ident;\n BEGIN\n typ := NIL;\n IF Files.Status(f) = Files.OK THEN\n form := Files.ReadNum(f);\n IF form <= 0 THEN typ := LTyptab[-form] (* already read or NIL *)\n ELSE\n NEW(htyp); htyp.form := form;\n Files.ReadAsciiStr(f, name);\n IF name[0] # 0X THEN (* named type *)\n NEW(obj); Strings.Copy(name, obj.name);\n obj.expo := Files.ReadNum(f) = 1;\n obj.class := Typ; obj.type := htyp;\n htyp.typobj := obj; mod := InMod(f, selfName);\n obj := InsertImport(obj, mod);\n typ := obj.type\n ELSE\n typ := htyp\n END ;\n IF nofLTypes < MaxTyptab THEN LTyptab[nofLTypes] := typ; INC(nofLTypes)\n ELSE OJS.Mark(\"too many imported types\")\n END;\n IF form = Pointer THEN htyp.base := InType(f, selfName)\n ELSIF form = Array THEN\n htyp.base := InType(f, selfName); htyp.len := Files.ReadNum(f)\n ELSIF form = Record THEN\n htyp.base := InType(f, selfName);\n IF htyp.base = NIL THEN obj := NIL\n ELSE obj := htyp.base.dsc\n END;\n class := Files.ReadNum(f);\n last := NIL;\n WHILE class # 0 DO (* fields *)\n NEW(fld); fld.class := class;\n Files.ReadAsciiStr(f, fld.name);\n fld.expo := TRUE; fld.type := InType(f, selfName);\n fld.recordType := htyp;\n fld.val := 0; class := Files.ReadNum(f);\n IF last = NIL THEN htyp.dsc := fld ELSE last.next := fld END ;\n last := fld\n END ;\n (* append base type fields *)\n IF last = NIL THEN htyp.dsc := obj ELSE last.next := obj END\n ELSIF form = Proc THEN\n htyp.base := InType(f, selfName);\n Files.ReadAsciiStr(f, htyp.signature);\n np := Files.ReadNum(f);\n htyp.nofpar := np;\n par := NIL;\n last := NIL;\n WHILE np > 0 DO (* parameters *)\n NEW(obj); obj.class := Files.ReadNum(f);\n obj.rdo := Files.ReadNum(f) = 1;\n obj.type := InType(f, selfName);\n IF par = NIL THEN par := obj ELSE last.next := obj END;\n last := obj; DEC(np)\n END ;\n htyp.dsc := par\n END\n END\n END\n RETURN typ\n END InType;\n\n PROCEDURE Import*(VAR aliasName, impName, selfName: OJS.Ident);\n VAR\n class, version, i: INTEGER;\n obj, mod, mod0, dummyMod: Object;\n dummyType: Type;\n name: OJS.Ident;\n fname: ARRAY OJS.maxPath OF CHAR;\n str: ARRAY OJS.stringBufSize OF CHAR;\n f: Files.File;\n BEGIN\n IF impName = \"SYSTEM\" THEN\n mod := InsertObj(aliasName, Mod);\n mod.dsc := system; mod.rdo := TRUE\n ELSE\n f := findSymFile(fname, impName);\n IF f # NIL THEN\n nofLMods := 0;\n nofLTypes := Record + 1;\n version := Files.ReadNum(f);\n IF version # versionkey THEN OJS.Mark(\"wrong symbol version key\") END;\n mod0 := InMod(f, selfName);\n IF mod0.name # impName THEN OJS.Mark(\"inconsistent module name\") END;\n (* Read imported modules *)\n i := Files.ReadNum(f);\n WHILE i > 0 DO dummyMod := InMod(f, selfName); DEC(i) END;\n class := Files.ReadNum(f);\n WHILE (class # 0) & (Files.Status(f) = Files.OK) DO\n IF class = Typ THEN\n Files.ReadAsciiStr(f, name);\n IF name[0] # 0X THEN (* alias type *)\n NEW(obj); Strings.Copy(name, obj.name);\n obj.class := class; obj.expo := TRUE;\n obj.type := InType(f, selfName);\n obj := InsertImport(obj, mod0)\n ELSE (* other types *)\n dummyType := InType(f, selfName)\n END\n ELSE\n Files.ReadAsciiStr(f, name); NEW(obj);\n Strings.Copy(name, obj.name); obj.class := class;\n obj.expo := TRUE;\n obj.type := InType(f, selfName);\n IF class = Const THEN\n IF obj.type.form = Real THEN obj.val := Files.ReadInt(f)\n ELSIF obj.type.form = String THEN\n obj.len := Files.ReadStr(f, str) + 1; (* length + 0X *)\n obj.val := OJS.InsertStr(str, obj.len)\n ELSE obj.val := Files.ReadNum(f)\n END\n ELSIF class = Var THEN obj.rdo := TRUE\n END ;\n obj := InsertImport(obj, mod0)\n END ;\n class := Files.ReadNum(f)\n END ;\n mod := InsertObj(aliasName, Mod);\n mod.rdo := TRUE;\n mod.val := mod0.val; mod.lev := mod0.lev; mod.dsc := mod0.dsc;\n Files.Close(f);\n IF Files.Status(f) = Files.IOERROR THEN\n OJS.MarkAppend(\"error importing \", fname)\n END\n ELSE\n OJS.MarkAppend(\"import not available: \", fname)\n END\n END\n END Import;\n\n (*-------------------------------- Export ---------------------------------*)\n\n PROCEDURE OutMod(f: Files.File; mod: Object);\n BEGIN\n IF mod.modref < 0 THEN (* first occurrence *)\n mod.modref := nofLMods;\n INC(nofLMods);\n Files.WriteNum(f, Mod); Files.WriteInt(f, mod.val);\n Files.WriteAsciiStr(f, mod.name)\n ELSE\n Files.WriteNum(f, -mod.modref)\n END\n END OutMod;\n\n PROCEDURE OutType(f: Files.File; t: Type);\n VAR fld, par, bot: Object;\n np: INTEGER;\n BEGIN\n IF Files.Status(f) = Files.OK THEN\n IF t = NIL THEN Files.WriteNum(f, 0)\n ELSIF t.ref > 0 THEN (*type was already output*) Files.WriteNum(f, -t.ref)\n ELSE\n Files.WriteNum(f, t.form);\n t.ref := nofLTypes; INC(nofLTypes);\n IF t.typobj # NIL THEN (* named type *)\n Files.WriteAsciiStr(f, t.typobj.name);\n IF ~t.typobj.expo THEN (* invisible type *)\n Files.WriteNum(f, 0)\n ELSE\n Files.WriteNum(f, 1)\n END ;\n OutMod(f, GModtab[-t.typobj.lev])\n ELSE\n Files.WriteNum(f, 0)\n END ;\n IF t.form = Pointer THEN OutType(f, t.base)\n ELSIF t.form = Array THEN OutType(f, t.base); Files.WriteNum(f, t.len)\n ELSIF t.form = Record THEN\n OutType(f, t.base);\n IF t.base # NIL THEN\n bot := t.base.dsc\n ELSE\n bot := NIL\n END ;\n fld := t.dsc;\n WHILE fld # bot DO (*fields*)\n IF fld.expo THEN\n Files.WriteNum(f, Fld); Files.WriteAsciiStr(f, fld.name);\n OutType(f, fld.type)\n END ;\n fld := fld.next\n END ;\n Files.WriteNum(f, 0)\n ELSIF t.form = Proc THEN\n OutType(f, t.base);\n Files.WriteAsciiStr(f, t.signature);\n par := t.dsc;\n np := t.nofpar;\n Files.WriteNum(f, np);\n WHILE np > 0 DO\n Files.WriteNum(f, par.class);\n IF par.rdo THEN Files.WriteNum(f, 1) ELSE Files.WriteNum(f, 0) END;\n OutType(f, par.type);\n par := par.next;\n DEC(np)\n END\n END\n END\n END\n END OutType;\n\n PROCEDURE readOldKey(filename: ARRAY OF CHAR; VAR oldkey: INTEGER): BOOLEAN;\n VAR f: Files.File;\n ok: BOOLEAN;\n BEGIN\n ok := FALSE;\n f := Files.Open(filename);\n IF (f # NIL) & (Files.Seek(f, keypos) = Files.OK) THEN\n oldkey := Files.ReadInt(f);\n Files.Close(f);\n ok := Files.Status(f) = Files.OK\n END\n RETURN ok\n END readOldKey;\n\n PROCEDURE Export*(VAR modid: OJS.Ident; newSF: BOOLEAN);\n VAR x, sum, i, r, len, rename, oldkey: INTEGER;\n obj: Object;\n filename, tmpFile: ARRAY OJS.maxPath OF CHAR;\n str: ARRAY OJS.stringBufSize OF CHAR;\n f: Files.File;\n found: BOOLEAN;\n BEGIN\n rename := Files.OK;\n nofLMods := 0;\n nofLTypes := Record + 1; MakeFileName(FALSE, filename, modid, \".smb\");\n MakeFileName(FALSE, tmpFile, modid, \".smb.tmp\");\n f := Files.Create(tmpFile);\n IF f # NIL THEN\n Files.WriteNum(f, versionkey);\n OutMod(f, GModtab[0]);\n (* Write imported modules *)\n Files.WriteNum(f, nofGMods - 1);\n i := 1;\n WHILE i < nofGMods DO OutMod(f, GModtab[i]); INC(i) END;\n obj := topScope.next;\n WHILE (obj # NIL) & (Files.Status(f) = Files.OK) DO\n IF obj.expo THEN\n Files.WriteNum(f, obj.class);\n IF (obj.class # Typ) OR (obj.type.typobj # obj) THEN\n (* no type or alias type *)\n Files.WriteAsciiStr(f, obj.name)\n ELSE\n (* other type, write name in OutType *)\n Files.WriteNum(f, 0)\n END ;\n OutType(f, obj.type);\n IF obj.class = Const THEN\n IF obj.type.form = Real THEN Files.WriteInt(f, obj.val)\n ELSIF obj.type.form = String THEN\n OJS.ExtractStr(obj.val, obj.len, str);\n Files.WriteStr(f, str)\n ELSE Files.WriteNum(f, obj.val)\n END\n END\n END ;\n obj := obj.next;\n END ;\n len := Files.Size(f);\n IF len # -1 THEN\n REPEAT Files.WriteNum(f, 0); INC(len) UNTIL len MOD 4 = 0;\n END ;\n (* reset local type table *)\n FOR nofLTypes := Record+1 TO MaxTyptab-1 DO LTyptab[nofLTypes] := NIL END ;\n (* compute key (checksum) *)\n r := Files.Seek(f, 0); sum := Files.ReadInt(f);\n i := 4;\n WHILE (i < len) & (Files.Status(f) = Files.OK) DO\n x := Files.ReadInt(f); sum := sum + x; INC(i, 4)\n END ;\n found := readOldKey(filename, oldkey);\n IF ~found OR (sum # oldkey) THEN\n IF newSF OR ~found THEN\n r := Files.Seek(f, keypos);\n Files.WriteInt(f, sum); (*insert checksum*)\n Files.Close(f);\n rename := Files.Rename(tmpFile, filename)\n ELSE Files.Close(f); OJS.Mark(\"new symbol file inhibited\")\n END\n ELSE\n Files.Close(f);\n r := Files.Delete(tmpFile)\n END ;\n IF (Files.Status(f) = Files.IOERROR) OR (rename = Files.IOERROR) OR\n (r = Files.IOERROR) THEN\n OJS.MarkAppend(\"error exporting \", filename)\n END\n ELSE\n OJS.MarkAppend(\"error while creating symbol file \", filename)\n END\n END Export;\n\n PROCEDURE Init*(outputFolder: ARRAY OF CHAR; modid: OJS.Ident);\n VAR dummy: Object;\n BEGIN\n topScope := universe; nofGMods := 0; anonRecIdx := 0;\n Strings.Copy(outputFolder, outFolder);\n dummy := InsertMod(modid, 0)\n END Init;\n\n PROCEDURE type(ref, form: INTEGER): Type;\n VAR tp: Type;\n BEGIN NEW(tp); tp.form := form; tp.ref := ref; tp.base := NIL;\n LTyptab[ref] := tp\n RETURN tp\n END type;\n\n PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: INTEGER);\n VAR obj: Object;\n BEGIN NEW(obj); Strings.Copy(name, obj.name); obj.class := cl;\n obj.type := type; obj.val := n; obj.dsc := NIL;\n IF cl = Typ THEN type.typobj := obj END ;\n obj.next := system; system := obj\n END enter;\n\nBEGIN\n byteType := type(Byte, Int);\n boolType := type(Bool, Bool);\n charType := type(Char, Char);\n intType := type(Int, Int);\n realType := type(Real, Real);\n setType := type(Set, Set);\n nilType := type(NilTyp, NilTyp);\n noType := type(NoTyp, NoTyp);\n strType := type(String, String);\n\n (*initialize universe with data types and in-line procedures;\n LONGINT is synonym to INTEGER, LONGREAL to REAL. *)\n system := NIL; (*n = procno*10 + nofpar*)\n enter(\"BOR\", SFunc, intType, 122); (*functions*)\n enter(\"AND\", SFunc, intType, 112);\n enter(\"NOT\", SFunc, intType, 151);\n enter(\"ROR\", SFunc, intType, 92);\n enter(\"ASR\", SFunc, intType, 82);\n enter(\"LSL\", SFunc, intType, 72);\n enter(\"LEN\", SFunc, intType, 61);\n enter(\"CHR\", SFunc, charType, 51);\n enter(\"ORD\", SFunc, intType, 41);\n enter(\"FLT\", SFunc, realType, 31);\n enter(\"FLOOR\", SFunc, intType, 21);\n enter(\"ODD\", SFunc, boolType, 11);\n enter(\"ABS\", SFunc, intType, 1);\n enter(\"NEW\", SProc, noType, 51);\n enter(\"ASSERT\", SProc, noType, 41);\n enter(\"EXCL\", SProc, noType, 32);\n enter(\"INCL\", SProc, noType, 22);\n enter(\"DEC\", SProc, noType, 11);\n enter(\"INC\", SProc, noType, 1);\n enter(\"SET\", Typ, setType, 0); (*types*)\n enter(\"BOOLEAN\", Typ, boolType, 0);\n enter(\"BYTE\", Typ, byteType, 0);\n enter(\"CHAR\", Typ, charType, 0);\n enter(\"LONGREAL\", Typ, realType, 0);\n enter(\"REAL\", Typ, realType, 0);\n enter(\"LONGINT\", Typ, intType, 0);\n enter(\"INTEGER\", Typ, intType, 0);\n enter(\"ARGNUM\", SFunc, intType, 230);\n enter(\"ARGS\", SProc, noType, 242);\n\n (* Useful during bootstrapping *)\n enter(\"eot\", SFunc, boolType, 210);\n enter(\"ReadInt\", SFunc, intType, 220);\n enter(\"WriteChar\", SProc, noType, 151);\n enter(\"WriteInt\", SProc, noType, 161);\n enter(\"WriteLn\", SProc, noType, 170);\n enter(\"WriteReal\", SProc, noType, 181);\n\n topScope := NIL; OpenScope; topScope.next := system; universe := topScope;\n\n system := NIL; (* initialize \"unsafe\" pseudo-module SYSTEM*)\n enter(\"VAL\", SFunc, intType, 162);\n system.expo := TRUE; (* export VAL *)\n Os.GetEnv(homeFolder, \"OBERON_BIN\");\n IF homeFolder = \"\" THEN homeFolder := \".\" END\nEND OJB.\n" }, { "path": "src/OJG.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*Code generator for Oberon compiler for the Java Virtual Machine.*)\nMODULE OJG;\n IMPORT SYSTEM, Files, Opcodes, Strings, ClassFormat, OJS, OJB;\n\n CONST NofCases* = 256;\n MaxSetElement* = 32;\n ParamsMax* = 20;\n Stack = 10; RegI = 11; Cond = 12; Field = 13; (*internal item modes*)\n\n TYPE\n Item* = RECORD\n mode*: INTEGER;\n type*, oldType*: OJB.Type;\n a*, b*, r: INTEGER;\n rdo*: BOOLEAN; (*read only*)\n name*: ARRAY OJS.IdLen + ClassFormat.nestedIdLen OF CHAR;\n modName*: OJS.Ident;\n recordName: ClassFormat.Descriptor\n END ;\n\n LabelRange* = RECORD low*, high*, L*: INTEGER END ;\n\n StoreStmt = POINTER TO StoreStmtDesc;\n StoreStmtDesc = RECORD\n x, y: Item;\n next: StoreStmt\n END ;\n\n ClassContext = POINTER TO ClassContextDesc;\n ClassContextDesc = RECORD\n c: ClassFormat.CF;\n m: ClassFormat.MethodInfo;\n className: ClassFormat.Descriptor;\n numTmpVars: INTEGER;\n storeStmt: StoreStmt;\n next: ClassContext\n END ;\n\n VAR\n check: BOOLEAN; (*emit run-time checks*)\n topCtx: ClassContext;\n relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*)\n relmap0: ARRAY 6 OF INTEGER; (*condition codes for relations with 0*)\n relmapNil: ARRAY 2 OF INTEGER; (*condition codes for relations with NIL*)\n relmapAdr: ARRAY 2 OF INTEGER; (*condition codes for relations with adr*)\n dummyMethod: ClassFormat.MethodInfo;\n PROCEDURE curStack*(): INTEGER;\n RETURN topCtx.m.curStack\n END curStack;\n\n PROCEDURE clearCtx(ctx: ClassContext);\n BEGIN\n ctx.numTmpVars := 0\n END clearCtx;\n\n PROCEDURE closeContext;\n BEGIN\n ClassFormat.finalizeMethod(topCtx.c, topCtx.m);\n clearCtx(topCtx);\n topCtx.m := dummyMethod\n END closeContext;\n\n PROCEDURE SetCC(VAR x: Item; n: INTEGER);\n BEGIN\n x.mode := Cond;\n x.a := 0;\n x.b := 0;\n x.r := n;\n END SetCC;\n\n PROCEDURE negated(op: INTEGER): INTEGER;\n VAR ret: INTEGER;\n BEGIN\n ret := 0;\n CASE op OF\n Opcodes.IFACMPEQ: ret := Opcodes.IFACMPNE\n | Opcodes.IFACMPNE: ret := Opcodes.IFACMPEQ\n | Opcodes.IFEQ: ret := Opcodes.IFNE\n | Opcodes.IFNE: ret := Opcodes.IFEQ\n | Opcodes.IFLT: ret := Opcodes.IFGE\n | Opcodes.IFGE: ret := Opcodes.IFLT\n | Opcodes.IFGT: ret := Opcodes.IFLE\n | Opcodes.IFLE: ret := Opcodes.IFGT\n | Opcodes.IFICMPEQ: ret := Opcodes.IFICMPNE\n | Opcodes.IFICMPNE: ret := Opcodes.IFICMPEQ\n | Opcodes.IFNULL: ret := Opcodes.IFNONNULL\n | Opcodes.IFNONNULL: ret := Opcodes.IFNULL\n | Opcodes.IFICMPLT: ret := Opcodes.IFICMPGE\n | Opcodes.IFICMPGE: ret := Opcodes.IFICMPLT\n | Opcodes.IFICMPLE: ret := Opcodes.IFICMPGT\n | Opcodes.IFICMPGT: ret := Opcodes.IFICMPLE\n END\n RETURN ret\n END negated;\n\n PROCEDURE normalize(s: ARRAY OF CHAR; VAR out: ARRAY OF CHAR;\n i: INTEGER): INTEGER;\n VAR ch: CHAR;\n j, slen, olen: INTEGER;\n BEGIN\n IF i >= 0 THEN\n j := 0;\n slen := LEN(s);\n olen := LEN(out)-1;\n WHILE (j < slen) & (i < olen) & (s[j] # 0X) DO\n ch := s[j];\n IF (ch < \"0\") OR (ch > \"9\") & (ch < \"A\") OR\n (ch > \"Z\") & (ch < \"a\") OR (ch > \"z\") THEN\n ch := \"x\"\n END ;\n out[i] := ch;\n INC(i);\n INC(j)\n END ;\n out[i] := 0X\n END\n RETURN i\n END normalize;\n\n PROCEDURE internalNameAt(type: OJB.Type; VAR out: ARRAY OF CHAR;\n i: INTEGER): INTEGER;\n VAR mod: OJB.Object;\n BEGIN\n IF type.form = OJB.Record THEN\n mod := OJB.GetModFrom(type.typobj);\n i := Strings.Write(mod.name, out, i);\n i := Strings.WriteChar(\"_\", out, i);\n i := Strings.Write(type.typobj.name, out, i);\n IF type.typobj.nestedId > 0 THEN\n i := Strings.WriteInt(type.typobj.nestedId, 0, out, i)\n END\n ELSIF type.form = OJB.Pointer THEN\n mod := OJB.GetModFrom(type.base.typobj);\n i := Strings.Write(mod.name, out, i);\n i := Strings.WriteChar(\"_\", out, i);\n i := Strings.Write(type.base.typobj.name, out, i);\n IF type.base.typobj.nestedId > 0 THEN\n i := Strings.WriteInt(type.base.typobj.nestedId, 0, out, i)\n END\n ELSIF type.form = OJB.Proc THEN\n i := normalize(type.signature, out, i)\n END\n RETURN i\n END internalNameAt;\n\n\n PROCEDURE internalName(type: OJB.Type; VAR out: ARRAY OF CHAR);\n VAR i: INTEGER;\n BEGIN\n i := internalNameAt(type, out, 0);\n IF (i = -1) THEN OJS.Mark(\"Maximum descriptor length reached\") END\n END internalName;\n\n PROCEDURE DescriptorR(type: OJB.Type; VAR out: ARRAY OF CHAR;\n i: INTEGER): INTEGER;\n BEGIN\n IF type = OJB.boolType THEN\n i := Strings.WriteChar(\"Z\", out, i)\n ELSIF (type = OJB.intType) OR (type = OJB.setType) THEN\n i := Strings.WriteChar(\"I\", out, i)\n ELSIF type = OJB.byteType THEN\n i := Strings.WriteChar(\"B\", out, i)\n ELSIF type = OJB.charType THEN\n i := Strings.WriteChar(\"C\", out, i)\n ELSIF type = OJB.realType THEN\n i := Strings.WriteChar(\"F\", out, i)\n ELSIF type = OJB.noType THEN\n i := Strings.WriteChar(\"V\", out, i)\n ELSIF (type.form = OJB.Record) OR (type.form = OJB.Pointer) THEN\n i := Strings.WriteChar(\"L\", out, i);\n i := internalNameAt(type, out, i);\n i := Strings.WriteChar(\";\", out, i)\n ELSIF type.form = OJB.Array THEN\n i := Strings.WriteChar(\"[\", out, i);\n i := DescriptorR(type.base, out, i)\n ELSIF type.form = OJB.Proc THEN\n i := Strings.WriteChar(\"L\", out, i);\n i := normalize(type.signature, out, i);\n i := Strings.WriteChar(\";\", out, i)\n END\n RETURN i\n END DescriptorR;\n\n PROCEDURE DescriptorProc(type: OJB.Type; end: INTEGER;\n VAR desc: ARRAY OF CHAR);\n VAR args: OJB.Object;\n i, j: INTEGER;\n BEGIN\n i := 0;\n j := 0;\n j := Strings.WriteChar(\"(\", desc, j);\n args := type.dsc;\n WHILE (args # NIL) & (i < end) DO\n IF args.class = OJB.Par THEN\n j := Strings.WriteChar(\"[\", desc, j)\n END ;\n j := DescriptorR(args.type, desc, j);\n args := args.next;\n INC(i)\n END ;\n j := Strings.WriteChar(\")\", desc, j);\n j := DescriptorR(type.base, desc, j);\n IF j = -1 THEN OJS.Mark(\"Maximum descriptor length reached\") END\n END DescriptorProc;\n\n PROCEDURE DescriptorAt(type: OJB.Type; VAR desc: ARRAY OF CHAR; i: INTEGER);\n VAR x: INTEGER;\n BEGIN\n x := DescriptorR(type, desc, i);\n IF x = -1 THEN OJS.Mark(\"Maximum descriptor length reached\") END\n END DescriptorAt;\n\n PROCEDURE Descriptor(type: OJB.Type; VAR desc: ARRAY OF CHAR);\n BEGIN DescriptorAt(type, desc, 0)\n END Descriptor;\n\n PROCEDURE pushTypedLocal(VAR x: Item);\n BEGIN\n IF (x.type = OJB.intType) OR (x.type = OJB.boolType) OR\n (x.type = OJB.charType) OR (x.type = OJB.setType) OR\n (x.type = OJB.byteType ) THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, x.a)\n ELSIF x.type = OJB.realType THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.FLOAD, x.a)\n ELSE\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a)\n END\n END pushTypedLocal;\n\n PROCEDURE pushTypedArray(type: OJB.Type);\n BEGIN\n IF (type = OJB.intType) OR (type = OJB.setType) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.IALOAD)\n ELSIF type = OJB.realType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FALOAD)\n ELSIF (type = OJB.boolType) OR (type = OJB.byteType) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.BALOAD)\n ELSIF type = OJB.charType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.CALOAD)\n ELSE\n ClassFormat.putInsn(topCtx.m, Opcodes.AALOAD)\n END\n END pushTypedArray;\n\n PROCEDURE storeTypedLocal(VAR x: Item);\n BEGIN\n IF (x.type = OJB.intType) OR (x.type = OJB.boolType) OR\n (x.type = OJB.charType) OR (x.type = OJB.setType) OR\n (x.type = OJB.byteType) THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, x.a)\n ELSIF x.type = OJB.realType THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.FSTORE, x.a)\n ELSE\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, x.a)\n END\n END storeTypedLocal;\n\n PROCEDURE storeTypedArray(type: OJB.Type);\n BEGIN\n IF (type = OJB.intType) OR (type = OJB.setType) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.IASTORE)\n ELSIF (type = OJB.boolType) OR (type = OJB.byteType) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.BASTORE)\n ELSIF type = OJB.charType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.CASTORE)\n ELSIF type = OJB.realType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FASTORE)\n ELSE\n ClassFormat.putInsn(topCtx.m, Opcodes.AASTORE)\n END\n END storeTypedArray;\n\n PROCEDURE pushConst*(a: INTEGER);\n BEGIN\n IF (a = -1) OR (a >= 0) & (a <= 5) THEN\n CASE a OF\n -1: ClassFormat.putInsn(topCtx.m, Opcodes.ICONSTM1)\n | 0: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0)\n | 1: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST1)\n | 2: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST2)\n | 3: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST3)\n | 4: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST4)\n | 5: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST5)\n END\n ELSIF (a >= -128) & (a <= 127) THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.BIPUSH, a)\n ELSIF (a >= -32768) & (a <= 32767) THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.SIPUSH, a)\n ELSE\n ClassFormat.putLdcInsnInt(topCtx.m, ClassFormat.INT, a)\n END\n END pushConst;\n\n PROCEDURE pushRealConst(a: INTEGER);\n VAR num: REAL;\n BEGIN\n num := SYSTEM.VAL(REAL, a);\n IF num = 0.0 THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0)\n ELSIF num = 1.0 THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FCONST1)\n ELSIF num = 2.0 THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FCONST2)\n ELSE\n ClassFormat.putLdcInsnInt(topCtx.m, ClassFormat.FLOAT, a)\n END\n END pushRealConst;\n\n PROCEDURE isPrimitiveType(type: OJB.Type): BOOLEAN;\n RETURN (type = OJB.boolType) OR\n (type = OJB.charType) OR\n (type = OJB.realType) OR\n (type = OJB.setType) OR\n (type = OJB.byteType) OR\n (type = OJB.intType)\n END isPrimitiveType;\n\n PROCEDURE findMultiArrayDimension(type: OJB.Type;\n skipPrimitiveAndPtrArrays: BOOLEAN): INTEGER;\n VAR i: INTEGER; tmp: OJB.Type;\n BEGIN\n i := 1;\n tmp := type.base;\n WHILE tmp.form = OJB.Array DO\n tmp := tmp.base;\n INC(i)\n END ;\n IF skipPrimitiveAndPtrArrays &\n (isPrimitiveType(tmp) OR (tmp.form = OJB.Pointer) OR\n (tmp.form = OJB.Proc)) THEN\n i := 0\n END\n RETURN i\n END findMultiArrayDimension;\n\n PROCEDURE NewTmpObj(i: INTEGER; root: OJB.Object; type: OJB.Type;\n size: INTEGER): OJB.Object;\n VAR new: OJB.Object;\n BEGIN\n NEW(new);\n Strings.Append(\"@tmp\", new.name);\n Strings.AppendInt(i, 0, new.name);\n new.class := OJB.Var;\n new.type := type; new.val := size;\n new.next := root;\n RETURN new\n END NewTmpObj;\n\n PROCEDURE storeRef(x: OJB.Object);\n VAR desc, iname: ClassFormat.Descriptor;\n BEGIN\n IF x.lev = 0 THEN\n Descriptor(x.type, desc);\n IF x.class = OJB.Fld THEN\n internalName(x.recordType, iname);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTFIELD, iname, x.name,\n desc)\n ELSE\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, topCtx.className,\n x.name, desc)\n END\n ELSE\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, x.val)\n END\n END storeRef;\n\n PROCEDURE loadRef(x: OJB.Object);\n VAR desc, iname: ClassFormat.Descriptor;\n BEGIN\n IF x.lev = 0 THEN\n Descriptor(x.type, desc);\n IF x.class = OJB.Fld THEN\n internalName(x.recordType, iname);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETFIELD, iname, x.name,\n desc)\n ELSE\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, topCtx.className,\n x.name, desc)\n END\n ELSE\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.val)\n END\n END loadRef;\n\n PROCEDURE getLocalVars(obj: OJB.Object; end: INTEGER): OJB.Object;\n VAR i: INTEGER;\n BEGIN\n i := 0;\n WHILE (obj # NIL) & (i < end) DO\n obj := obj.next;\n INC(i)\n END\n RETURN obj\n END getLocalVars;\n\n PROCEDURE createArraysTempVars(topScope: OJB.Object; VAR size: INTEGER;\n skipPrimitiveAndPtrArrays: BOOLEAN): OJB.Object;\n VAR maxArrayDimension: INTEGER;\n tmp, vars: OJB.Object;\n dim, i: INTEGER;\n BEGIN\n maxArrayDimension := 0;\n tmp := topScope;\n vars := NIL;\n i := 0;\n WHILE tmp # NIL DO\n IF ((tmp.class = OJB.Var) OR (tmp.class = OJB.Fld)) &\n (tmp.type.form = OJB.Array) THEN\n dim := findMultiArrayDimension(tmp.type, skipPrimitiveAndPtrArrays);\n IF dim > maxArrayDimension THEN\n WHILE maxArrayDimension < dim DO\n vars := NewTmpObj(i, vars, OJB.intType, size);\n INC(maxArrayDimension);\n INC(i);\n INC(size)\n END\n END\n END ;\n tmp := tmp.next\n END\n RETURN vars\n END createArraysTempVars;\n\n PROCEDURE initializeLocalVar(x: OJB.Object);\n BEGIN\n IF (x.type = OJB.intType) OR (x.type = OJB.boolType) OR\n (x.type = OJB.setType) OR (x.type = OJB.byteType) OR\n (x.type = OJB.charType) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, x.val)\n ELSIF x.type = OJB.realType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.FSTORE, x.val)\n ELSE (* x.class = ORB.Pointer *)\n ClassFormat.putInsn(topCtx.m, Opcodes.ACONSTNULL);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, x.val)\n END\n END initializeLocalVar;\n\n PROCEDURE emitPrimitiveNewArray(type: OJB.Type);\n BEGIN\n IF type = OJB.boolType THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TBOOLEAN)\n ELSIF type = OJB.charType THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TCHAR)\n ELSIF type = OJB.realType THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TFLOAT)\n ELSIF type = OJB.byteType THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TBYTE)\n ELSIF (type = OJB.intType) OR (type = OJB.setType) THEN\n ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TINT)\n END\n END emitPrimitiveNewArray;\n\n PROCEDURE getLastArray(type: OJB.Type): OJB.Type;\n VAR last: OJB.Type;\n BEGIN\n last := NIL;\n WHILE type.form = OJB.Array DO\n last := type;\n type := type.base\n END\n RETURN last\n END getLastArray;\n\n PROCEDURE Fixup*(L: INTEGER);\n BEGIN\n ClassFormat.FixLink(topCtx.m, L)\n END Fixup;\n\n PROCEDURE pushIndexes(i: INTEGER; tmpVars: OJB.Object): OJB.Object;\n VAR k: INTEGER;\n BEGIN\n k := 0;\n WHILE k # i-1 DO\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, tmpVars.val);\n ClassFormat.putInsn(topCtx.m, Opcodes.AALOAD);\n tmpVars := tmpVars.next;\n INC(k)\n END\n RETURN tmpVars\n END pushIndexes;\n\n PROCEDURE pushIndexes2(i: INTEGER): INTEGER;\n VAR tmpVars, k: INTEGER;\n BEGIN\n tmpVars := topCtx.numTmpVars - i;\n k := 0;\n WHILE k < i-1 DO\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, tmpVars);\n ClassFormat.putInsn(topCtx.m, Opcodes.AALOAD);\n INC(tmpVars);\n INC(k)\n END\n RETURN tmpVars\n END pushIndexes2;\n\n PROCEDURE genNew(typeName: ARRAY OF CHAR);\n BEGIN\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.NEW, typeName);\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, typeName,\n \"\", \"()V\", 0)\n END genNew;\n\n PROCEDURE initializeMultiDimArray(i: INTEGER; x: OJB.Object; type: OJB.Type;\n tmpVars, currTmpVar: OJB.Object);\n VAR iname: ClassFormat.Descriptor;\n cond, end: INTEGER;\n BEGIN\n IF type.form = OJB.Array THEN\n pushConst(type.len - 1);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, currTmpVar.val);\n cond := topCtx.m.i;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, currTmpVar.val);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFLT, 0);\n initializeMultiDimArray(i + 1, x, type.base, tmpVars, currTmpVar.next);\n ClassFormat.putIincInsn(topCtx.m, currTmpVar.val, -1);\n ClassFormat.putGotoInsn(topCtx.m, cond-topCtx.m.i, 0);\n Fixup(end)\n ELSE\n IF x.class = OJB.Fld THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0)\n END ;\n loadRef(x);\n tmpVars := pushIndexes(i, tmpVars);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, tmpVars.val);\n internalName(type, iname);\n genNew(iname);\n ClassFormat.putInsn(topCtx.m, Opcodes.AASTORE)\n END\n END initializeMultiDimArray;\n\n PROCEDURE initializeRecord(x: OJB.Object);\n VAR iname: ClassFormat.Descriptor;\n BEGIN\n IF x.class = OJB.Fld THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0)\n END ;\n internalName(x.type, iname);\n genNew(iname);\n storeRef(x)\n END initializeRecord;\n\n PROCEDURE initializeArray(x, tmpVars: OJB.Object);\n VAR\n desc, iname: ClassFormat.Descriptor;\n arrDim, i: INTEGER;\n type, tbase, base, t: OJB.Type;\n BEGIN\n type := x.type;\n arrDim := 1;\n tbase := type.base;\n IF x.class = OJB.Fld THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0)\n END ;\n i := Strings.WriteChar(\"[\", desc, 0);\n pushConst(type.len);\n WHILE (tbase # NIL) & (tbase.form = OJB.Array) DO\n pushConst(tbase.len);\n INC(arrDim);\n i := Strings.WriteChar(\"[\", desc, i);\n tbase := tbase.base\n END ;\n IF (arrDim = 1) & (tbase # NIL) THEN\n IF isPrimitiveType(tbase) THEN\n emitPrimitiveNewArray(tbase);\n storeRef(x)\n ELSE\n internalName(tbase, iname);\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, iname);\n storeRef(x);\n IF (tbase.form # OJB.Pointer) & (tbase.form # OJB.Proc) THEN\n initializeMultiDimArray(0, x, type, tmpVars, tmpVars)\n END\n END\n ELSE\n DescriptorAt(tbase, desc, i);\n ClassFormat.putMultiANewArrayInsn(topCtx.m, desc, arrDim);\n storeRef(x);\n t := getLastArray(x.type);\n base := t.base;\n IF ~isPrimitiveType(base) & (base.form # OJB.Pointer) &\n (base.form # OJB.Proc) THEN\n initializeMultiDimArray(0, x, type, tmpVars, tmpVars)\n END\n END\n END initializeArray;\n\n PROCEDURE initializeScope(x: OJB.Object; offset: INTEGER);\n VAR type, recordType: OJB.Type;\n num, numTmpVars: INTEGER;\n tempVars: OJB.Object;\n BEGIN\n num := offset;\n (* skipPrimitiveAndPtrArrays = TRUE, as we don't want to create local\n variables to index multi-dimensional primitive/reference arrays as by\n default they are already initialized by MULTIANEWARRAY *)\n tempVars := createArraysTempVars(x, num, TRUE);\n numTmpVars := num;\n IF x # NIL THEN\n recordType := x.recordType;\n WHILE (x # NIL) & (recordType = x.recordType) DO\n IF (x.class = OJB.Var) OR (x.class = OJB.Fld) THEN\n type := x.type;\n IF type.form = OJB.Record THEN\n initializeRecord(x)\n ELSIF type.form = OJB.Array THEN\n initializeArray(x, tempVars)\n ELSIF x.lev > 0 THEN\n initializeLocalVar(x)\n END\n END ;\n x := x.next\n END\n END ;\n topCtx.numTmpVars := numTmpVars\n END initializeScope;\n\n PROCEDURE Constructor(obj: OJB.Object);\n VAR baseName: ClassFormat.Descriptor;\n tmp: OJB.Object;\n BEGIN\n topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC, \"\",\n \"()V\");\n clearCtx(topCtx);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n Strings.Append(\"java/lang/Object\", baseName);\n tmp := NIL;\n IF obj # NIL THEN\n tmp := obj.type.dsc;\n IF obj.type.base # NIL THEN\n internalName(obj.type.base, baseName)\n END\n END ;\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, baseName,\n \"\", \"()V\", 0);\n initializeScope(tmp, 1);\n ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx);\n ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars);\n closeContext\n END Constructor;\n\n PROCEDURE emitTypedReturn(type: OJB.Type);\n BEGIN\n IF (type = OJB.intType) OR (type = OJB.boolType) OR\n (type = OJB.charType) OR (type = OJB.setType) OR\n (type = OJB.byteType) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.IRETURN)\n ELSIF type = OJB.realType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FRETURN)\n ELSE\n ClassFormat.putInsn(topCtx.m, Opcodes.ARETURN)\n END\n END emitTypedReturn;\n\n PROCEDURE InvokeMethod(signature: ARRAY OF CHAR; procType: OJB.Type;\n qualifierModName, procName: ARRAY OF CHAR;\n impl: BOOLEAN);\n VAR access, i: INTEGER; par: OJB.Object;\n tmp: Item;\n BEGIN\n access := Opcodes.ACCxPUBLIC;\n IF ~impl THEN INC(access, Opcodes.ACCxABSTRACT) END ;\n topCtx.m := ClassFormat.NewMI(topCtx.c, access, \"invoke\", signature);\n clearCtx(topCtx);\n IF impl THEN\n par := procType.dsc;\n FOR i := 1 TO procType.nofpar DO\n IF par.class = OJB.Par THEN\n (* it's a VAR parameter, force pushTypedLocal() to generate an\n ALOAD *)\n tmp.type := OJB.nilType\n ELSE\n tmp.type := par.type\n END ;\n tmp.a := i;\n pushTypedLocal(tmp);\n par := par.next\n END ;\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n qualifierModName, procName, signature,\n procType.nofpar);\n IF procType.base.form # OJB.NoTyp THEN\n emitTypedReturn(procType.base)\n ELSE ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx)\n END ;\n ClassFormat.setMaxVars(topCtx.m, procType.nofpar+1) (* +1 is this *)\n END ;\n closeContext\n END InvokeMethod;\n\n PROCEDURE genClassFilePath(name: ARRAY OF CHAR; VAR path: ARRAY OF CHAR);\n VAR i: INTEGER;\n BEGIN\n i := OJB.getOutputFolder(path);\n i := Strings.Write(Files.SEPARATOR, path, i);\n i := Strings.Write(name, path, i);\n i := Strings.Write(\".class\", path, i);\n IF i = -1 THEN OJS.Mark(\"Maximum file path length reached\") END\n END genClassFilePath;\n\n PROCEDURE MakeProcType*(type: OJB.Type);\n VAR typeName: ClassFormat.Descriptor;\n path: ARRAY OJS.maxPath OF CHAR;\n newCtx: ClassContext;\n BEGIN\n internalName(type, typeName);\n genClassFilePath(typeName, path);\n IF ~Files.Exists(path) THEN\n NEW(newCtx);\n Strings.Copy(typeName, newCtx.className);\n newCtx.next := topCtx;\n topCtx := newCtx;\n newCtx.c := ClassFormat.NewCF(Opcodes.ACCxPUBLIC + Opcodes.ACCxABSTRACT,\n topCtx.className, \"java/lang/Object\");\n Constructor(NIL);\n InvokeMethod(type.signature, NIL, \"\", \"\", FALSE);\n genClassFilePath(topCtx.className, path);\n ClassFormat.toFile(topCtx.c, path);\n topCtx := topCtx.next\n END\n END MakeProcType;\n\n PROCEDURE joinNames(VAR s0, s1: ARRAY OF CHAR; VAR out: ARRAY OF CHAR);\n VAR i: INTEGER;\n BEGIN\n i := Strings.Write(s0, out, 0);\n i := Strings.WriteChar(\"_\", out, i);\n i := Strings.Write(s1, out, i);\n IF i = -1 THEN OJS.Mark(\"Maximum descriptor length reached\") END\n END joinNames;\n\n PROCEDURE makeRefDesc(VAR s, desc: ARRAY OF CHAR);\n VAR i: INTEGER;\n BEGIN\n i := Strings.WriteChar(\"L\", desc, 0);\n i := Strings.Write(s, desc, i);\n i := Strings.WriteChar(\";\", desc, i);\n IF i = -1 THEN OJS.Mark(\"Maximum descriptor length reached\") END\n END makeRefDesc;\n\n PROCEDURE ConstructorProcInstance(signature: OJB.Type);\n VAR iname: ClassFormat.Descriptor;\n BEGIN\n topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPRIVATE, \"\",\n \"()V\");\n clearCtx(topCtx);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n internalName(signature, iname);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, iname, \"\",\n \"()V\", 0);\n ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx);\n ClassFormat.setMaxVars(topCtx.m, 1);\n closeContext\n END ConstructorProcInstance;\n\n PROCEDURE InitProcInstance(VAR typeName: ARRAY OF CHAR);\n VAR desc: ClassFormat.Descriptor;\n BEGIN\n topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxSTATIC, \"\",\n \"()V\");\n clearCtx(topCtx);\n genNew(typeName);\n makeRefDesc(typeName, desc);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, typeName, \"INSTANCE\",\n desc);\n ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx);\n ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars);\n closeContext\n END InitProcInstance;\n\n PROCEDURE MakeProcInstance(VAR x: Item);\n VAR\n path: ARRAY OJS.maxPath OF CHAR;\n iname, instanceName:ClassFormat.Descriptor;\n procType: OJB.Type;\n newCtx: ClassContext;\n access: INTEGER;\n BEGIN\n procType := x.type;\n MakeProcType(procType);\n joinNames(x.modName, x.name, instanceName);\n genClassFilePath(instanceName, path);\n IF ~Files.Exists(path) THEN\n NEW(newCtx);\n access := Opcodes.ACCxPUBLIC + Opcodes.ACCxSUPER + Opcodes.ACCxFINAL;\n joinNames(x.modName, x.name, newCtx.className);\n newCtx.next := topCtx;\n topCtx := newCtx;\n internalName(procType, iname);\n newCtx.c := ClassFormat.NewCF(access, topCtx.className, iname);\n makeRefDesc(topCtx.className, iname);\n ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC,\n \"INSTANCE\", iname);\n ConstructorProcInstance(procType);\n InvokeMethod(procType.signature, procType, x.modName, x.name, TRUE);\n InitProcInstance(topCtx.className);\n genClassFilePath(topCtx.className, path);\n ClassFormat.toFile(topCtx.c, path);\n topCtx := topCtx.next\n END\n END MakeProcInstance;\n\n PROCEDURE load(VAR x: Item);\n VAR\n L0, L1: INTEGER;\n xt: OJB.Type;\n desc, procType: ClassFormat.Descriptor;\n s: ARRAY OJS.stringBufSize OF CHAR;\n BEGIN\n IF x.mode # Stack THEN\n IF x.oldType # NIL THEN\n xt := x.oldType\n ELSE\n xt := x.type\n END ;\n IF (x.mode = OJB.Var) OR (x.mode = OJB.ParStruct) THEN\n IF x.r > 0 THEN\n (*local*)\n pushTypedLocal(x)\n ELSE\n Descriptor(xt, desc);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, x.modName,\n x.name, desc)\n END\n ELSIF x.mode = OJB.Par THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n pushConst(0);\n pushTypedArray(xt)\n ELSIF x.mode = OJB.Const THEN\n IF xt = OJB.realType THEN\n pushRealConst(x.a)\n ELSIF xt = OJB.nilType THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.ACONSTNULL);\n ELSIF xt = OJB.strType THEN\n OJS.ExtractStr(x.a, x.b, s);\n ClassFormat.putLdcInsnStr(topCtx.m, s, TRUE)\n ELSIF xt.form = OJB.Proc THEN\n MakeProcInstance(x);\n joinNames(x.modName, x.name, procType);\n makeRefDesc(procType, desc);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, procType,\n \"INSTANCE\", desc)\n ELSE\n pushConst(x.a)\n END\n ELSIF x.mode = RegI THEN\n pushTypedArray(xt)\n ELSIF x.mode = Field THEN\n Descriptor(xt, desc);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETFIELD, x.recordName,\n x.name, desc)\n ELSIF x.mode = Cond THEN\n L0 := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, negated(x.r), 0);\n ClassFormat.FixLink(topCtx.m, x.b);\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST1);\n L1 := topCtx.m.i;\n ClassFormat.putGotoInsn(topCtx.m, 0, -1);\n ClassFormat.FixLink(topCtx.m, x.a);\n Fixup(L0);\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0);\n Fixup(L1)\n END ;\n x.mode := Stack;\n IF x.oldType # NIL THEN\n x.oldType := NIL;\n internalName(x.type, desc);\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.CHECKCAST, desc)\n END ;\n IF x.type = OJB.byteType THEN\n pushConst(255);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n END\n END\n END load;\n\n PROCEDURE TypeTest*(VAR x: Item; T: OJB.Type; isguard: BOOLEAN);\n VAR iname: ClassFormat.Descriptor;\n BEGIN\n IF isguard THEN\n IF x.oldType = NIL THEN x.oldType := x.type END\n ELSE\n load(x);\n internalName(T, iname);\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.INSTANCEOF, iname)\n END\n END TypeTest;\n\n PROCEDURE loadCond(VAR x: Item);\n BEGIN\n IF x.type.form = OJB.Bool THEN\n load(x); x.r := Opcodes.IFNE;\n x.mode := Cond; x.a := 0; x.b := 0;\n ELSE OJS.Mark(\"not Boolean\") END\n END loadCond;\n\n PROCEDURE getPC*(): INTEGER;\n RETURN topCtx.m.i\n END getPC;\n\n PROCEDURE CFJump*(VAR x: Item); (*conditional forward jump*)\n VAR L0: INTEGER;\n BEGIN\n IF x.mode # Cond THEN loadCond(x) END ;\n L0 := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, negated(x.r), x.a);\n ClassFormat.FixLink(topCtx.m, x.b); x.a := L0\n END CFJump;\n\n PROCEDURE FJump*(L: INTEGER): INTEGER; (*unconditional forward jump*)\n VAR L0: INTEGER;\n BEGIN\n L0 := topCtx.m.i;\n ClassFormat.putGotoInsn(topCtx.m, L, 0);\n RETURN L0\n END FJump;\n\n PROCEDURE CBJump*(VAR x: Item; L: INTEGER); (*conditional backward jump*)\n BEGIN\n IF x.mode # Cond THEN loadCond(x) END ;\n ClassFormat.putJumpInsn(topCtx.m, negated(x.r), L-topCtx.m.i);\n ClassFormat.FixLink(topCtx.m, x.b);\n ClassFormat.FixLinkWith(topCtx.m, x.a, L)\n END CBJump;\n\n PROCEDURE BJump*(L: INTEGER); (*unconditional backward jump*)\n BEGIN\n ClassFormat.putGotoInsn(topCtx.m, L-topCtx.m.i, 0)\n END BJump;\n\n PROCEDURE genSignature*(type: OJB.Type);\n BEGIN DescriptorProc(type, type.nofpar, type.signature)\n END genSignature;\n\n PROCEDURE MakeConstItem*(VAR x: Item; typ: OJB.Type; val: INTEGER);\n BEGIN\n x.mode := OJB.Const; x.type := typ; x.a := val; x.rdo := TRUE\n END MakeConstItem;\n\n PROCEDURE MakeRealItem*(VAR x: Item; val: REAL);\n BEGIN\n x.mode := OJB.Const; x.type := OJB.realType;\n x.a := SYSTEM.VAL(INTEGER, val); x.rdo := TRUE\n END MakeRealItem;\n\n PROCEDURE MakeStringItem*(VAR x: Item);\n BEGIN\n x.mode := OJB.Const; x.type := OJB.strType;\n x.a := OJS.strpos; x.b := OJS.slen; x.rdo := TRUE;\n END MakeStringItem;\n\n PROCEDURE MakeItem*(VAR x: Item; y: OJB.Object);\n BEGIN\n x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo;\n Strings.Copy(y.name, x.name);\n IF y.nestedId > 0 THEN\n Strings.AppendInt(y.nestedId, 0, x.name)\n END ;\n x.oldType := y.caseOrgType;\n IF (y.class = OJB.Const) & (y.type.form = OJB.String) THEN\n x.b := y.len\n END ;\n x.r := y.lev\n END MakeItem;\n\n PROCEDURE Pop(x: Item);\n BEGIN\n IF x.mode IN {Stack, Field} THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.POP)\n ELSIF x.mode = RegI THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.POP2)\n END\n END Pop;\n\n PROCEDURE ConstTypeTest*(VAR x: Item);\n BEGIN\n IF x.mode IN {OJB.Var, OJB.Par, OJB.ParStruct, Field, Stack, RegI} THEN\n Pop(x);\n MakeConstItem(x, OJB.boolType, 1)\n ELSE OJS.Mark(\"Unexpected internal mode\")\n END\n END ConstTypeTest;\n\n PROCEDURE FieldAccess*(VAR x: Item; y: OJB.Object); (* x := x.y *)\n BEGIN\n load(x);\n x.mode := Field;\n internalName(x.type, x.recordName);\n Strings.Copy(y.name, x.name)\n END FieldAccess;\n\n PROCEDURE Index0*(VAR x: Item);\n BEGIN\n load(x)\n END Index0;\n\n PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *)\n BEGIN\n IF (y.mode = OJB.Const) & (x.type.len >= 0) THEN\n IF (y.a < 0) OR (y.a >= x.type.len) THEN OJS.Mark(\"bad index\") END\n END ;\n load(y);\n x.mode := RegI\n END Index;\n\n PROCEDURE Not*(VAR x: Item); (* x := ~x *)\n VAR t: INTEGER;\n BEGIN\n IF x.mode # Cond THEN loadCond(x) END ;\n x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t\n END Not;\n\n PROCEDURE And1*(VAR x: Item); (* x := x & *)\n VAR L0: INTEGER;\n BEGIN\n IF x.mode # Cond THEN loadCond(x) END ;\n L0 := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, negated(x.r), x.a);\n x.a := L0; ClassFormat.FixLink(topCtx.m, x.b);\n x.b := 0\n END And1;\n\n PROCEDURE And2*(VAR x, y: Item);\n BEGIN\n IF y.mode # Cond THEN loadCond(y) END ;\n x.a := ClassFormat.merged(topCtx.m, y.a, x.a); x.b := y.b; x.r := y.r\n END And2;\n\n PROCEDURE Or1*(VAR x: Item); (* x := x OR *)\n VAR L0: INTEGER;\n BEGIN\n IF x.mode # Cond THEN loadCond(x) END ;\n L0 := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, x.r, x.b);\n x.b := L0; ClassFormat.FixLink(topCtx.m, x.a);\n x.a := 0\n END Or1;\n\n PROCEDURE Or2*(VAR x, y: Item);\n BEGIN\n IF y.mode # Cond THEN loadCond(y) END ;\n x.a := y.a; x.b := ClassFormat.merged(topCtx.m, y.b, x.b); x.r := y.r\n END Or2;\n\n PROCEDURE loadAndMaybeSwap(VAR x, y: Item);\n BEGIN\n IF (x.mode = OJB.Const) & (y.mode # OJB.Const) THEN\n (*x loading has been delayed, so fully load y and restore the order\n (SWAP)*)\n load(y);\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP)\n ELSE load(x); load(y)\n END\n END loadAndMaybeSwap;\n\n PROCEDURE Neg*(VAR x: Item); (* x := -x *)\n BEGIN\n IF x.type.form = OJB.Int THEN\n IF x.mode = OJB.Const THEN x.a := -x.a\n ELSE load(x); ClassFormat.putInsn(topCtx.m, Opcodes.INEG)\n END\n ELSIF x.type.form = OJB.Real THEN\n IF x.mode = OJB.Const THEN\n x.a := SYSTEM.VAL(INTEGER, -SYSTEM.VAL(REAL, x.a));\n ELSE load(x); ClassFormat.putInsn(topCtx.m, Opcodes.FNEG)\n END\n ELSE (*form := Set*)\n (* The sign of a two’s complement number is reversed in a process called\n taking the two’s complement:\n Ex. 8 := 00001000 -> -8 := oneComplement(8) + 1\n := 11110111 + 1 := 11111000\n So if I only need the oneComplement I subtract 1 to the two's\n complement:\n Ex. -8 := oneComplement(8) + 1 -> -8 - 1 := oneComplement(8)\n *)\n IF x.mode = OJB.Const THEN x.a := -x.a-1\n ELSE (* there is no Not instruction in JVM *)\n load(x);\n pushConst(-1);\n ClassFormat.putInsn(topCtx.m, Opcodes.IXOR)\n END\n END\n END Neg;\n\n PROCEDURE AddOp*(op: INTEGER; VAR x, y: Item); (* x := x +- y *)\n BEGIN\n IF op = OJS.plus THEN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := x.a + y.a\n ELSIF x.mode = OJB.Const THEN\n load(y);\n IF x.a # 0 THEN\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.IADD)\n ELSE x.mode := Stack\n END\n ELSIF y.mode = OJB.Const THEN\n load(x);\n IF y.a # 0 THEN\n load(y); ClassFormat.putInsn(topCtx.m, Opcodes.IADD)\n END ;\n ELSE load(x); load(y); ClassFormat.putInsn(topCtx.m, Opcodes.IADD)\n END\n ELSE (*op = ORS.minus*)\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := x.a - y.a\n ELSIF y.mode = OJB.Const THEN\n load(x);\n IF y.a # 0 THEN load(y); ClassFormat.putInsn(topCtx.m, Opcodes.ISUB) END\n ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.ISUB)\n END\n END\n END AddOp;\n\n (*\n The log2(x) is the number of bits needed to represent the value of a\n positive x. As The result is a real number\n we actually compute the ceiling(log2(x)).\n Ex. log2(5) = 2.32 -> ceiling(2.32) = 3 in fact 5 is 101 in binary\n This means that to implement log2(x) we count how many bits we have until\n we reach the Most Significant Bit.\n So we basically shift x by one in a loop until x = 1 i.e. the\n MSB ( while(x # 1) { x = x >> 1; res++;} ceiling(res);)\n\n Here however, we are interested in the log2(x) where x is a power of 2.\n ex. 2^3 = 1000 = 1 * 2^3 + 0 * 2^2 + 0 * 2^1 + 0 * 2^0\n All the power of 2 have the MSB set to 1 and the rest of the bits set to 0.\n So we can stop the loop when we find the first 1 and check at the call site\n (log2(x) = 1) to know if x is indeed a power of 2.\n Also remember that log2(2^k) = k = ceiling(k) as there is no fractional\n part.\n *)\n\n PROCEDURE log2(m: INTEGER; VAR e: INTEGER): INTEGER;\n BEGIN e := 0;\n WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ;\n RETURN m\n END log2;\n\n PROCEDURE MulOp*(VAR x, y: Item); (* x := x * y *)\n VAR e: INTEGER;\n BEGIN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := x.a * y.a\n ELSIF (y.mode = OJB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN\n load(x); pushConst(e);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n ELSIF x.mode = OJB.Const THEN\n load(y);\n IF (x.a >= 2) & (log2(x.a, e) = 1) THEN\n pushConst(e);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHL);\n ELSIF x.a # 0 THEN\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.IMUL)\n END ;\n x.mode := Stack\n ELSE load(x); load(y); ClassFormat.putInsn(topCtx.m, Opcodes.IMUL)\n END\n END MulOp;\n\n (*\n Delayed code generation is used to implement constant folding\n Given VAR i,j : INTEGER; a : ARRAY 10 OF INTEGER;\n i := 2 + a[1+3];\n will be compiled as i := a[4] + 2:\n GETSTATIC A.a : [I\n ICONST_4\n IALOAD\n ICONST_2\n IADD\n PUTSTATIC A.i : I\n We delay the code generation for the first operands of both additions.\n In the first addition 2 will be emitted after the evaluation of a[1+3] as\n at that point is clear that no constant folding is possible between 2 and a.\n In the second addition we delay the emission of 1 as it could be folded as\n indeed happens as the second operand is the constant 3.\n The statement\n i := 2 - a[j+3];\n Will be compiled as i = 2 - a[j + 3];\n GETSTATIC A.a : [I\n GETSTATIC A.j : I\n ICONST_3\n IADD\n IALOAD\n ICONST_2\n SWAP\n ISUB\n PUTSTATIC A.i : I\n Notice the presence of an extra SWAP. Because 2 is emitted after evaluating\n a[j+3] and because - is not commutative we need to swap the argument of the\n ISUB instruction.\n *)\n\n PROCEDURE loadOp*(VAR x: Item);\n BEGIN\n IF x.mode # OJB.Const THEN\n load(x)\n END\n END loadOp;\n\n PROCEDURE SetLineNumber*(line: INTEGER);\n BEGIN\n ClassFormat.addLineNumber(topCtx.m, line)\n END SetLineNumber;\n\n PROCEDURE Trap(msg: ARRAY OF CHAR);\n BEGIN\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.NEW,\n \"java/lang/RuntimeException\");\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP);\n ClassFormat.putLdcInsnStr(topCtx.m, msg, FALSE);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL,\n \"java/lang/RuntimeException\", \"\",\n \"(Ljava/lang/String;)V\", 1);\n ClassFormat.putInsn(topCtx.m, Opcodes.ATHROW)\n END Trap;\n\n PROCEDURE TrapWithCond(cond: INTEGER; msg: ARRAY OF CHAR);\n VAR L: INTEGER;\n BEGIN\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP);\n L := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, negated(cond), 0);\n Trap(msg);\n Fixup(L)\n END TrapWithCond;\n\n PROCEDURE DivOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *)\n VAR e: INTEGER; skip: BOOLEAN;\n BEGIN\n skip := FALSE;\n IF op = OJS.div THEN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n (* Euclidean division, use y.a > 0 for Floored division *)\n IF y.a # 0 THEN\n x.a := x.a DIV y.a\n ELSE\n OJS.Mark(\"bad divisor\")\n END\n ELSIF (y.mode = OJB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN\n load(x); pushConst(e);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHR)\n ELSE\n (* Euclidean division, use y.a <= 0 for Floored division *)\n IF y.mode = OJB.Const THEN\n IF y.a = 0 THEN OJS.Mark(\"bad divisor\")\n ELSIF y.a > 0 THEN skip := TRUE END\n END ;\n loadAndMaybeSwap(x, y);\n (* Euclidean division, use Opcodes.IFLE for Floored division *)\n IF check & ~skip THEN TrapWithCond(Opcodes.IFEQ, \"bad divisor\") END ;\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n \"OberonRuntime\", \"DIV\", \"(II)I\", 2)\n END\n ELSE (*op := ORS.mod*)\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n (* Euclidean division, use y.a > 0 for Floored division *)\n IF y.a # 0 THEN\n x.a := x.a MOD y.a\n ELSE\n OJS.Mark(\"bad modulus\")\n END\n ELSIF (y.mode = OJB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN\n load(x); pushConst(y.a-1);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n ELSE\n (* Euclidean division, use y.a <= 0 for Floored division *)\n IF (y.mode = OJB.Const) & (y.a = 0) THEN OJS.Mark(\"bad modulus\")\n ELSE skip := TRUE END ;\n loadAndMaybeSwap(x, y);\n (* Euclidean division, use Opcodes.IFLE for Floored division *)\n IF check & ~skip THEN TrapWithCond(Opcodes.IFEQ, \"bad modulus\") END ;\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n \"OberonRuntime\", \"MOD\", \"(II)I\", 2)\n END\n END\n END DivOp;\n\n (* Code generation for REAL operators *)\n\n PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *)\n BEGIN\n IF op = OJS.plus THEN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) +SYSTEM.VAL(REAL, y.a))\n ELSE\n loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FADD)\n END ;\n ELSIF op = OJS.minus THEN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) -SYSTEM.VAL(REAL, y.a))\n ELSE\n loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FSUB)\n END ;\n ELSIF op = OJS.times THEN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) *SYSTEM.VAL(REAL, y.a))\n ELSE\n loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FMUL)\n END ;\n ELSE (* op = ORS.rdiv *)\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) /SYSTEM.VAL(REAL, y.a))\n ELSE\n loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FDIV)\n END ;\n END\n END RealOp;\n\n (* Code generation for set operators *)\n\n PROCEDURE Singleton*(VAR x: Item); (* x := {x} *)\n BEGIN\n IF x.mode = OJB.Const THEN x.a := LSL(1, x.a)\n ELSIF x.mode # OJB.Var THEN\n load(x);\n pushConst(1);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n ELSE pushConst(1); load(x); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n END\n END Singleton;\n\n (*\n Example s := {3..5}\n\n -1 = 11111111111111111111111111111111\n -2 = 11111111111111111111111111111110\n LSL(-1, 3) = 11111111111111111111111111111000\n LSL(-2, 5) = 11111111111111111111111111000000\n LSL(-1, 3) - LSL(-2, 5)\n = 11111111111111111111111111111000 - 11111111111111111111111111000000\n = 11111111111111111111111111111000 + 00000000000000000000000000111111\n + 1 (two's complement)\n = 11111111111111111111111111111001 + 00000000000000000000000000111111\n = 00000000000000000000000000111000\n = 56\n LSL(2, 5) - LSL(1, 3)\n = 00000000000000000000000001000000 - 00000000000000000000000000001000\n = 00000000000000000000000001000000 + 11111111111111111111111111110111\n + 1 (two's complement)\n = 00000000000000000000000001000001 + 11111111111111111111111111110111\n = 00000000000000000000000000111000\n = 56\n\n\n = LSL(-1, 3) & ~LSL(-2, 5)\n = 11111111111111111111111111111000 & 00000000000000000000000000111111\n\n = (LSL(-2, 5) xor -1) & LSL(-1, 3) // where LSL(-1, 3) is computed\n // at compile time\n = ~LSL(-2, 5) & LSL(-1, 3) // there is no Not institution in RISC\n\n\n *)\n\n PROCEDURE Set0*(VAR x: Item); (* x := {x .. y} *)\n BEGIN\n (* delay generation if x is constant, handle it in Set1 *)\n IF x.mode # OJB.Const THEN\n IF x.mode # OJB.Var THEN\n load(x);\n pushConst(-1);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n ELSE pushConst(-1); load(x); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n END\n END\n END Set0;\n\n PROCEDURE Set1*(VAR x, y: Item); (* x := {x .. y} *)\n BEGIN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n IF x.a <= y.a THEN x.a := LSL(-1, x.a) - LSL(-2, y.a) ELSE x.a := 0 END\n ELSE\n IF y.mode = OJB.Const THEN\n pushConst(LSL(-2, y.a)); y.mode := Stack\n ELSIF y.mode # OJB.Var THEN\n load(y);\n pushConst(-2);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n ELSE pushConst(-2); load(y); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n END ;\n IF x.mode = OJB.Const THEN\n pushConst(LSL(-1, x.a)); x.mode := Stack;\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP)\n END ;\n ClassFormat.putInsn(topCtx.m, Opcodes.ISUB);\n END\n END Set1;\n\n (*\n Example\n\n s := 4 in {3..5}\n\n {3..5} = 56 = 00000000000000000000000000111000\n 4 = 100\n We add 1 as our set is 0 based\n 4 + 1 = 5 = 101\n\n ROR(56, 5) = 11000000000000000000000000000001\n -> as the most significant bit is set to 1 this number is\n negative so it means that 4 is indeed in {3..5}\n\n Alternately as in the JVM ROR will be implemented with too many\n instructions (i.e. (x >>> n) | (x << -n) )\n\n LSL(1, 4) = 00000000000000000000000000010000\n LSL(1, 4) & {3..5} = 00000000000000000000000000010000 &\n 00000000000000000000000000111000\n = 00000000000000000000000000010000\n -> the result is not 0 so it means that 4 is\n indeed in {3..5}\n\n x IN y\n If x is not in the implementation defined SET range {0..MaxSetElement-1}\n the IN operator is undefined\n *)\n\n PROCEDURE In0*(VAR x: Item); (* x := x IN y *)\n BEGIN\n IF x.mode = OJB.Const THEN\n x.a := LSL(1, x.a);\n load(x)\n ELSE\n load(x);\n pushConst(1);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISHL)\n END ;\n SetCC(x, Opcodes.IFNE)\n END In0;\n\n PROCEDURE In1*(VAR x: Item); (* x := x IN y *)\n BEGIN\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n END In1;\n\n (* See \"SET: A neglected data type, and its compilation for the ARM\" *)\n PROCEDURE SetOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *)\n VAR xset, yset: SET; (*x.type.form = Set*)\n BEGIN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a);\n IF op = OJS.plus THEN xset := xset + yset\n ELSIF op = OJS.minus THEN xset := xset - yset\n ELSIF op = OJS.times THEN xset := xset * yset\n ELSIF op = OJS.rdiv THEN xset := xset / yset\n END ;\n x.a := SYSTEM.VAL(INTEGER, xset)\n ELSE\n loadAndMaybeSwap(x, y);\n IF op = OJS.plus THEN ClassFormat.putInsn(topCtx.m, Opcodes.IOR)\n ELSIF op = OJS.minus THEN\n (*ANN*)\n pushConst(-1);\n ClassFormat.putInsn(topCtx.m, Opcodes.IXOR);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n ELSIF op = OJS.times THEN ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n ELSIF op = OJS.rdiv THEN ClassFormat.putInsn(topCtx.m, Opcodes.IXOR)\n END\n END\n END SetOp;\n\n (* Code generation for relations *)\n\n PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *)\n BEGIN\n IF (y.mode = OJB.Const) & (y.type.form # OJB.Proc) & (y.a = 0) THEN\n load(x);\n IF y.type.form = OJB.NilTyp THEN\n SetCC(x, relmapNil[op - OJS.eql])\n ELSE\n SetCC(x, relmap0[op - OJS.eql])\n END\n ELSE\n loadAndMaybeSwap(x, y);\n IF (x.type.form = OJB.Pointer) OR (x.type.form = OJB.Proc) OR\n (x.type.form = OJB.NilTyp) THEN\n SetCC(x, relmapAdr[op - OJS.eql])\n ELSE\n SetCC(x, relmap[op - OJS.eql])\n END\n END\n END IntRelation;\n\n PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *)\n BEGIN\n loadAndMaybeSwap(x, y);\n IF (op = OJS.lss) OR (op = OJS.leq) THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.FCMPG)\n ELSE\n ClassFormat.putInsn(topCtx.m, Opcodes.FCMPL)\n END ;\n SetCC(x, relmap0[op - OJS.eql])\n END RealRelation;\n\n PROCEDURE StrToChar*(VAR x: Item);\n BEGIN\n x.type := OJB.charType; x.a := ORD(OJS.ExtractChar(x.a))\n END StrToChar;\n\n PROCEDURE CharToStr*(VAR x: Item);\n VAR c: CHAR;\n BEGIN\n c := CHR(x.a);\n x.mode := OJB.Const; x.type := OJB.strType; x.a := OJS.InsertChar(c);\n x.b := 2; (* 1 char + 0X *) x.rdo := TRUE\n END CharToStr;\n\n PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *)\n BEGIN\n (*x, y are char arrays or strings*)\n IF (x.type.form = OJB.String) & (x.b = 2) & (y.type.form = OJB.String) &\n (y.b = 2) THEN\n StrToChar(x); StrToChar(y);\n IntRelation(op, x, y)\n ELSIF (x.type.form # OJB.String) & (y.type.form = OJB.String) &\n (y.b = 1) THEN (* x := x < \"\" *)\n load(x);\n pushConst(0);\n pushTypedArray(x.type.base);\n SetCC(x, relmap0[op - OJS.eql])\n ELSIF (x.type.form = OJB.String) & (y.type.form # OJB.String) THEN\n load(y);\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL,\n \"java/lang/String\", \"toCharArray\", \"()[C\", 0);\n x.mode := Stack;\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n \"OberonRuntime\", \"StrCmp\", \"([C[C)I\", 2);\n SetCC(x, relmap0[op - OJS.eql])\n ELSE\n load(x);\n IF x.type.form = OJB.String THEN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL,\n \"java/lang/String\", \"toCharArray\", \"()[C\", 0);\n x.mode := Stack\n END ;\n load(y);\n IF y.type.form = OJB.String THEN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL,\n \"java/lang/String\", \"toCharArray\", \"()[C\", 0);\n x.mode := Stack\n END ;\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n \"OberonRuntime\", \"StrCmp\", \"([C[C)I\", 2);\n SetCC(x, relmap0[op - OJS.eql])\n END\n END StringRelation;\n\n PROCEDURE makeCopyDesc(VAR s, desc: ARRAY OF CHAR);\n VAR i: INTEGER;\n BEGIN\n i := Strings.Write(\"(L\", desc, 0);\n i := Strings.Write(s, desc, i);\n i := Strings.Write(\";)V\", desc, i);\n IF i = -1 THEN OJS.Mark(\"Maximum descriptor length reached\") END\n END makeCopyDesc;\n\n\n (* Code generation of Assignments *)\n\n PROCEDURE Store*(VAR x, y: Item; storeStruct: BOOLEAN); (* x := y *)\n VAR desc, typeName :ClassFormat.Descriptor;\n BEGIN\n load(y);\n IF storeStruct THEN\n internalName(x.type, typeName);\n makeCopyDesc(typeName, desc);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, typeName,\n \"copyFrom\", desc, 1)\n ELSE\n IF (x.mode = OJB.Var) OR (x.mode = Stack) OR (x.mode = OJB.ParStruct) THEN\n IF x.r > 0 THEN (*local*)\n storeTypedLocal(x)\n ELSE\n Descriptor(x.type, desc);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, x.modName,\n x.name, desc)\n END\n ELSIF x.mode = RegI THEN\n storeTypedArray(x.type)\n ELSIF x.mode = Field THEN\n Descriptor(x.type, desc);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTFIELD, x.recordName,\n x.name, desc)\n ELSIF x.mode = OJB.Par THEN\n storeTypedArray(x.type)\n ELSE OJS.Mark(\"illegal assignment\")\n END\n END\n END Store;\n\n PROCEDURE storeArrayR(i: INTEGER; type: OJB.Type; VAR x, y: Item);\n VAR desc, iname: ClassFormat.Descriptor;\n cond, end, lastTmp, index: INTEGER;\n BEGIN\n IF type.form = OJB.Array THEN\n IF type.len < 0 THEN\n (*\n only monodimensional open arrays are supported.\n ex.\n PROCEDURE P(VAR b : ARRAY OF ARRAY OF INTEGER);\n VAR c: ARRAY 10, 10 OF INTEGER;\n BEGIN\n c := b; (* illegal see Type Rule E.6, B.2, B.3 *)\n END P;\n *)\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH);\n pushConst(1);\n ClassFormat.putInsn(topCtx.m, Opcodes.ISUB)\n ELSE\n pushConst(type.len - 1)\n END ;\n (* topCtx.numTmpVars is the first free local to use *)\n index := i + topCtx.numTmpVars;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, index);\n cond := topCtx.m.i;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, index);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFLT, 0);\n storeArrayR(i + 1, type.base, x, y);\n ClassFormat.putIincInsn(topCtx.m, index, -1);\n ClassFormat.putGotoInsn(topCtx.m, cond-topCtx.m.i, 0);\n Fixup(end)\n ELSE\n (* as we incremented index(= last used local) we have to\n update topCtx.numTmpVars as it is still pointing to the\n first used local *)\n IF ~isPrimitiveType(type) & (type.form # OJB.Pointer) &\n (type.form # OJB.Proc) THEN\n topCtx.numTmpVars := topCtx.numTmpVars + i + 1;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n lastTmp := pushIndexes2(i+1);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a);\n lastTmp := pushIndexes2(i+1);\n internalName(type, iname);\n makeCopyDesc(iname, desc);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname,\n \"copyFrom\", desc, 1);\n ELSE\n topCtx.numTmpVars := topCtx.numTmpVars + i;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n lastTmp := pushIndexes2(i);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a);\n lastTmp := pushIndexes2(i);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp);\n pushTypedArray(type);\n storeTypedArray(type)\n END\n END\n END storeArrayR;\n\n PROCEDURE storeTempLocal(VAR x: Item);\n BEGIN\n load(x);\n x.a := topCtx.numTmpVars;\n storeTypedLocal(x);\n INC(topCtx.numTmpVars)\n END storeTempLocal;\n\n PROCEDURE storeArray*(VAR x, y: Item);\n VAR end: INTEGER;\n BEGIN\n load(y);\n y.a := topCtx.numTmpVars;\n storeTypedLocal(y);\n INC(topCtx.numTmpVars);\n (* OJP guarantees x and y are regular arrays (not open) with equal element\n types and length or x is a regular array, y is an open array with equal\n base type *)\n IF (check) & (y.type.len < 0) THEN (*open array len*)\n pushConst(x.type.len);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPGE, 0);\n Trap(\"array copy overflow\");\n Fixup(end)\n END ;\n IF isPrimitiveType(x.type.base) THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a);\n pushConst(0);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n pushConst(0);\n IF y.type.len < 0 THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH)\n ELSE\n pushConst(y.type.len)\n END ;\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n \"java/lang/System\", \"arraycopy\",\n \"(Ljava/lang/Object;ILjava/lang/Object;II)V\", 5)\n ELSE\n storeArrayR(0, y.type, x, y)\n END\n END storeArray;\n\n PROCEDURE StoreProc*(VAR x, y: Item); (* x := y *)\n BEGIN\n IF y.mode = OJB.Const THEN\n load(y)\n END ;\n Store(x, y, FALSE)\n END StoreProc;\n\n PROCEDURE ValueParam*(VAR x: Item);\n BEGIN\n load(x)\n END ValueParam;\n\n PROCEDURE StringParam*(VAR x: Item);\n BEGIN\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL,\n \"java/lang/String\", \"toCharArray\", \"()[C\", 0)\n END StringParam;\n\n PROCEDURE CopyString*(VAR x, y: Item); (* x := y *)\n VAR len, end: INTEGER;\n BEGIN\n len := x.type.len;\n IF len >= 0 THEN\n IF len < y.b THEN OJS.Mark(\"string too long\") END\n ELSIF check THEN (*open array len*)\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH);\n pushConst(y.b);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPGE, 0);\n Trap(\"string too long\");\n Fixup(end)\n END ;\n IF y.b = 1 THEN (* x := \"\" *)\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n pushConst(0);\n pushConst(0);\n ClassFormat.putInsn(topCtx.m, Opcodes.CASTORE)\n ELSE\n StringParam(y);\n pushConst(0);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n pushConst(0);\n pushConst(y.b);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n \"java/lang/System\", \"arraycopy\",\n \"(Ljava/lang/Object;ILjava/lang/Object;II)V\", 5)\n END\n END CopyString;\n\n PROCEDURE loadPar*(VAR x: Item);\n BEGIN\n IF x.mode = OJB.Par THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0)\n END\n END loadPar;\n\n PROCEDURE VarParam*(VAR x: Item);\n VAR desc: ClassFormat.Descriptor;\n newStoreStmt: StoreStmt;\n type, newType: OJB.Type;\n BEGIN\n IF (x.mode = OJB.Par) & (x.oldType = NIL) THEN\n (* x is already a var parameter with no type guard, so pass it by value *)\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a)\n ELSE\n IF x.oldType # NIL THEN\n newType := x.oldType\n ELSE\n newType := x.type\n END ;\n NEW(newStoreStmt);\n IF x.mode = Field THEN\n newStoreStmt.x.a := topCtx.numTmpVars;\n newStoreStmt.x.mode := x.mode;\n Strings.Copy(x.recordName, newStoreStmt.x.recordName);\n Strings.Copy(x.modName, newStoreStmt.x.modName);\n Strings.Copy(x.name, newStoreStmt.x.name);\n newStoreStmt.x.type := newType;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, newStoreStmt.x.a);\n INC(topCtx.numTmpVars)\n ELSIF x.mode = RegI THEN\n newStoreStmt.x.a := topCtx.numTmpVars;\n INC(topCtx.numTmpVars);\n newStoreStmt.x.b := topCtx.numTmpVars;\n INC(topCtx.numTmpVars);\n newStoreStmt.x.mode := x.mode;\n Strings.Copy(x.name, newStoreStmt.x.name);\n Strings.Copy(x.modName, newStoreStmt.x.modName);\n newStoreStmt.x.type := newType;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, newStoreStmt.x.b);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, newStoreStmt.x.a)\n ELSIF (x.mode = OJB.Var) OR (x.oldType # NIL) THEN\n newStoreStmt.x.a := x.a;\n newStoreStmt.x.r := x.r;\n newStoreStmt.x.mode := x.mode;\n Strings.Copy(x.name, newStoreStmt.x.name);\n Strings.Copy(x.modName, newStoreStmt.x.modName);\n newStoreStmt.x.type := newType\n ELSE OJS.Mark(\"Only variables allowed\")\n END ;\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST1);\n type := x.type;\n IF isPrimitiveType(type) THEN\n emitPrimitiveNewArray(type)\n ELSIF type.form = OJB.Array THEN\n Descriptor(type, desc);\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, desc)\n ELSE\n internalName(type, desc);\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, desc)\n END ;\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP);\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0);\n IF x.mode = Field THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, newStoreStmt.x.a)\n ELSIF x.mode = RegI THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, newStoreStmt.x.a);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, newStoreStmt.x.b)\n END ;\n load(x);\n storeTypedArray(x.type);\n newStoreStmt.y.a := topCtx.numTmpVars;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, topCtx.numTmpVars);\n INC(topCtx.numTmpVars);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, newStoreStmt.y.a);\n newStoreStmt.y.mode := RegI;\n newStoreStmt.y.type := type;\n newStoreStmt.next := topCtx.storeStmt;\n topCtx.storeStmt := newStoreStmt\n END\n END VarParam;\n\n PROCEDURE storeVarPar*;\n VAR h: StoreStmt;\n BEGIN\n h := topCtx.storeStmt;\n WHILE h # NIL DO\n IF h.x.mode = Field THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.x.a)\n ELSIF h.x.mode = RegI THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.x.a);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, h.x.b)\n ELSIF h.x.mode = OJB.Par THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.x.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0)\n END ;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.y.a);\n ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0);\n Store(h.x, h.y, FALSE);\n h := h.next;\n END ;\n topCtx.storeStmt := NIL\n END storeVarPar;\n\n PROCEDURE PrepAssign*(VAR x: Item);\n BEGIN\n IF x.type.form = OJB.Array THEN\n storeTempLocal(x)\n ELSIF x.type.form = OJB.Record THEN\n load(x)\n ELSE\n loadPar(x)\n END\n END PrepAssign;\n\n PROCEDURE For0*(VAR x, y: Item);\n BEGIN\n Store(x, y, FALSE)\n END For0;\n\n PROCEDURE For1*(VAR x, z, w: Item): INTEGER;\n VAR L, oldMode: INTEGER;\n BEGIN\n load(z);\n oldMode := x.mode;\n load(x);\n x.mode := oldMode;\n L := topCtx.m.i;\n IF w.a < 0 THEN ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPGT, 0)\n ELSIF w.a > 0 THEN ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPLT, 0)\n ELSE OJS.Mark(\"zero increment\")\n END\n RETURN L\n END For1;\n\n PROCEDURE For2*(VAR x, w: Item);\n BEGIN\n IF (x.mode = OJB.Var) & (x.r > 0) THEN\n ClassFormat.putIincInsn(topCtx.m, x.a, w.a)\n ELSIF x.mode = OJB.Par THEN\n loadPar(x);\n AddOp(OJS.plus, x, w);\n w.mode := Stack;\n x.mode := OJB.Par;\n Store(x, w, FALSE)\n ELSE\n AddOp(OJS.plus, x, w);\n w.mode := Stack;\n Store(x, w, FALSE)\n END\n END For2;\n\n PROCEDURE CaseIn*(VAR x: Item; L: INTEGER): INTEGER;\n BEGIN\n storeTempLocal(x)\n RETURN FJump(L)\n END CaseIn;\n\n PROCEDURE CaseDefault*(): INTEGER;\n VAR dflt: INTEGER;\n BEGIN\n dflt := topCtx.m.i;\n Trap(\"Invalid case in CASE statement\")\n RETURN dflt\n END CaseDefault;\n\n PROCEDURE CaseOut*(VAR caseExpr: Item; end, L0, n, dflt: INTEGER;\n tab: ARRAY OF LabelRange);\n VAR max, lastLow, nLables, i, j: INTEGER;\n all: ARRAY NofCases OF INTEGER;\n BEGIN\n IF n > 0 THEN\n max := tab[n-1].high;\n lastLow := tab[0].low;\n nLables := ABS(max - lastLow + 1);\n ELSE\n max := 0; lastLow := 0; nLables := 0;\n END ;\n IF nLables <= NofCases THEN\n ClassFormat.FixLink(topCtx.m, L0);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, caseExpr.a);\n dflt := dflt-topCtx.m.i;\n i := 0; j := 0;\n WHILE j < n DO\n WHILE lastLow < tab[j].low DO\n all[i] := dflt;\n INC(i);\n INC(lastLow)\n END ;\n WHILE lastLow <= tab[j].high DO\n all[i] := tab[j].L-topCtx.m.i;\n INC(i);\n INC(lastLow)\n END ;\n INC(j)\n END ;\n ClassFormat.putTableSwitchInsn(topCtx.m, tab[0].low, max,\n dflt, nLables, all);\n ClassFormat.FixLink(topCtx.m, end)\n ELSE OJS.Mark(\"too many cases or no case in case statement\")\n END\n END CaseOut;\n\n PROCEDURE PrepCall*(VAR x: Item);\n BEGIN\n (*x.type.form = OJB.Proc*)\n IF x.mode # OJB.Const THEN\n (*call on procedure variable*)\n load(x)\n END\n END PrepCall;\n\n PROCEDURE Call*(VAR x: Item);\n VAR iname: ClassFormat.Descriptor;\n BEGIN\n (*x.type.form = OJB.Proc*)\n IF x.mode = OJB.Const THEN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, x.modName,\n x.name, x.type.signature, x.type.nofpar)\n ELSE\n internalName(x.type, iname);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname,\n \"invoke\", x.type.signature, x.type.nofpar)\n END ;\n IF x.type.base.form # OJB.NoTyp THEN (*function*)\n x.mode := Stack\n END\n END Call;\n\n PROCEDURE Enter*(proc: OJB.Object; locblksize: INTEGER);\n VAR acc: INTEGER;\n nestedName: ARRAY OJS.IdLen + ClassFormat.nestedIdLen OF CHAR;\n BEGIN\n acc := Opcodes.ACCxSTATIC + Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL;\n IF proc.nestedId > 0 THEN\n Strings.Copy(proc.name, nestedName);\n Strings.AppendInt(proc.nestedId, 0, nestedName);\n topCtx.m := ClassFormat.NewMI(topCtx.c, acc, nestedName,\n proc.type.signature)\n ELSE\n topCtx.m := ClassFormat.NewMI(topCtx.c, acc, proc.name,\n proc.type.signature)\n END;\n clearCtx(topCtx);\n initializeScope(getLocalVars(proc.type.dsc, proc.type.nofpar), locblksize)\n END Enter;\n\n PROCEDURE Return*(type: OJB.Type; VAR x: Item);\n BEGIN\n IF (type # NIL) & (type.form # OJB.NoTyp) THEN\n load(x);\n IF type = OJB.byteType THEN\n pushConst(255);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n END ;\n emitTypedReturn(x.type)\n ELSE ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx)\n END ;\n ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars);\n closeContext\n END Return;\n\n PROCEDURE Increment1*(upordown: INTEGER; VAR x, y, z: Item);\n VAR op: INTEGER;\n BEGIN\n IF upordown = 0 THEN op := Opcodes.IADD ELSE op := Opcodes.ISUB END ;\n IF y.type.form = OJB.NoTyp THEN y.mode := OJB.Const; y.a := 1 END ;\n IF (x.mode = OJB.Var) & (x.r > 0) & (y.mode = OJB.Const) &\n (y.a >= -128) & (y.a <= 127) THEN\n IF op = Opcodes.ISUB THEN y.a := -y.a END ;\n ClassFormat.putIincInsn(topCtx.m, x.a, y.a)\n ELSE\n IF (x.mode = OJB.Var) & (x.r > 0) THEN\n z := x;\n IF y.mode IN {OJB.Const, OJB.Var} THEN load(x); load(y)\n ELSE\n load(y);\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP)\n END\n ELSE\n load(y)\n END ;\n ClassFormat.putInsn(topCtx.m, op);\n Store(z, x, FALSE)\n END\n END Increment1;\n\n PROCEDURE Increment0*(VAR x, z: Item);\n BEGIN\n IF (x.mode # OJB.Var) OR (x.r = 0) THEN\n z := x;\n IF x.mode = RegI THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP2)\n ELSIF x.mode = Field THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP)\n END ;\n IF x.mode = OJB.Par THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n pushConst(0);\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP2);\n pushTypedArray(x.type);\n x.mode := Stack\n ELSE\n load(x)\n END ;\n END\n END Increment0;\n\n PROCEDURE Include0*(VAR x, z: Item);\n BEGIN\n z := x;\n IF x.mode = RegI THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP2)\n ELSIF x.mode = Field THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP)\n END ;\n IF x.mode = OJB.Par THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a);\n pushConst(0);\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP2);\n pushTypedArray(x.type);\n x.mode := Stack\n ELSE\n load(x)\n END ;\n END Include0;\n\n PROCEDURE Include1*(inorex: INTEGER; VAR y, z: Item);\n BEGIN\n Singleton(y);\n load(y);\n IF inorex = 0 THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.IOR)\n ELSE\n pushConst(-1);\n ClassFormat.putInsn(topCtx.m, Opcodes.IXOR);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n END ;\n Store(z, y, FALSE)\n END Include1;\n\n PROCEDURE Assert*(VAR x: Item);\n VAR L0: INTEGER;\n BEGIN\n IF x.mode # Cond THEN loadCond(x) END ;\n L0 := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, x.r, x.b);\n ClassFormat.FixLink(topCtx.m, x.a); x.b := L0;\n Trap(\"assertion violated\");\n ClassFormat.FixLink(topCtx.m, x.b)\n END Assert;\n\n PROCEDURE New*(VAR x: Item);\n VAR iname: ClassFormat.Descriptor;\n dummy: Item;\n BEGIN\n loadPar(x);\n dummy.mode := Stack;\n internalName(x.type, iname);\n genNew(iname);\n Store(x, dummy, FALSE)\n END New;\n\n PROCEDURE ReadInt*(VAR x: Item);\n BEGIN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"ReadInt\", \"()I\", 0);\n x.mode := Stack\n END ReadInt;\n\n PROCEDURE eot*(VAR x: Item);\n BEGIN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"eot\", \"()Z\", 0);\n x.mode := Stack\n END eot;\n\n PROCEDURE WriteInt*(VAR x: Item);\n BEGIN\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"WriteInt\", \"(I)V\", 1)\n END WriteInt;\n\n PROCEDURE WriteReal*(VAR x: Item);\n BEGIN\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"WriteReal\", \"(F)V\", 1)\n END WriteReal;\n\n PROCEDURE WriteChar*(VAR x: Item);\n BEGIN\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"WriteChar\", \"(I)V\", 1)\n END WriteChar;\n\n PROCEDURE WriteLn*;\n BEGIN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"WriteLn\", \"()V\", 0)\n END WriteLn;\n\n PROCEDURE Args0*;\n BEGIN\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, topCtx.className,\n \"args\", \"[Ljava/lang/String;\");\n END Args0;\n\n PROCEDURE Args1*(VAR x: Item);\n BEGIN\n load(x)\n END Args1;\n\n PROCEDURE Args2*(VAR y: Item);\n BEGIN\n load(y);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"ARGS\", \"([Ljava/lang/String;I[C)V\", 3)\n END Args2;\n\n PROCEDURE Abs*(VAR x: Item);\n VAR f: REAL; end: INTEGER;\n BEGIN\n IF x.mode = OJB.Const THEN\n IF x.type.form = OJB.Real THEN\n f := ABS(SYSTEM.VAL(REAL, x.a));\n x.a := SYSTEM.VAL(INTEGER, f)\n ELSE x.a := ABS(x.a)\n END\n ELSE load(x);\n IF x.type.form = OJB.Real THEN\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP);\n ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0);\n ClassFormat.putInsn(topCtx.m, Opcodes.FCMPG);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFGT, 0);\n ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0);\n ClassFormat.putInsn(topCtx.m, Opcodes.SWAP);\n ClassFormat.putInsn(topCtx.m, Opcodes.FSUB);\n Fixup(end)\n ELSE\n ClassFormat.putInsn(topCtx.m, Opcodes.DUP);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFGE, 0);\n ClassFormat.putInsn(topCtx.m, Opcodes.INEG);\n Fixup(end)\n END\n END\n END Abs;\n\n PROCEDURE Odd*(VAR x: Item);\n BEGIN\n IF x.mode = OJB.Const THEN\n x.a := ORD(ODD(x.a))\n ELSE\n load(x);\n pushConst(1);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND);\n SetCC(x, Opcodes.IFNE)\n END\n END Odd;\n\n PROCEDURE Floor*(VAR x: Item);\n VAR f: REAL;\n BEGIN\n IF x.mode = OJB.Const THEN\n f := SYSTEM.VAL(REAL, x.a);\n x.a := FLOOR(f)\n ELSE\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.F2D);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"java/lang/Math\",\n \"floor\", \"(D)D\", 1);\n ClassFormat.putInsn(topCtx.m, Opcodes.D2I)\n END\n END Floor;\n\n PROCEDURE IntToReal*(VAR x: Item);\n BEGIN\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"java/lang/Float\",\n \"intBitsToFloat\", \"(I)F\", 1)\n END IntToReal;\n\n PROCEDURE RealToInt*(VAR x: Item);\n BEGIN\n load(x);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"java/lang/Float\",\n \"floatToRawIntBits\", \"(F)I\", 1)\n END RealToInt;\n\n PROCEDURE Float*(VAR x: Item);\n BEGIN\n IF x.mode = OJB.Const THEN\n x.a := SYSTEM.VAL(INTEGER, FLT(x.a))\n ELSE\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.I2F)\n END\n END Float;\n\n PROCEDURE Ord*(VAR x: Item);\n BEGIN\n (* allow constant folding: ORD(\"A\") + 1 *)\n IF x.mode # OJB.Const THEN\n load(x)\n END\n END Ord;\n\n PROCEDURE Len*(VAR x: Item);\n BEGIN\n IF x.type.len >= 0 THEN\n Pop(x);\n x.mode := OJB.Const; x.a := x.type.len\n ELSE (*open array*)\n load(x);\n ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH);\n x.mode := Stack\n END\n END Len;\n\n PROCEDURE Argnum*(VAR x: Item);\n BEGIN\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, topCtx.className,\n \"args\", \"[Ljava/lang/String;\");\n ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH);\n x.mode := Stack\n END Argnum;\n\n PROCEDURE Shift*(fct: INTEGER; VAR x, y: Item);\n CONST Ror = 3;\n VAR op: INTEGER;\n BEGIN\n IF fct = 0 THEN\n op := Opcodes.ISHL\n ELSIF fct = 1 THEN\n op := Opcodes.ISHR\n ELSE op := Ror\n END ;\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n IF fct = 0 THEN\n x.a := LSL(x.a, y.a)\n ELSIF fct = 1 THEN\n x.a := ASR(x.a, y.a)\n ELSE\n x.a := ROR(x.a, y.a)\n END\n ELSE\n loadAndMaybeSwap(x, y);\n IF op = Ror THEN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, \"OberonRuntime\",\n \"ROR\", \"(II)I\", 2)\n ELSE\n ClassFormat.putInsn(topCtx.m, op)\n END\n END\n END Shift;\n\n PROCEDURE Band*(VAR x, y: Item);\n BEGIN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n x.a := AND(x.a, y.a)\n ELSE\n loadAndMaybeSwap(x, y);\n ClassFormat.putInsn(topCtx.m, Opcodes.IAND)\n END\n END Band;\n\n PROCEDURE Bor*(VAR x, y: Item);\n BEGIN\n IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN\n x.a := BOR(x.a, y.a)\n ELSE\n loadAndMaybeSwap(x, y);\n ClassFormat.putInsn(topCtx.m, Opcodes.IOR)\n END\n END Bor;\n\n PROCEDURE Bnot*(VAR x: Item);\n BEGIN\n IF x.mode = OJB.Const THEN\n x.a := NOT(x.a)\n ELSE\n load(x);\n pushConst(-1);\n ClassFormat.putInsn(topCtx.m, Opcodes.IXOR)\n END\n END Bnot;\n\n PROCEDURE Open*(modid: ARRAY OF CHAR);\n VAR ctx: ClassContext;\n BEGIN\n ClassFormat.Init;\n check := TRUE;\n NEW(ctx);\n Strings.Copy(modid, ctx.className);\n topCtx := ctx;\n topCtx.c := ClassFormat.NewCF(Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL,\n topCtx.className, \"java/lang/Object\");\n dummyMethod := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC, \"DUMMY\",\n \"()V\");\n topCtx.m := dummyMethod\n END Open;\n\n PROCEDURE Header*(topScope: OJB.Object);\n VAR desc: ClassFormat.Descriptor;\n tmp: OJB.Object;\n BEGIN\n ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC,\n \"args\", \"[Ljava/lang/String;\");\n tmp := topScope;\n WHILE tmp # NIL DO\n IF tmp.expo & (tmp.class = OJB.Const) & (tmp.type.form # OJB.Proc) &\n (tmp.type.form # OJB.String) THEN\n Descriptor(tmp.type, desc);\n ClassFormat.addConstField(topCtx.c, tmp.name, desc, tmp.val)\n ELSIF tmp.class = OJB.Var THEN\n Descriptor(tmp.type, desc);\n ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC,\n tmp.name, desc)\n END ;\n tmp := tmp.next\n END\n END Header;\n\n PROCEDURE copyRecord(x: OJB.Object);\n VAR desc, iname: ClassFormat.Descriptor;\n BEGIN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n loadRef(x);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1);\n loadRef(x);\n internalName(x.type, iname);\n makeCopyDesc(iname, desc);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname,\"copyFrom\",\n desc, 1)\n END copyRecord;\n\n PROCEDURE copyPrimitiveField(x: OJB.Object);\n BEGIN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1);\n loadRef(x);\n storeRef(x)\n END copyPrimitiveField;\n\n PROCEDURE copyArrayR(i: INTEGER; x: OJB.Object; type: OJB.Type; tmpVars,\n currTmpVar: OJB.Object);\n VAR desc, iname: ClassFormat.Descriptor;\n lastTmp: OJB.Object;\n cond, end: INTEGER;\n BEGIN\n IF type.form = OJB.Array THEN\n pushConst(type.len - 1);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, currTmpVar.val);\n cond := topCtx.m.i;\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, currTmpVar.val);\n end := topCtx.m.i;\n ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFLT, 0);\n copyArrayR(i + 1, x, type.base, tmpVars, currTmpVar.next);\n ClassFormat.putIincInsn(topCtx.m, currTmpVar.val, -1);\n ClassFormat.putGotoInsn(topCtx.m, cond-topCtx.m.i, 0);\n Fixup(end)\n ELSE\n IF ~isPrimitiveType(type) & (type.form # OJB.Pointer) &\n (type.form # OJB.Proc) THEN\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n loadRef(x);\n lastTmp := pushIndexes(i+1, tmpVars);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1);\n loadRef(x);\n lastTmp := pushIndexes(i+1, tmpVars);\n internalName(type, iname);\n makeCopyDesc(iname, desc);\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname,\n \"copyFrom\", desc, 1)\n ELSE\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n loadRef(x);\n lastTmp := pushIndexes(i, tmpVars);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp.val);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1);\n loadRef(x);\n lastTmp := pushIndexes(i, tmpVars);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp.val);\n pushTypedArray(type);\n storeTypedArray(type)\n END\n END\n END copyArrayR;\n\n PROCEDURE copyArray(x, tmpVars: OJB.Object);\n BEGIN\n copyArrayR(0, x, x.type, tmpVars, tmpVars)\n END copyArray;\n\n PROCEDURE copyState(x: OJB.Object);\n VAR type: OJB.Type; tempVars: OJB.Object;\n num: INTEGER;\n BEGIN\n (* 2 locals so far: this + copyFrom's parameter *)\n num := 2;\n tempVars := createArraysTempVars(x, num, FALSE);\n WHILE x # NIL DO\n IF (x.class = OJB.Var) OR (x.class = OJB.Fld) THEN\n type := x.type;\n IF type.form = OJB.Record THEN\n copyRecord(x)\n ELSIF type.form = OJB.Array THEN\n copyArray(x, tempVars)\n ELSE\n copyPrimitiveField(x)\n END\n END ;\n x := x.next;\n END ;\n topCtx.numTmpVars := num\n END copyState;\n\n PROCEDURE CopyMethod(obj: OJB.Object);\n VAR desc,typeName: ClassFormat.Descriptor;\n BEGIN\n internalName(obj.type, typeName);\n makeCopyDesc(typeName, desc);\n topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC +\n Opcodes.ACCxFINAL, \"copyFrom\", desc);\n clearCtx(topCtx);\n copyState(obj.type.dsc);\n ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx);\n ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars);\n closeContext\n END CopyMethod;\n\n PROCEDURE MainProc*(hasMain: BOOLEAN);\n BEGIN\n topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC +\n Opcodes.ACCxSTATIC, \"main\",\n \"([Ljava/lang/String;)V\");\n clearCtx(topCtx);\n ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, topCtx.className,\n \"args\", \"[Ljava/lang/String;\");\n IF hasMain THEN\n ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC,\n topCtx.className, \"Main\", \"()V\", 0)\n END ;\n ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx);\n ClassFormat.setMaxVars(topCtx.m, 1);\n closeContext\n END MainProc;\n\n PROCEDURE addCmdLineArgs;\n BEGIN\n pushConst(0);\n ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, \"java/lang/String\");\n ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, topCtx.className,\n \"args\", \"[Ljava/lang/String;\")\n END addCmdLineArgs;\n\n PROCEDURE ModuleBody*(topScope: OJB.Object);\n BEGIN\n topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxSTATIC, \"\",\n \"()V\");\n clearCtx(topCtx);\n addCmdLineArgs;\n initializeScope(topScope, 0)\n END ModuleBody;\n\n PROCEDURE Close*;\n VAR path: ARRAY OJS.maxPath OF CHAR;\n BEGIN\n genClassFilePath(topCtx.className, path);\n ClassFormat.toFile(topCtx.c, path)\n END Close;\n\n PROCEDURE deleteModule*;\n VAR path: ARRAY OJS.maxPath OF CHAR;\n r: INTEGER;\n BEGIN\n genClassFilePath(topCtx.className, path);\n r := Files.Delete(path)\n END deleteModule;\n\n PROCEDURE MakeRecordType*(obj: OJB.Object);\n VAR desc, name, baseName: ClassFormat.Descriptor;\n path: ARRAY OJS.maxPath OF CHAR;\n newCtx: ClassContext;\n access: INTEGER;\n tmp: OJB.Object;\n recordType: OJB.Type;\n BEGIN\n NEW(newCtx);\n internalName(obj.type, name);\n access := Opcodes.ACCxPUBLIC;\n Strings.Append(\"java/lang/Object\", baseName);\n IF obj.type.base # NIL THEN\n internalName(obj.type.base, baseName);\n INC(access, Opcodes.ACCxSUPER)\n END ;\n Strings.Copy(topCtx.className, newCtx.className);\n newCtx.next := topCtx;\n topCtx := newCtx;\n newCtx.c := ClassFormat.NewCF(access, name, baseName);\n tmp := obj.type.dsc;\n recordType := obj.type;\n WHILE (tmp # NIL) & (tmp.class = OJB.Fld) & (recordType = tmp.recordType) DO\n Descriptor(tmp.type, desc);\n ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC, tmp.name, desc);\n tmp := tmp.next\n END ;\n Constructor(obj);\n CopyMethod(obj);\n genClassFilePath(name, path);\n ClassFormat.toFile(topCtx.c, path);\n topCtx := topCtx.next\n END MakeRecordType;\n\nBEGIN\n relmap[0] := Opcodes.IFICMPEQ; relmap[1] := Opcodes.IFICMPNE;\n relmap[2] := Opcodes.IFICMPLT; relmap[3] := Opcodes.IFICMPLE;\n relmap[4] := Opcodes.IFICMPGT; relmap[5] := Opcodes.IFICMPGE;\n relmap0[0] := Opcodes.IFEQ; relmap0[1] := Opcodes.IFNE;\n relmap0[2] := Opcodes.IFLT; relmap0[3] := Opcodes.IFLE;\n relmap0[4] := Opcodes.IFGT; relmap0[5] := Opcodes.IFGE;\n relmapNil[0] := Opcodes.IFNULL; relmapNil[1] := Opcodes.IFNONNULL;\n relmapAdr[0] := Opcodes.IFACMPEQ;relmapAdr[1] := Opcodes.IFACMPNE;\nEND OJG.\n" }, { "path": "src/OJP.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Copyright (C)2013 Niklaus Wirth (NW), Juerg Gutknecht (JG),\n Paul Reed (PR/PDR).\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*\n Parser of Oberon-JVM compiler. Uses Scanner OJS to obtain symbols (tokens),\n OJB for definition of data structures and for handling import and export, and\n OJG to produce bytecode. OJP performs type checking and data allocation.\n Parser is target-independent, except for part of the handling of allocations.\n*)\n\nMODULE OJP; (*Oberon compiler for JVM in Oberon-07*)\n IMPORT OJS, OJB, OJG, Strings;\n\n TYPE PtrBase = POINTER TO PtrBaseDesc;\n PtrBaseDesc = RECORD (*list of names of pointer base types*)\n name: OJS.Ident; type: OJB.Type; next: PtrBase\n END ;\n\n VAR sym: INTEGER; (*last symbol read*)\n level: INTEGER;\n nestedIdCounter: INTEGER; (*unique id for each nested procedure/type*)\n newSF, isDefinition: BOOLEAN;\n expression: PROCEDURE (VAR x: OJG.Item); (*to avoid forward reference*)\n Type: PROCEDURE (typedef: BOOLEAN): OJB.Type;\n FormalType: PROCEDURE (): OJB.Type;\n EqualSignatures: PROCEDURE (t0, t1: OJB.Type): BOOLEAN;\n modid: OJS.Ident;\n pbsList: PtrBase; (*list of names of pointer base types*)\n dummy: OJB.Object;\n hasMain: BOOLEAN;\n\n PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);\n BEGIN\n IF sym = s THEN OJS.Get(sym) ELSE OJS.Mark(msg) END\n END Check;\n\n PROCEDURE qualident(VAR modName: ARRAY OF CHAR): OJB.Object;\n VAR obj, modObj: OJB.Object;\n BEGIN\n obj := OJB.thisObj(OJS.id); OJS.Get(sym);\n IF obj = NIL THEN OJS.Mark(\"undef\"); obj := dummy END ;\n IF (sym = OJS.period) & (obj.class = OJB.Mod) THEN\n modObj := OJB.GetModFrom(obj);\n Strings.Copy(modObj.name, modName);\n OJS.Get(sym);\n IF sym = OJS.ident THEN obj := OJB.thisimport(obj, OJS.id); OJS.Get(sym);\n IF obj = NIL THEN OJS.Mark(\"undef\"); obj := dummy END\n ELSE OJS.Mark(\"identifier expected\"); obj := dummy\n END\n ELSE Strings.Copy(modid, modName)\n END\n RETURN obj\n END qualident;\n\n PROCEDURE CheckBool(VAR x: OJG.Item);\n BEGIN\n IF x.type.form # OJB.Bool THEN\n OJS.Mark(\"not Boolean\"); x.type := OJB.boolType\n END\n END CheckBool;\n\n PROCEDURE CheckInt(VAR x: OJG.Item);\n BEGIN\n IF x.type.form # OJB.Int THEN\n OJS.Mark(\"not Integer\"); x.type := OJB.intType\n END\n END CheckInt;\n\n PROCEDURE CheckByteRange(VAR x: OJG.Item);\n BEGIN\n IF (x.mode = OJB.Const) & ((x.a < 0) OR (x.a > 255)) THEN\n OJS.Mark(\"not a valid BYTE value\")\n END\n END CheckByteRange;\n\n PROCEDURE CheckReal(VAR x: OJG.Item);\n BEGIN\n IF x.type.form # OJB.Real THEN\n OJS.Mark(\"not Real\"); x.type := OJB.realType\n END\n END CheckReal;\n\n PROCEDURE CheckSet(VAR x: OJG.Item);\n BEGIN\n IF x.type.form # OJB.Set THEN OJS.Mark(\"not Set\"); x.type := OJB.setType END\n END CheckSet;\n\n PROCEDURE CheckSetVal(VAR x: OJG.Item);\n BEGIN\n IF x.type.form # OJB.Int THEN OJS.Mark(\"not Int\"); x.type := OJB.setType\n ELSIF x.mode = OJB.Const THEN\n IF (x.a < 0) OR (x.a >= OJG.MaxSetElement) THEN\n OJS.Mark(\"invalid set\")\n END\n END\n END CheckSetVal;\n\n PROCEDURE CheckConst(VAR x: OJG.Item);\n BEGIN\n IF x.mode # OJB.Const THEN\n OJS.Mark(\"not a constant\"); x.mode := OJB.Const\n END\n END CheckConst;\n\n PROCEDURE CheckReadOnly(VAR x: OJG.Item);\n BEGIN\n IF x.rdo THEN OJS.Mark(\"read-only\") END\n END CheckReadOnly;\n\n PROCEDURE CheckExport(): BOOLEAN;\n VAR expo: BOOLEAN;\n BEGIN\n IF sym = OJS.times THEN\n expo := TRUE; OJS.Get(sym);\n IF level # 0 THEN OJS.Mark(\"remove asterisk\") END\n ELSE expo := isDefinition\n END\n RETURN expo\n END CheckExport;\n\n PROCEDURE OrigFormalParamType(param: OJB.Object): OJB.Type;\n VAR partype: OJB.Type;\n BEGIN\n IF param.caseOrgType # NIL THEN partype := param.caseOrgType\n ELSE partype := param.type\n END\n RETURN partype\n END OrigFormalParamType;\n\n PROCEDURE FindObjFrom(modid: ARRAY OF CHAR; VAR x: OJG.Item): OJB.Object;\n VAR obj: OJB.Object;\n BEGIN\n IF (x.mode = OJB.Var) OR (x.mode = OJB.Par) OR (x.mode = OJB.ParStruct) THEN\n obj := OJB.FindObj(modid, x.modName, x.name)\n ELSE\n obj := NIL\n END\n RETURN obj\n END FindObjFrom;\n\n PROCEDURE IsExtension(t0, t1: OJB.Type): BOOLEAN;\n BEGIN (*t1 is an extension of t0*)\n RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base)\n END IsExtension;\n\n (* expressions *)\n\n PROCEDURE TypeTest(VAR x: OJG.Item; T: OJB.Type; guard: BOOLEAN);\n VAR xt: OJB.Type;\n BEGIN xt := x.type;\n IF (T.form = xt.form) &\n ((T.form = OJB.Pointer) OR\n (T.form = OJB.Record) & (x.mode = OJB.ParStruct)) THEN\n WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ;\n IF xt # T THEN xt := x.type;\n IF xt.form = OJB.Pointer THEN\n IF IsExtension(xt.base, T.base) THEN\n OJG.TypeTest(x, T.base, guard); x.type := T\n ELSE\n OJS.Mark(\"not an extension\")\n END\n ELSIF (xt.form = OJB.Record) & (x.mode = OJB.ParStruct) THEN\n IF IsExtension(xt, T) THEN OJG.TypeTest(x, T, guard); x.type := T\n ELSE OJS.Mark(\"not an extension\")\n END\n ELSE OJS.Mark(\"incompatible types\")\n END\n ELSIF ~guard THEN OJG.ConstTypeTest(x)\n END\n ELSE OJS.Mark(\"type mismatch\")\n END ;\n IF ~guard THEN x.type := OJB.boolType END\n END TypeTest;\n\n PROCEDURE selector(VAR x: OJG.Item);\n VAR y: OJG.Item; obj: OJB.Object;\n modName: OJS.Ident;\n BEGIN\n WHILE (sym = OJS.lbrak) OR (sym = OJS.period) OR (sym = OJS.arrow)\n OR (sym = OJS.lparen) & (x.type.form IN {OJB.Record, OJB.Pointer}) DO\n IF sym = OJS.lbrak THEN\n REPEAT\n OJG.Index0(x);\n OJS.Get(sym); expression(y);\n IF x.type.form = OJB.Array THEN\n CheckInt(y); OJG.Index(x, y); x.type := x.type.base\n ELSE OJS.Mark(\"not an array\")\n END\n UNTIL sym # OJS.comma;\n Check(OJS.rbrak, \"no ]\")\n ELSIF sym = OJS.period THEN OJS.Get(sym);\n IF sym = OJS.ident THEN\n IF x.type.form = OJB.Pointer THEN x.type := x.type.base END ;\n IF x.type.form = OJB.Record THEN\n obj := OJB.thisfield(x.type); OJS.Get(sym);\n IF obj # NIL THEN OJG.FieldAccess(x, obj); x.type := obj.type\n ELSE OJS.Mark(\"undef\")\n END\n ELSE OJS.Mark(\"not a record\")\n END\n ELSE OJS.Mark(\"ident?\")\n END\n ELSIF sym = OJS.arrow THEN\n OJS.Get(sym);\n IF x.type.form = OJB.Pointer THEN x.type := x.type.base\n ELSE OJS.Mark(\"not a pointer\")\n END\n ELSE (*type guard*)\n OJS.Get(sym);\n IF sym = OJS.ident THEN\n obj := qualident(modName);\n IF obj.class = OJB.Typ THEN\n TypeTest(x, obj.type, TRUE)\n ELSE\n OJS.Mark(\"guard type expected\")\n END\n ELSE OJS.Mark(\"not an identifier\")\n END ;\n Check(OJS.rparen, \" ) missing\")\n END\n END\n END selector;\n\n (* Type Rule A, B *)\n PROCEDURE EqualTypes(t0, t1: OJB.Type): BOOLEAN;\n BEGIN\n RETURN (t0 = t1)\n OR (t0.form = OJB.Array) & (t1.form = OJB.Array) &\n (t0.len = t1.len) & EqualTypes(t0.base, t1.base)\n OR (t0.form = OJB.Proc) & (t1.form = OJB.Proc) &\n EqualSignatures(t0, t1)\n OR (t0.form = OJB.Pointer) & (t1.form = OJB.Pointer) &\n EqualTypes(t0.base, t1.base)\n END EqualTypes;\n\n\n (* Type Rule F.1, F.2 *)\n PROCEDURE CompatibleOpenArrays(t0, t1: OJB.Type): BOOLEAN;\n BEGIN\n RETURN EqualTypes(t0, t1)\n OR (t0.form = OJB.Array) & (t1.form = OJB.Array) & (t1.len < 0) &\n CompatibleOpenArrays(t0.base, t1.base)\n END CompatibleOpenArrays;\n\n PROCEDURE EqualSignatures0(t0, t1: OJB.Type): BOOLEAN;\n VAR p0, p1: OJB.Object; com: BOOLEAN;\n BEGIN com := TRUE;\n (* Type Rule C.1, C.2 *)\n IF (t0.nofpar = t1.nofpar) & EqualTypes(t0.base, t1.base) THEN\n p0 := t0.dsc; p1 := t1.dsc;\n WHILE p0 # NIL DO\n (* Type Rule C.3, C.4 *)\n IF (p0.class = p1.class) & (p0.rdo = p1.rdo) &\n EqualTypes(OrigFormalParamType(p0), OrigFormalParamType(p1))\n THEN p0 := p0.next; p1 := p1.next\n ELSE p0 := NIL; com := FALSE\n END\n END\n ELSE com := FALSE\n END ;\n RETURN com\n END EqualSignatures0;\n\n PROCEDURE CompTypes(t0, t1: OJB.Type; varpar: BOOLEAN): BOOLEAN;\n BEGIN (*check for assignment compatibility*)\n (* Type Rule E.1, E.2, E.3, E.4 *)\n RETURN ~((t0.form = OJB.Array) & (t1.form = OJB.Array) & (t0.len < 0) &\n (t1.len < 0)) & EqualTypes(t0, t1)\n OR (t0.form = OJB.Record) & (t1.form = OJB.Record) & IsExtension(t0, t1)\n OR ~varpar &\n ((t0.form = OJB.Pointer) & (t1.form = OJB.Pointer) &\n IsExtension(t0.base, t1.base)\n OR (t0.form IN {OJB.Pointer, OJB.Proc}) & (t1.form = OJB.NilTyp))\n END CompTypes;\n\n PROCEDURE Parameter(par: OJB.Object);\n VAR x: OJG.Item; varpar: BOOLEAN; partype: OJB.Type;\n BEGIN\n expression(x);\n IF par # NIL THEN\n partype := OrigFormalParamType(par);\n varpar := (par.class = OJB.Par) OR (par.class = OJB.ParStruct);\n IF CompTypes(partype, x.type, varpar) OR (* Type Rule G.1, G.2, G.3 *)\n CompatibleOpenArrays(x.type, partype) THEN (* Type Rule F.1, F.2 *)\n IF varpar & x.rdo THEN OJS.Mark(\"read only actual parameter\")\n ELSIF ~varpar OR (par.class = OJB.ParStruct) THEN\n IF x.mode = OJB.Typ THEN OJS.Mark(\"illegal value parameter\") END ;\n OJG.ValueParam(x)\n ELSE (*par.class = Par*)\n IF ~par.rdo THEN CheckReadOnly(x) END ;\n OJG.VarParam(x)\n END\n (* Type Rule F.3 *)\n ELSIF (x.type.form = OJB.String) & par.rdo & (partype.form = OJB.Array) &\n (partype.base.form = OJB.Char) & (partype.len < 0) THEN\n OJG.StringParam(x)\n (* Type Rule F.3, J *)\n ELSIF (x.type.form = OJB.Char) & x.rdo & par.rdo &\n (partype.form = OJB.Array) & (partype.base.form = OJB.Char) &\n (partype.len < 0) THEN\n OJG.CharToStr(x);\n OJG.StringParam(x)\n (*\n ~varpar below to prevent this:\n PROCEDURE P(VAR n: INTEGER); ... n := ... uses a STR instruction\n P(b) STR overwrites bytes around byte variable b\n *)\n (* Type Rule I, G.2 *) (*BYTE*)\n ELSIF ~varpar & (partype.form = OJB.Int) & (x.type.form = OJB.Int) THEN\n IF partype = OJB.byteType THEN CheckByteRange(x) END;\n OJG.ValueParam(x)\n (* Type Rule J, G.2 *)\n ELSIF (x.type.form = OJB.String) & (x.b = 2) & (par.class = OJB.Var) &\n (partype.form = OJB.Char) THEN\n OJG.StrToChar(x);\n OJG.ValueParam(x)\n ELSE OJS.Mark(\"incompatible parameters\")\n END\n END\n END Parameter;\n\n PROCEDURE ParamList(VAR x: OJG.Item);\n VAR n: INTEGER; par: OJB.Object;\n BEGIN par := x.type.dsc; n := 0;\n IF sym # OJS.rparen THEN\n Parameter(par); n := 1;\n WHILE sym <= OJS.comma DO\n Check(OJS.comma, \"comma?\");\n IF par # NIL THEN par := par.next END ;\n INC(n); Parameter(par)\n END ;\n Check(OJS.rparen, \") missing\")\n ELSE OJS.Get(sym);\n END ;\n IF n < x.type.nofpar THEN OJS.Mark(\"too few params\")\n ELSIF n > x.type.nofpar THEN OJS.Mark(\"too many params\")\n END\n END ParamList;\n\n PROCEDURE StandFunc(VAR x: OJG.Item; fct: INTEGER; restyp: OJB.Type);\n VAR y: OJG.Item; n, npar: INTEGER;\n BEGIN\n Check(OJS.lparen, \"no (\");\n npar := fct MOD 10; fct := fct DIV 10;\n n := 0;\n IF npar # 0 THEN expression(x); n := 1 END ;\n WHILE sym = OJS.comma DO\n OJS.Get(sym);\n IF (x.mode # OJB.Typ) & (* x.mode = ORB.Typ for SYSTEM.VAL(x, y) *)\n (x.mode # OJB.Const) (* allow constant folding in OJG.Shift/Band/Bor *)\n THEN\n OJG.ValueParam(x)\n END ;\n expression(y);\n INC(n)\n END ;\n Check(OJS.rparen, \"no )\");\n IF n = npar THEN\n IF fct = 0 THEN (*ABS*)\n IF x.type.form IN {OJB.Int, OJB.Real} THEN\n OJG.Abs(x); restyp := x.type\n ELSE\n OJS.Mark(\"bad type\")\n END\n ELSIF fct = 1 THEN (*ODD*) CheckInt(x); OJG.Odd(x)\n ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); OJG.Floor(x)\n ELSIF fct = 3 THEN (*FLT*) CheckInt(x); OJG.Float(x)\n ELSIF fct = 4 THEN (*ORD*)\n IF x.type.form IN {OJB.Char, OJB.Bool, OJB.Set} THEN OJG.Ord(x)\n ELSIF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x)\n ELSE OJS.Mark(\"bad type\")\n END\n ELSIF fct = 5 THEN (*CHR*) CheckInt(x); OJG.Ord(x)\n ELSIF fct = 6 THEN (*LEN*)\n IF x.type.form = OJB.Array THEN\n OJG.Len(x)\n ELSE\n OJS.Mark(\"not an array\")\n END\n ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*)\n IF x.type.form IN {OJB.Int, OJB.Set} THEN\n CheckInt(x); CheckInt(y);\n OJG.Shift(fct-7, x, y); restyp := x.type\n ELSE\n OJS.Mark(\"bad type\")\n END\n ELSIF fct = 11 THEN (*AND*) CheckInt(x); CheckInt(y); OJG.Band(x, y)\n ELSIF fct = 12 THEN (*BOR*) CheckInt(x); CheckInt(y); OJG.Bor(x, y)\n ELSIF fct = 15 THEN (*NOT*) CheckInt(x); OJG.Bnot(x)\n ELSIF fct = 16 THEN (*VAL*)\n IF x.mode = OJB.Typ THEN\n IF ((x.type = OJB.byteType) OR (x.type = OJB.intType)) &\n ((y.type = OJB.byteType) OR (y.type = OJB.intType)) THEN\n (*\n BYTE and INTEGER are compatible, this is a no-op.\n The resulting type must match the one of the expression to be\n converted, as the actual conversion happens elsewhere.\n *)\n restyp := y.type;\n ELSIF ((x.type = OJB.intType) OR (x.type.form = OJB.Set)) &\n ((y.type = OJB.intType) OR (y.type.form = OJB.Set)) THEN\n (* A SET is represented as an INTEGER, this is a no-op. *)\n restyp := x.type\n ELSIF (x.type.form = OJB.Real) & (y.type.form = OJB.Int) THEN\n OJG.IntToReal(y);\n restyp := x.type\n ELSIF (x.type.form = OJB.Int) & (y.type.form = OJB.Real) THEN\n OJG.RealToInt(y);\n restyp := x.type\n ELSIF (x.type.form = OJB.Pointer) & (y.type.form = OJB.Pointer)\n THEN\n TypeTest(y, x.type, TRUE);\n restyp := x.type\n ELSE OJS.Mark(\"casting not allowed\")\n END ;\n x := y\n ELSE OJS.Mark(\"casting not allowed\")\n END\n ELSIF fct = 21 THEN (*eot*) OJG.eot(x)\n ELSIF fct = 22 THEN (*ReadInt*) OJG.ReadInt(x)\n ELSIF fct = 23 THEN (*ARGNUM*) OJG.Argnum(x)\n END ;\n x.type := restyp\n ELSE OJS.Mark(\"wrong nof params\")\n END\n END StandFunc;\n\n PROCEDURE element(VAR x: OJG.Item);\n VAR y: OJG.Item;\n BEGIN\n expression(x); CheckSetVal(x);\n IF sym = OJS.upto THEN\n OJS.Get(sym);\n OJG.Set0(x);\n expression(y);\n CheckSetVal(y);\n OJG.Set1(x, y)\n ELSE OJG.Singleton(x)\n END ;\n x.type := OJB.setType\n END element;\n\n PROCEDURE set(VAR x: OJG.Item);\n VAR y: OJG.Item;\n BEGIN\n IF sym >= OJS.if THEN\n IF sym # OJS.rbrace THEN OJS.Mark(\" } missing\") END ;\n OJG.MakeConstItem(x, OJB.setType, 0) (*empty set*)\n ELSE element(x);\n WHILE sym < OJS.rparen DO\n IF sym = OJS.comma THEN OJS.Get(sym)\n ELSE OJS.Mark(\"missing comma\")\n END ;\n element(y); OJG.SetOp(OJS.plus, x, y)\n END\n END\n END set;\n\n PROCEDURE factor(VAR x: OJG.Item);\n VAR obj: OJB.Object;\n modName: OJS.Ident;\n BEGIN (*sync*)\n IF (sym < OJS.char) OR (sym > OJS.ident) THEN\n OJS.Mark(\"expression expected\");\n REPEAT OJS.Get(sym)\n UNTIL (sym >= OJS.char) & (sym <= OJS.for) OR (sym >= OJS.then)\n END ;\n IF sym = OJS.ident THEN\n obj := qualident(modName);\n IF obj.class = OJB.SFunc THEN StandFunc(x, obj.val, obj.type)\n ELSE\n Strings.Copy(modName, x.modName);\n OJG.MakeItem(x, obj); selector(x);\n IF sym = OJS.lparen THEN\n OJS.Get(sym);\n IF (x.type.form = OJB.Proc) & (x.type.base.form # OJB.NoTyp) THEN\n OJG.PrepCall(x); ParamList(x); OJG.Call(x);\n OJG.storeVarPar;\n x.type := x.type.base\n ELSE OJS.Mark(\"not a function\"); ParamList(x)\n END\n END\n END\n ELSIF sym = OJS.int THEN\n OJG.MakeConstItem(x, OJB.intType, OJS.ival); OJS.Get(sym)\n ELSIF sym = OJS.real THEN\n OJG.MakeRealItem(x, OJS.rval); OJS.Get(sym)\n ELSIF sym = OJS.char THEN\n OJG.MakeConstItem(x, OJB.charType, OJS.ival); OJS.Get(sym)\n ELSIF sym = OJS.nil THEN\n OJS.Get(sym); OJG.MakeConstItem(x, OJB.nilType, 0)\n ELSIF sym = OJS.string THEN\n OJG.MakeStringItem(x); OJS.Get(sym)\n ELSIF sym = OJS.lparen THEN\n OJS.Get(sym); expression(x); Check(OJS.rparen, \"no )\")\n ELSIF sym = OJS.lbrace THEN\n OJS.Get(sym); set(x); Check(OJS.rbrace, \"no }\")\n ELSIF sym = OJS.not THEN\n OJS.Get(sym); factor(x); CheckBool(x); OJG.Not(x)\n ELSIF sym = OJS.false THEN\n OJS.Get(sym); OJG.MakeConstItem(x, OJB.boolType, 0)\n ELSIF sym = OJS.true THEN\n OJS.Get(sym); OJG.MakeConstItem(x, OJB.boolType, 1)\n ELSE\n OJS.Mark(\"not a factor\"); OJG.MakeConstItem(x, OJB.intType, 0)\n END\n END factor;\n\n PROCEDURE term(VAR x: OJG.Item);\n VAR y: OJG.Item; op, f: INTEGER;\n BEGIN\n factor(x); f := x.type.form;\n WHILE (sym >= OJS.times) & (sym <= OJS.and) DO\n op := sym; OJS.Get(sym);\n IF op = OJS.times THEN\n OJG.loadOp(x);\n IF f = OJB.Int THEN factor(y); CheckInt(y); OJG.MulOp(x, y)\n ELSIF f = OJB.Real THEN factor(y); CheckReal(y); OJG.RealOp(op, x, y)\n ELSIF f = OJB.Set THEN factor(y); CheckSet(y); OJG.SetOp(op, x, y)\n ELSE OJS.Mark(\"bad type\")\n END\n ELSIF (op = OJS.div) OR (op = OJS.mod) THEN\n OJG.loadOp(x);\n CheckInt(x); factor(y); CheckInt(y);\n OJG.DivOp(op, x, y)\n ELSIF op = OJS.rdiv THEN\n OJG.loadOp(x);\n IF f = OJB.Real THEN factor(y); CheckReal(y); OJG.RealOp(op, x, y)\n ELSIF f = OJB.Set THEN factor(y); CheckSet(y); OJG.SetOp(op, x, y)\n ELSE OJS.Mark(\"bad type\")\n END\n ELSE (*op = and*)\n CheckBool(x); OJG.And1(x); factor(y); CheckBool(y); OJG.And2(x, y)\n END\n END\n END term;\n\n PROCEDURE SimpleExpression(VAR x: OJG.Item);\n VAR y: OJG.Item; op: INTEGER;\n BEGIN\n IF sym = OJS.minus THEN OJS.Get(sym); term(x);\n IF x.type.form IN {OJB.Int, OJB.Real, OJB.Set} THEN\n OJG.Neg(x)\n ELSE\n CheckInt(x)\n END\n ELSIF sym = OJS.plus THEN OJS.Get(sym); term(x);\n ELSE term(x)\n END ;\n WHILE (sym >= OJS.plus) & (sym <= OJS.or) DO\n op := sym; OJS.Get(sym);\n IF op = OJS.or THEN\n OJG.Or1(x); CheckBool(x); term(y); CheckBool(y); OJG.Or2(x, y)\n ELSIF x.type.form = OJB.Int THEN\n OJG.loadOp(x); term(y); CheckInt(y); OJG.AddOp(op, x, y)\n ELSIF x.type.form = OJB.Real THEN\n OJG.loadOp(x); term(y); CheckReal(y); OJG.RealOp(op, x, y)\n ELSE\n CheckSet(x); OJG.loadOp(x); term(y); CheckSet(y); OJG.SetOp(op, x, y)\n END\n END\n END SimpleExpression;\n\n PROCEDURE expression0(VAR x: OJG.Item);\n VAR y: OJG.Item; obj: OJB.Object; rel, xf, yf: INTEGER;\n modName: OJS.Ident;\n BEGIN\n SimpleExpression(x);\n IF (sym >= OJS.eql) & (sym <= OJS.geq) THEN\n rel := sym; OJS.Get(sym);\n OJG.loadOp(x);\n SimpleExpression(y); xf := x.type.form; yf := y.type.form;\n IF x.type = y.type THEN\n IF (xf IN {OJB.Char, OJB.Int}) THEN OJG.IntRelation(rel, x, y)\n ELSIF xf = OJB.Real THEN OJG.RealRelation(rel, x, y)\n ELSIF xf IN {OJB.Set, OJB.Pointer, OJB.Proc, OJB.NilTyp, OJB.Bool} THEN\n IF rel <= OJS.neq THEN\n OJG.IntRelation(rel, x, y)\n ELSE\n OJS.Mark(\"only = or #\")\n END\n ELSIF (xf = OJB.Array) &\n (x.type.base.form = OJB.Char) OR (xf = OJB.String) THEN\n OJG.StringRelation(rel, x, y)\n ELSE OJS.Mark(\"illegal comparison\")\n END\n ELSIF (xf IN {OJB.Pointer, OJB.Proc}) & (yf = OJB.NilTyp)\n OR (yf IN {OJB.Pointer, OJB.Proc}) & (xf = OJB.NilTyp) THEN\n IF rel <= OJS.neq THEN\n OJG.IntRelation(rel, x, y)\n ELSE\n OJS.Mark(\"only = or #\")\n END\n ELSIF (xf = OJB.Pointer) & (yf = OJB.Pointer) &\n (IsExtension(x.type.base, y.type.base) OR\n IsExtension(y.type.base, x.type.base)) OR\n (xf = OJB.Proc) & (yf = OJB.Proc) &\n EqualSignatures(x.type, y.type) THEN\n IF rel <= OJS.neq THEN\n OJG.IntRelation(rel, x, y)\n ELSE\n OJS.Mark(\"only = or #\")\n END\n ELSIF (xf = OJB.Array) & (x.type.base.form = OJB.Char) &\n ((yf = OJB.String) OR (yf = OJB.Array) &\n (y.type.base.form = OJB.Char)) OR\n (yf = OJB.Array) & (y.type.base.form = OJB.Char) &\n (xf = OJB.String) THEN\n OJG.StringRelation(rel, x, y)\n ELSIF (xf = OJB.Char) & (yf = OJB.String) & (y.b = 2) THEN\n OJG.StrToChar(y); OJG.IntRelation(rel, x, y)\n ELSIF (yf = OJB.Char) & (xf = OJB.String) & (x.b = 2) THEN\n OJG.StrToChar(x); OJG.IntRelation(rel, x, y)\n (*BYTE*)\n ELSIF (xf = OJB.Int) & (yf = OJB.Int) THEN OJG.IntRelation(rel, x, y)\n ELSE OJS.Mark(\"illegal comparison\")\n END ;\n x.type := OJB.boolType\n ELSIF sym = OJS.in THEN\n OJG.In0(x);\n OJS.Get(sym);\n CheckInt(x); SimpleExpression(y);\n CheckSet(y); OJG.In1(y);\n x.type := OJB.boolType\n ELSIF sym = OJS.is THEN\n OJS.Get(sym);\n obj := qualident(modName);\n Strings.Copy(modName, x.modName);\n TypeTest(x, obj.type, FALSE);\n x.type := OJB.boolType\n END\n END expression0;\n\n (* statements *)\n\n PROCEDURE StandProc(pno: INTEGER);\n VAR npar: INTEGER; (*nof formal parameters*)\n x, y, z: OJG.Item;\n BEGIN\n npar := pno MOD 10; pno := pno DIV 10;\n IF (npar = 0) & (pno = 17) THEN\n OJG.WriteLn\n ELSIF (npar = 2) & (pno = 24) THEN (*ARGS*)\n OJG.Args0();\n Check(OJS.lparen, \"no (\");\n expression(x); CheckInt(x); OJG.Args1(x);\n Check(OJS.comma, \"no ,\");\n expression(y);\n Check(OJS.rparen, \"no )\");\n IF (y.type.form # OJB.Array) OR (y.type.base # OJB.charType) THEN\n OJS.Mark(\"not ARRAY OF CHAR\")\n END ;\n OJG.Args2(y)\n ELSIF (npar = 2) & ((pno = 2) OR (pno = 3)) THEN (*INCL, EXCL*)\n Check(OJS.lparen, \"no (\");\n expression(x); CheckSet(x); CheckReadOnly(x);\n OJG.Include0(x, z);\n Check(OJS.comma, \"no ,\");\n expression(y);\n Check(OJS.rparen, \"no )\");\n CheckInt(y); OJG.Include1(pno-2, y, z)\n ELSIF (pno = 0) OR (pno = 1) THEN (*INC, DEC*)\n Check(OJS.lparen, \"no (\");\n expression(x); CheckInt(x); CheckReadOnly(x);\n OJG.Increment0(x, z);\n IF sym = OJS.comma THEN\n OJS.Get(sym); expression(y); CheckInt(y)\n ELSE\n y.type := OJB.noType\n END ;\n Check(OJS.rparen, \"no )\");\n OJG.Increment1(pno, x, y, z)\n ELSE\n Check(OJS.lparen, \"no (\");\n expression(x);\n Check(OJS.rparen, \"no )\");\n IF pno = 4 THEN CheckBool(x); OJG.Assert(x)\n ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x);\n IF (x.type.form = OJB.Pointer) & (x.type.base.form = OJB.Record) THEN\n OJG.New(x)\n ELSE\n OJS.Mark(\"not a pointer to record\")\n END\n ELSIF pno = 15 THEN\n IF (x.type.form = OJB.String) & (x.b = 2) THEN\n OJG.StrToChar(x)\n ELSIF x.type.form # OJB.Char THEN\n OJS.Mark(\"not Char\"); x.type := OJB.charType\n END ;\n OJG.WriteChar(x)\n ELSIF pno = 16 THEN CheckInt(x); OJG.WriteInt(x)\n ELSIF pno = 18 THEN CheckReal(x); OJG.WriteReal(x)\n END\n END\n END StandProc;\n\n PROCEDURE StatSequence;\n VAR obj: OJB.Object;\n orgtype: OJB.Type; (*original type of case var*)\n x, y, z, w: OJG.Item;\n L0, L1: INTEGER;\n modName: OJS.Ident;\n\n PROCEDURE TypeCase(obj: OJB.Object; VAR x: OJG.Item);\n VAR typobj: OJB.Object;\n modName: OJS.Ident;\n BEGIN\n IF sym = OJS.ident THEN\n typobj := qualident(modName);\n Strings.Copy(modName, x.modName);\n OJG.MakeItem(x, obj);\n x.oldType := NIL;\n IF typobj.class # OJB.Typ THEN OJS.Mark(\"not a type\") END ;\n TypeTest(x, typobj.type, FALSE); obj.caseOrgType := obj.type;\n obj.type := typobj.type;\n OJG.CFJump(x); Check(OJS.colon, \": expected\"); StatSequence\n ELSE OJS.Mark(\"type id expected\"); OJG.CFJump(x)\n END\n END TypeCase;\n\n PROCEDURE LabelRange(labelForm: INTEGER; VAR x, y: OJG.Item; VAR n: INTEGER;\n VAR tab: ARRAY OF OJG.LabelRange; stmts: INTEGER);\n VAR i: INTEGER; done: BOOLEAN;\n BEGIN\n expression(x);\n CheckConst(x);\n IF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x) END ;\n IF x.type.form # labelForm THEN\n OJS.Mark(\"wrong type of case label\")\n END ;\n IF sym = OJS.upto THEN\n OJS.Get(sym);\n expression(y);\n CheckConst(y);\n IF (y.type.form = OJB.String) & (y.b = 2) THEN OJG.StrToChar(y) END ;\n IF y.type.form # x.type.form THEN\n OJS.Mark(\"wrong type of case label\")\n END ;\n IF y.a < x.a THEN OJS.Mark(\"illegal value of constant\"); y.a := x.a END;\n ELSE y := x\n END ;\n (*enter label range into ordered table*)\n i := n;\n done := FALSE;\n IF i < OJG.NofCases THEN\n WHILE (i # 0) & ~done DO\n IF tab[i-1].low <= y.a THEN\n IF tab[i-1].high >= x.a THEN\n OJS.Mark(\"case label defined more than once\")\n END ;\n done := TRUE\n ELSE\n tab[i] := tab[i-1];\n DEC(i)\n END\n END ;\n tab[i].low := x.a; tab[i].high := y.a;\n tab[i].L := stmts;\n INC(n)\n ELSE OJS.Mark(\"too many cases or no case in case statement\")\n END\n END LabelRange;\n\n PROCEDURE Case(labelForm: INTEGER; VAR n: INTEGER;\n VAR tab: ARRAY OF OJG.LabelRange);\n VAR x, y: OJG.Item;\n stmts: INTEGER;\n BEGIN\n IF sym IN {OJS.int, OJS.char, OJS.minus, OJS.plus, OJS.string, OJS.ident}\n THEN\n stmts := OJG.getPC();\n LabelRange(labelForm, x, y, n, tab, stmts);\n WHILE sym = OJS.comma DO\n OJS.Get(sym);\n LabelRange(labelForm, x, y, n, tab, stmts)\n END ;\n IF sym IN {OJS.int, OJS.char, OJS.minus, OJS.plus, OJS.string,OJS.ident}\n THEN\n OJS.Mark(\"',' missing\")\n END ;\n Check(OJS.colon, \": expected\");\n StatSequence;\n ELSE OJS.Mark(\"integer or character expected\")\n END\n END Case;\n\n PROCEDURE CasePart(VAR caseExpr: OJG.Item);\n VAR n, L0, dflt, end: INTEGER;\n tab: ARRAY OJG.NofCases OF OJG.LabelRange;\n BEGIN\n L0 := 0;\n end := 0;\n n := 0;\n L0 := OJG.CaseIn(caseExpr, L0);\n Case(caseExpr.type.form, n, tab);\n end := OJG.FJump(end);\n WHILE sym = OJS.bar DO\n OJS.Get(sym); Case(caseExpr.type.form, n, tab);\n end := OJG.FJump(end)\n END ;\n dflt := OJG.CaseDefault();\n OJG.CaseOut(caseExpr, end, L0, n, dflt, tab)\n END CasePart;\n\n PROCEDURE SkipCase;\n BEGIN\n WHILE sym # OJS.colon DO OJS.Get(sym) END ;\n OJS.Get(sym); StatSequence\n END SkipCase;\n\n BEGIN\n (* StatSequence *)\n REPEAT (*sync*) obj := NIL;\n IF ~((sym >= OJS.ident) & (sym <= OJS.for) OR (sym >= OJS.semicolon)) THEN\n OJS.Mark(\"statement expected\");\n REPEAT OJS.Get(sym) UNTIL sym >= OJS.ident\n END ;\n OJG.SetLineNumber(OJS.GetLine());\n IF sym = OJS.ident THEN\n obj := qualident(modName);\n Strings.Copy(modName, x.modName);\n OJG.MakeItem(x, obj);\n IF x.mode = OJB.SProc THEN StandProc(obj.val)\n ELSE selector(x);\n IF sym = OJS.becomes THEN (*assignment*)\n OJS.Get(sym); CheckReadOnly(x);\n OJG.PrepAssign(x);\n expression(y);\n IF y.mode = OJB.Typ THEN\n OJS.Mark(\"illegal assignment\")\n (* Type Rule E.1, E.2, E.3, E.4 *)\n ELSIF CompTypes(x.type, y.type, FALSE) THEN\n IF x.type.form <= OJB.Pointer THEN OJG.Store(x, y, FALSE)\n ELSIF x.type.form = OJB.Proc THEN OJG.StoreProc(x, y)\n ELSIF y.type.form = OJB.Record THEN\n OJG.Store(x, y, TRUE)\n ELSIF y.type.form = OJB.Array THEN\n OJG.storeArray(x, y)\n END\n (* Type Rule E.6 *)\n ELSIF (x.type.form = OJB.Array) & (y.type.form = OJB.Array) &\n (x.type.len > 0) & (y.type.len < 0) &\n EqualTypes(x.type.base, y.type.base) THEN\n OJG.storeArray(x, y)\n (* Type Rule E.5 *)\n ELSIF (x.type.form = OJB.Array) & (x.type.base.form = OJB.Char) &\n (y.type.form = OJB.String) THEN\n OJG.CopyString(x, y)\n (* Type Rule E.5, J *)\n ELSIF (x.type.form = OJB.Array) & (x.type.base.form = OJB.Char) &\n y.rdo & (y.type.form = OJB.Char) THEN\n OJG.CharToStr(y);\n OJG.CopyString(x, y);\n (* Type Rule I *) (*BYTE*)\n ELSIF (x.type.form = OJB.Int) & (y.type.form = OJB.Int) THEN\n IF x.type = OJB.byteType THEN CheckByteRange(y) END;\n OJG.Store(x, y, FALSE)\n (* Type Rule J *)\n ELSIF (x.type.form = OJB.Char) & (y.type.form = OJB.String) &\n (y.b = 2) THEN\n OJG.StrToChar(y); OJG.Store(x, y, FALSE)\n ELSE OJS.Mark(\"illegal assignment\")\n END\n ELSIF sym = OJS.eql THEN\n OJS.Mark(\"should be :=\"); OJS.Get(sym); expression(y)\n ELSIF sym = OJS.lparen THEN (*procedure call*)\n OJS.Get(sym);\n IF (x.type.form = OJB.Proc) & (x.type.base.form = OJB.NoTyp) THEN\n OJG.PrepCall(x); ParamList(x); OJG.Call(x);\n OJG.storeVarPar\n ELSE OJS.Mark(\"not a procedure\"); ParamList(x)\n END\n (*procedure call without parameters*)\n ELSIF x.type.form = OJB.Proc THEN\n IF x.type.nofpar > 0 THEN OJS.Mark(\"missing parameters\") END ;\n IF x.type.base.form = OJB.NoTyp THEN\n OJG.PrepCall(x);\n OJG.Call(x)\n ELSE\n OJS.Mark(\"not a procedure\")\n END\n ELSIF x.mode = OJB.Typ THEN OJS.Mark(\"illegal assignment\")\n ELSE OJS.Mark(\"not a procedure\")\n END\n END\n ELSIF sym = OJS.if THEN\n OJS.Get(sym); expression(x); CheckBool(x); OJG.CFJump(x);\n Check(OJS.then, \"no THEN\");\n StatSequence; L0 := 0;\n WHILE sym = OJS.elsif DO\n OJS.Get(sym); L0 := OJG.FJump(L0); OJG.Fixup(x.a); expression(x);\n CheckBool(x); OJG.CFJump(x); Check(OJS.then, \"no THEN\"); StatSequence\n END ;\n IF sym = OJS.else THEN\n OJS.Get(sym); L0 := OJG.FJump(L0); OJG.Fixup(x.a); StatSequence\n ELSE\n OJG.Fixup(x.a)\n END ;\n OJG.Fixup(L0); Check(OJS.end, \"no END\")\n ELSIF sym = OJS.while THEN\n OJS.Get(sym); L0 := OJG.getPC(); expression(x); CheckBool(x);\n OJG.CFJump(x); Check(OJS.do, \"no DO\"); StatSequence; OJG.BJump(L0);\n WHILE sym = OJS.elsif DO\n OJS.Get(sym); OJG.Fixup(x.a); expression(x); CheckBool(x);\n OJG.CFJump(x); Check(OJS.do, \"no DO\"); StatSequence; OJG.BJump(L0)\n END ;\n OJG.Fixup(x.a); Check(OJS.end, \"no END\")\n ELSIF sym = OJS.repeat THEN\n OJS.Get(sym); L0 := OJG.getPC(); StatSequence;\n IF sym = OJS.until THEN\n OJS.Get(sym); expression(x); CheckBool(x); OJG.CBJump(x, L0)\n ELSE OJS.Mark(\"missing UNTIL\")\n END\n ELSIF sym = OJS.for THEN\n OJS.Get(sym);\n IF sym = OJS.ident THEN\n obj := qualident(modName);\n Strings.Copy(modName, x.modName);\n OJG.MakeItem(x, obj); CheckInt(x); CheckReadOnly(x);\n IF sym = OJS.becomes THEN\n OJG.loadPar(x); OJS.Get(sym); expression(y); CheckInt(y);\n OJG.For0(x, y); L0 := OJG.getPC();\n Check(OJS.to, \"no TO\"); expression(z); CheckInt(z); obj.rdo := TRUE;\n IF sym = OJS.by THEN\n OJS.Get(sym); expression(w); CheckConst(w); CheckInt(w)\n ELSE\n OJG.MakeConstItem(w, OJB.intType, 1)\n END ;\n Check(OJS.do, \"no DO\"); L1 := OJG.For1(x, z, w);\n StatSequence; Check(OJS.end, \"no END\");\n OJG.For2(x, w); OJG.BJump(L0); OJG.Fixup(L1); obj.rdo := FALSE\n ELSE OJS.Mark(\":= expected\")\n END\n ELSE OJS.Mark(\"identifier expected\")\n END\n ELSIF sym = OJS.case THEN\n OJS.Get(sym);\n expression(x);\n Check(OJS.of, \"OF expected\");\n obj := FindObjFrom(modid, x);\n IF (obj # NIL) & ((obj.type.form = OJB.Pointer) OR\n (obj.type.form = OJB.Record) &\n (obj.class = OJB.ParStruct)) THEN\n orgtype := obj.type;\n TypeCase(obj, x); L0 := 0;\n WHILE sym = OJS.bar DO\n OJS.Get(sym); L0 := OJG.FJump(L0); OJG.Fixup(x.a);\n obj.type := orgtype; obj.caseOrgType := NIL;\n TypeCase(obj, x)\n END ;\n OJG.Fixup(x.a); OJG.Fixup(L0); obj.type := orgtype;\n obj.caseOrgType := NIL\n ELSIF (obj = NIL) & ((x.type.form = OJB.Pointer) OR\n (x.type.form = OJB.Record)) THEN\n OJS.Mark(\"identifier expected\")\n ELSIF (x.type.form = OJB.Int) OR (x.type.form = OJB.Char) THEN\n CasePart(x)\n ELSE OJS.Mark(\"inadmissible type\");\n SkipCase;\n WHILE sym = OJS.bar DO SkipCase END\n END ;\n Check(OJS.end, \"no END\")\n END ;\n IF sym = OJS.semicolon THEN OJS.Get(sym)\n ELSIF sym < OJS.semicolon THEN OJS.Mark(\"missing semicolon?\")\n END ;\n IF (OJG.curStack() # 0) & (OJS.errcnt = 0) THEN\n OJS.Mark(\"Reg Stack\")\n END\n UNTIL sym > OJS.semicolon\n END StatSequence;\n\n (* Types and declarations *)\n\n PROCEDURE IdentList(class: INTEGER): OJB.Object;\n VAR obj, first: OJB.Object;\n BEGIN\n IF sym = OJS.ident THEN\n first := OJB.InsertObj(OJS.id, class); OJS.Get(sym);\n first.expo := CheckExport();\n WHILE sym = OJS.comma DO\n OJS.Get(sym);\n IF sym = OJS.ident THEN\n obj := OJB.InsertObj(OJS.id, class); OJS.Get(sym);\n obj.expo := CheckExport()\n ELSE OJS.Mark(\"ident?\")\n END\n END;\n IF sym = OJS.colon THEN OJS.Get(sym) ELSE OJS.Mark(\":?\") END\n ELSE first := NIL\n END\n RETURN first\n END IdentList;\n\n PROCEDURE ArrayType(): OJB.Type;\n VAR x: OJG.Item;\n typ, type: OJB.Type; len: INTEGER;\n BEGIN\n NEW(typ); typ.form := OJB.NoTyp;\n expression(x);\n IF (x.mode = OJB.Const) & (x.type.form = OJB.Int) & (x.a >= 0) THEN\n len := x.a\n ELSE\n len := 1; OJS.Mark(\"not a valid length\")\n END ;\n IF sym = OJS.of THEN OJS.Get(sym); typ.base := Type(FALSE);\n ELSIF sym = OJS.comma THEN OJS.Get(sym); typ.base := ArrayType()\n ELSE OJS.Mark(\"missing OF\"); typ.base := OJB.intType\n END ;\n typ.form := OJB.Array; typ.len := len; type := typ\n RETURN type\n END ArrayType;\n\n PROCEDURE RecordType(): OJB.Type;\n VAR obj, obj0, new, bot, base: OJB.Object;\n type, typ, tp: OJB.Type;\n modName: OJS.Ident;\n BEGIN NEW(typ); typ.form := OJB.NoTyp; typ.base := NIL;\n typ.nofpar := 0; bot := NIL;\n IF sym = OJS.lparen THEN\n OJS.Get(sym); (*record extension*)\n IF sym = OJS.ident THEN\n base := qualident(modName);\n IF base.class = OJB.Typ THEN\n IF base.type.form = OJB.Record THEN typ.base := base.type\n ELSE typ.base := OJB.intType; OJS.Mark(\"invalid extension\")\n END ;\n bot := typ.base.dsc\n ELSE OJS.Mark(\"type expected\")\n END\n ELSE OJS.Mark(\"ident expected\")\n END ;\n Check(OJS.rparen, \"no )\")\n END ;\n WHILE sym = OJS.ident DO (*fields*)\n obj := bot;\n WHILE sym = OJS.ident DO\n obj0 := obj;\n WHILE (obj0 # NIL) & (obj0.name # OJS.id) DO obj0 := obj0.next END ;\n IF obj0 # NIL THEN OJS.Mark(\"mult def\") END ;\n NEW(new); Strings.Copy(OJS.id, new.name); new.nestedId := 0;\n new.class := OJB.Fld; new.recordType := typ;\n new.next := obj; obj := new;\n OJS.Get(sym); new.expo := CheckExport();\n IF (sym # OJS.comma) & (sym # OJS.colon) THEN OJS.Mark(\"comma expected\")\n ELSIF sym = OJS.comma THEN OJS.Get(sym)\n END\n END ;\n Check(OJS.colon, \"colon expected\"); tp := Type(FALSE);\n IF (tp.form = OJB.Array) & (tp.len < 0) THEN\n OJS.Mark(\"dyn array not allowed\")\n END ;\n obj0 := obj;\n WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; obj0 := obj0.next END;\n bot := obj;\n IF sym = OJS.semicolon THEN OJS.Get(sym) ELSIF sym # OJS.end THEN\n OJS.Mark(\" ; or END\")\n END\n END ;\n typ.form := OJB.Record; typ.dsc := bot; type := typ\n RETURN type\n END RecordType;\n\n PROCEDURE FPSection(VAR adr: INTEGER; VAR nofpar: INTEGER);\n VAR obj, first: OJB.Object; tp: OJB.Type;\n cl: INTEGER; rdo: BOOLEAN;\n BEGIN\n IF sym = OJS.var THEN OJS.Get(sym); cl := OJB.Par ELSE cl := OJB.Var END ;\n first := IdentList(cl); tp := FormalType(); rdo := FALSE;\n IF (cl = OJB.Var) & (tp.form >= OJB.Array) THEN\n (* cl = ORB.Par; not needed as arrays/records are references in JVM*)\n rdo := TRUE\n ELSIF (cl = OJB.Par) & (tp.form >= OJB.Array) THEN\n (* arrays/records are references in JVM, OJB.ParStruct is equivalent\n to OJB.Var but for structured types *)\n cl := OJB.ParStruct\n END ;\n obj := first;\n WHILE obj # NIL DO\n INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo;\n obj.lev := level; obj.val := adr;\n adr := adr + 1; obj := obj.next\n END ;\n IF adr > OJG.ParamsMax THEN OJS.Mark(\"too many parameters\") END\n END FPSection;\n\n PROCEDURE ProcedureType(ptype: OJB.Type; parblksize: INTEGER): INTEGER;\n VAR obj: OJB.Object; size: INTEGER; nofpar: INTEGER;\n modName: OJS.Ident;\n BEGIN ptype.base := OJB.noType; size := parblksize; nofpar := 0;\n ptype.dsc := NIL;\n IF sym = OJS.lparen THEN\n OJS.Get(sym);\n IF sym = OJS.rparen THEN OJS.Get(sym)\n ELSE FPSection(size, nofpar);\n WHILE sym = OJS.semicolon DO OJS.Get(sym); FPSection(size, nofpar) END ;\n Check(OJS.rparen, \"no )\")\n END ;\n IF sym = OJS.colon THEN (*function*)\n OJS.Get(sym);\n IF sym = OJS.ident THEN\n obj := qualident(modName); ptype.base := obj.type;\n (* Type Rule H *)\n IF ~((obj.class = OJB.Typ) &\n (obj.type.form IN {OJB.Byte .. OJB.Pointer, OJB.Proc})) THEN\n OJS.Mark(\"illegal function type\")\n END\n ELSE OJS.Mark(\"type identifier expected\")\n END\n END\n END ;\n ptype.nofpar := nofpar; parblksize := size\n RETURN parblksize\n END ProcedureType;\n\n PROCEDURE FormalType0(): OJB.Type;\n VAR obj: OJB.Object; dmy: INTEGER;\n typ: OJB.Type;\n modName: OJS.Ident;\n BEGIN\n IF sym = OJS.ident THEN\n obj := qualident(modName);\n IF obj.class = OJB.Typ THEN\n typ := obj.type\n ELSE\n OJS.Mark(\"not a type\"); typ := OJB.intType\n END\n ELSIF sym = OJS.array THEN\n OJS.Get(sym); Check(OJS.of, \"OF ?\");\n NEW(typ); typ.form := OJB.Array; typ.len := -1;\n typ.base := FormalType()\n ELSIF sym = OJS.procedure THEN\n OJS.Get(sym); OJB.OpenScope;\n NEW(typ); typ.form := OJB.Proc; dmy := ProcedureType(typ, 0);\n typ.dsc := OJB.topScope.next; OJB.CloseScope;\n OJG.genSignature(typ);\n OJG.MakeProcType(typ)\n ELSE OJS.Mark(\"identifier expected\"); typ := OJB.noType\n END\n RETURN typ\n END FormalType0;\n\n PROCEDURE Type0(typedef: BOOLEAN): OJB.Type;\n VAR dmy: INTEGER; obj, tmp: OJB.Object; ptbase: PtrBase;\n type: OJB.Type; modName: OJS.Ident;\n BEGIN type := OJB.intType; (*sync*)\n IF (sym # OJS.ident) & (sym < OJS.array) THEN OJS.Mark(\"not a type\");\n REPEAT OJS.Get(sym) UNTIL (sym = OJS.ident) OR (sym >= OJS.array)\n END ;\n IF sym = OJS.ident THEN\n obj := qualident(modName);\n IF obj.class = OJB.Typ THEN\n IF (obj.type # NIL) & (obj.type.form # OJB.NoTyp) THEN\n type := obj.type\n END\n ELSE OJS.Mark(\"not a type or undefined\")\n END\n ELSIF sym = OJS.array THEN OJS.Get(sym); type := ArrayType()\n ELSIF sym = OJS.record THEN\n OJS.Get(sym); type := RecordType(); Check(OJS.end, \"no END\");\n IF ~typedef & ~isDefinition THEN\n OJG.MakeRecordType(OJB.generateAnonymousTypeObj(type))\n END\n ELSIF sym = OJS.pointer THEN\n OJS.Get(sym); Check(OJS.to, \"no TO\");\n NEW(type); type.form := OJB.Pointer; type.base := OJB.intType;\n IF sym = OJS.ident THEN\n obj := OJB.thisObj(OJS.id);\n IF obj # NIL THEN\n OJS.Get(sym);\n IF (obj.class = OJB.Typ) &\n (obj.type.form IN {OJB.Record, OJB.NoTyp}) THEN\n type.base := obj.type\n ELSIF (sym = OJS.period) & (obj.class = OJB.Mod) THEN\n OJS.Get(sym);\n IF sym = OJS.ident THEN obj := OJB.thisimport(obj, OJS.id);\n OJS.Get(sym);\n IF obj = NIL THEN OJS.Mark(\"undef\")\n ELSE type.base := obj.type\n END\n ELSE OJS.Mark(\"identifier expected\")\n END\n ELSE\n OJS.Mark(\"no valid base type\")\n END\n ELSE\n (*enter into list of forward references to be fixed in Declarations*)\n NEW(ptbase); Strings.Copy(OJS.id, ptbase.name); ptbase.type := type;\n ptbase.next := pbsList; pbsList := ptbase;\n OJS.Get(sym);\n (* Temporarily save base type name (needed by OJG.internalName despite\n forward references are not fixed yet) *)\n NEW(type.base); type.base.form := OJB.Int; NEW(tmp);\n Strings.Copy(ptbase.name, tmp.name);\n IF level > 0 THEN\n tmp.nestedId := nestedIdCounter; INC(nestedIdCounter)\n END ;\n type.base.typobj := tmp\n END\n ELSE type.base := Type(FALSE);\n IF type.base.form # OJB.Record THEN\n OJS.Mark(\"must point to record\");\n type := OJB.intType\n END\n END\n ELSIF sym = OJS.procedure THEN\n OJS.Get(sym); OJB.OpenScope;\n NEW(type); type.form := OJB.Proc;\n dmy := ProcedureType(type, 0); type.dsc := OJB.topScope.next;\n OJB.CloseScope;\n OJG.genSignature(type);\n OJG.MakeProcType(type)\n ELSE OJS.Mark(\"illegal type\")\n END\n RETURN type\n END Type0;\n\n PROCEDURE Declarations(varsize: INTEGER): INTEGER;\n VAR obj, first: OJB.Object;\n x: OJG.Item; tp: OJB.Type; ptbase: PtrBase;\n expo, alias: BOOLEAN; id: OJS.Ident;\n BEGIN\n (*sync*) pbsList := NIL;\n IF (sym < OJS.const) & (sym # OJS.end) & (sym # OJS.return) THEN\n OJS.Mark(\"declaration?\");\n REPEAT OJS.Get(sym)\n UNTIL (sym >= OJS.const) OR (sym = OJS.end) OR (sym = OJS.return)\n END ;\n IF sym = OJS.const THEN\n OJS.Get(sym);\n WHILE sym = OJS.ident DO\n Strings.Copy(OJS.id, id); OJS.Get(sym); expo := CheckExport();\n IF sym = OJS.eql THEN OJS.Get(sym) ELSE OJS.Mark(\"= ?\") END;\n expression(x);\n IF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x) END ;\n obj := OJB.InsertObj(id, OJB.Const); obj.expo := expo; obj.rdo := TRUE;\n IF x.mode = OJB.Const THEN\n obj.val := x.a; obj.len := x.b; obj.type := x.type\n ELSE\n OJS.Mark(\"expression not constant\"); obj.type := OJB.intType\n END;\n Check(OJS.semicolon, \"; missing\")\n END\n END ;\n IF sym = OJS.type THEN\n OJS.Get(sym);\n WHILE sym = OJS.ident DO\n alias := FALSE;\n Strings.Copy(OJS.id, id); OJS.Get(sym); expo := CheckExport();\n IF sym = OJS.eql THEN OJS.Get(sym) ELSE OJS.Mark(\"=?\") END ;\n tp := Type(TRUE);\n obj := OJB.InsertObj(id, OJB.Typ); obj.type := tp; obj.expo := expo;\n obj.lev := level;\n IF level > 0 THEN\n obj.nestedId := nestedIdCounter; INC(nestedIdCounter)\n END ;\n IF tp.typobj = NIL THEN\n (*aliases must not modify the typobj*)\n tp.typobj := obj\n ELSE\n alias := TRUE\n END ;\n IF tp.form = OJB.Record THEN\n (*\n Check whether this object record (obj) is the base of a pointer type\n that was created (via Type()) before obj was inserted in the symbol\n table (via InsertObj(id, OJB.Typ))\n When this happens the base of the pointer type must to be fixed.\n Examples:\n 1. P is defined before R is defined:\n P = POINTER TO R;\n R = RECORD END;\n 2. The type of x is defined before R is fully defined.\n R = RECORD x: POINTER TO R END;\n *)\n ptbase := pbsList;\n WHILE ptbase # NIL DO\n IF obj.name = ptbase.name THEN\n (*\n Keep the nestedId computed when the tmp base object type was\n created\n *)\n obj.type.typobj.nestedId := ptbase.type.base.typobj.nestedId;\n ptbase.type.base := obj.type\n END ;\n ptbase := ptbase.next\n END ;\n END ;\n Check(OJS.semicolon, \"; missing\");\n IF (obj.type.form = OJB.Record) & ~alias & ~isDefinition THEN\n OJG.MakeRecordType(obj)\n END\n END\n END ;\n IF sym = OJS.var THEN\n OJS.Get(sym);\n WHILE sym = OJS.ident DO\n first := IdentList(OJB.Var); tp := Type(FALSE);\n obj := first;\n WHILE obj # NIL DO\n obj.type := tp; obj.lev := level;\n obj.val := varsize; INC(varsize);\n obj := obj.next\n END ;\n Check(OJS.semicolon, \"; missing\")\n END\n END ;\n ptbase := pbsList;\n WHILE ptbase # NIL DO\n IF ptbase.type.base.form = OJB.Int THEN\n OJS.MarkAppend(\"undefined pointer base: \", ptbase.name)\n END ;\n ptbase := ptbase.next\n END ;\n IF (sym >= OJS.const) & (sym <= OJS.var) THEN\n OJS.Mark(\"declaration in bad order\")\n END\n RETURN varsize\n END Declarations;\n\n PROCEDURE ProcedureDecl;\n VAR proc: OJB.Object;\n type: OJB.Type;\n procid: OJS.Ident;\n x: OJG.Item;\n locblksize, parblksize: INTEGER;\n BEGIN\n (* ProcedureDecl *) OJS.Get(sym);\n IF sym = OJS.ident THEN\n Strings.Copy(OJS.id, procid); OJS.Get(sym);\n proc := OJB.InsertObj(OJS.id, OJB.Const); proc.lev := level; parblksize := 0;\n NEW(type); type.form := OJB.Proc; proc.type := type;\n IF level > 0 THEN\n proc.nestedId := nestedIdCounter; INC(nestedIdCounter)\n END ;\n proc.expo := CheckExport();\n OJB.OpenScope; INC(level); proc.val := 0; type.base := OJB.noType;\n parblksize := ProcedureType(type, parblksize); (*formal parameter list*)\n IF procid = \"Main\" THEN\n IF type.nofpar # 0 THEN\n OJS.Mark(\"Main cannot have formal parameters\")\n ELSIF type.base # OJB.noType THEN\n OJS.Mark(\"Main cannot have a return type\")\n ELSE\n hasMain := TRUE\n END\n END ;\n IF ~isDefinition THEN\n Check(OJS.semicolon, \"no ;\"); locblksize := parblksize;\n locblksize := Declarations(locblksize);\n proc.type.dsc := OJB.topScope.next;\n OJG.genSignature(proc.type);\n IF sym = OJS.procedure THEN\n REPEAT ProcedureDecl; Check(OJS.semicolon, \"no ;\")\n UNTIL sym # OJS.procedure;\n proc.type.dsc := OJB.topScope.next\n END ;\n OJG.Enter(proc, locblksize);\n IF sym = OJS.begin THEN OJS.Get(sym); StatSequence END ;\n IF sym = OJS.return THEN\n OJS.Get(sym); expression(x);\n IF type.base = OJB.noType THEN OJS.Mark(\"this is not a function\")\n (* Type Rule I *)\n ELSIF (type.base.form = OJB.Int) & (x.type.form = OJB.Int) THEN\n IF type.base = OJB.byteType THEN CheckByteRange(x) END\n (* Type Rule J *)\n ELSIF (type.base.form = OJB.Char) & (x.type.form = OJB.String) &\n (x.b = 2) THEN\n OJG.StrToChar(x);\n (* Type Rule H *)\n ELSIF ~CompTypes(type.base, x.type, FALSE) THEN\n OJS.Mark(\"wrong result type\")\n END\n ELSIF type.base.form # OJB.NoTyp THEN\n OJS.Mark(\"function without result\"); type.base := OJB.noType\n END ;\n OJG.Return(type.base, x);\n OJB.CheckUnused(parblksize);\n OJB.CloseScope; DEC(level); Check(OJS.end, \"no END\");\n IF sym = OJS.ident THEN\n IF OJS.id # procid THEN OJS.Mark(\"no match\") END ;\n OJS.Get(sym)\n ELSE OJS.Mark(\"no proc id\")\n END\n ELSE\n proc.type.dsc := OJB.topScope.next;\n OJG.genSignature(proc.type);\n OJB.CloseScope; DEC(level)\n END\n ELSE OJS.Mark(\"proc id expected\")\n END\n END ProcedureDecl;\n\n PROCEDURE Import;\n VAR aliasName, impName: OJS.Ident;\n BEGIN\n IF sym = OJS.ident THEN\n Strings.Copy(OJS.id, aliasName); OJS.Get(sym);\n IF sym = OJS.becomes THEN\n OJS.Get(sym);\n IF isDefinition THEN OJS.Mark(\"module alias not allowed\") END ;\n IF sym = OJS.ident THEN Strings.Copy(OJS.id, impName); OJS.Get(sym)\n ELSE OJS.Mark(\"id expected\"); impName := \"\"\n END\n ELSE Strings.Copy(aliasName, impName)\n END ;\n OJB.Import(aliasName, impName, modid)\n ELSE OJS.Mark(\"id expected\")\n END\n END Import;\n\n PROCEDURE Module(outputFolder: ARRAY OF CHAR);\n VAR dc: INTEGER;\n dmy: OJG.Item;\n BEGIN\n isDefinition := FALSE;\n hasMain := FALSE;\n nestedIdCounter := 1;\n OJS.Get(sym);\n IF (sym = OJS.module) OR (sym = OJS.definition) THEN\n IF sym = OJS.definition THEN isDefinition := TRUE END ;\n OJS.Get(sym);\n IF sym = OJS.ident THEN\n Strings.Copy(OJS.id, modid); OJS.Get(sym);\n ELSE OJS.Mark(\"identifier expected\")\n END ;\n Check(OJS.semicolon, \"no ;\"); level := 0; dc := 0;\n OJB.Init(outputFolder, modid); OJB.OpenScope;\n IF sym = OJS.import THEN\n OJS.Get(sym); Import;\n WHILE sym = OJS.comma DO OJS.Get(sym); Import END ;\n Check(OJS.semicolon, \"; missing\")\n END ;\n OJG.Open(modid); dc := Declarations(dc);\n WHILE sym = OJS.procedure DO\n ProcedureDecl; Check(OJS.semicolon, \"no ;\")\n END ;\n IF ~isDefinition THEN\n OJG.Header(OJB.topScope);\n OJG.MainProc(hasMain);\n OJG.ModuleBody(OJB.topScope);\n IF sym = OJS.begin THEN OJS.Get(sym); StatSequence END ;\n OJG.Return(NIL, dmy);\n END ;\n Check(OJS.end, \"no END\");\n IF sym = OJS.ident THEN\n IF OJS.id # modid THEN OJS.Mark(\"no match\") END ;\n OJS.Get(sym)\n ELSE OJS.Mark(\"identifier missing\")\n END ;\n IF sym # OJS.period THEN OJS.Mark(\"period missing\") END ;\n IF ~isDefinition THEN OJB.CheckUnused(0) END ;\n IF OJS.errcnt = 0 THEN\n OJB.Export(modid, newSF);\n END ;\n IF OJS.errcnt = 0 THEN\n IF ~isDefinition THEN OJG.Close END ;\n ELSE OJS.Mark(\"compilation FAILED\"); OJG.deleteModule\n END ;\n OJB.CloseScope; pbsList := NIL\n ELSE OJS.Mark(\"must start with MODULE or DEFINITION\")\n END\n END Module;\n\n PROCEDURE Compile*(fname: ARRAY OF CHAR; newSym: BOOLEAN;\n VAR outputFolder: ARRAY OF CHAR);\n BEGIN\n newSF := newSym;\n OJS.Init(fname);\n IF OJS.errcnt = 0 THEN\n Module(outputFolder)\n END\n END Compile;\n\nBEGIN\n NEW(dummy); dummy.class := OJB.Var; dummy.type := OJB.intType;\n expression := expression0; Type := Type0; FormalType := FormalType0;\n EqualSignatures := EqualSignatures0\nEND OJP.\n" }, { "path": "src/OJS.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Copyright (C)2013 Niklaus Wirth (NW), Juerg Gutknecht (JG),\n Paul Reed (PR/PDR).\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*\n Oberon Scanner does lexical analysis. Input is UTF8 text, output is\n sequence of symbols, i.e identifiers, numbers, strings, and special symbols.\n Recognises all Oberon keywords and skips comments. The keywords are\n recorded in a table.\n Get(sym) delivers next symbol from input text.\n Mark()/MarkAppend() record error and delivers error message on\n standard output.\n If Get delivers ident, then the identifier (a string) is in variable id,\n if int or char in ival, if real in rval, and if string in str (and slen)\n*)\nMODULE OJS;\n IMPORT SYSTEM, Strings, Files, Out;\n\n CONST IdLen* = 32;\n NKW = 34; (*nof keywords*)\n maxKWX = 11; maxKWD = 11;\n maxExp = 38; minExp = -45;\n stringBufSize* = 256; maxStrx = stringBufSize*500;\n maxSrcSize = 200000;\n maxErrMsgSize = 200;\n maxPath* = 200;\n\n (*lexical symbols*)\n null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;\n and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;\n neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;\n in* = 15; is* = 16; arrow* = 17; period* = 18;\n char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;\n nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;\n lbrace* = 30; ident* = 31;\n if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;\n comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;\n rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;\n to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54;\n else* = 55; elsif* = 56; until* = 57; return* = 58;\n array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;\n var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69;\n definition* = 70; eot = 71;\n\n TYPE Ident* = ARRAY IdLen OF CHAR;\n\n VAR ival*, strpos*: INTEGER; (*results of Get*)\n slen*: INTEGER; (*include terminal 0X*)\n rval*: REAL;\n id*: Ident; (*for identifiers*)\n strBuf: ARRAY maxStrx OF CHAR;\n strx: INTEGER;\n errcnt*: INTEGER;\n\n ch: CHAR; (*last character read*)\n errpos: INTEGER;\n pos: INTEGER;\n EOF: BOOLEAN;\n k: INTEGER;\n KWX: ARRAY maxKWX OF INTEGER;\n keyTab: ARRAY NKW OF\n RECORD sym: INTEGER; id: ARRAY maxKWD OF CHAR END;\n src: ARRAY maxSrcSize OF BYTE;\n srcSize: INTEGER;\n line, prevLine, col, prevCol: INTEGER;\n inputPath: ARRAY maxPath OF CHAR;\n\n PROCEDURE MarkAppend*(msg, extra: ARRAY OF CHAR);\n VAR out: ARRAY maxErrMsgSize OF CHAR;\n BEGIN\n IF (pos > errpos) & (errcnt < 25) THEN\n Strings.Append(inputPath, out);\n Strings.AppendChar(\":\", out);\n Strings.AppendInt(prevLine, 0, out);\n Strings.AppendChar(\":\", out);\n Strings.AppendInt(prevCol, 0, out);\n Strings.Append(\": \", out);\n Strings.Append(msg, out);\n Out.String(out);\n Out.String(extra);\n Out.Ln;\n INC(errcnt); errpos := pos + 4\n END\n END MarkAppend;\n\n PROCEDURE Mark*(msg: ARRAY OF CHAR);\n BEGIN\n MarkAppend(msg, \"\")\n END Mark;\n\n PROCEDURE ExtractChar*(a: INTEGER): CHAR;\n VAR c: CHAR;\n BEGIN\n IF a < maxStrx THEN c := strBuf[a] ELSE c := 0X END\n RETURN c\n END ExtractChar;\n\n PROCEDURE InsertChar*(c: CHAR): INTEGER;\n VAR idx: INTEGER;\n BEGIN\n idx := strx;\n IF (strx + 1) < maxStrx THEN\n strBuf[strx] := c;\n strBuf[strx + 1] := 0X;\n INC(strx, 2)\n ELSE Mark(\"too many strings\")\n END\n RETURN idx\n END InsertChar;\n\n PROCEDURE ExtractStr*(i, len: INTEGER; VAR out: ARRAY OF CHAR);\n VAR j: INTEGER;\n BEGIN\n j := 0;\n WHILE (j < len) & (i < maxStrx) & (j < LEN(out)) DO\n out[j] := strBuf[i];\n INC(i);\n INC(j)\n END\n END ExtractStr;\n\n PROCEDURE InsertStr*(in: ARRAY OF CHAR; len: INTEGER): INTEGER;\n VAR i, idx: INTEGER;\n BEGIN\n i := 0;\n idx := strx;\n IF (strx + len - 1) < maxStrx THEN\n WHILE len > 0 DO strBuf[strx] := in[i]; INC(strx); INC(i); DEC(len) END\n ELSE Mark(\"too many strings\")\n END\n RETURN idx\n END InsertStr;\n\n PROCEDURE getUTF8(): BOOLEAN;\n VAR ok: BOOLEAN;\n x, b1, b2, b3: INTEGER;\n BEGIN\n ok := FALSE;\n ch := 0X;\n IF pos < srcSize THEN\n b1 := src[pos];\n x := ASR(b1, 4);\n CASE x OF\n 0..7: (* 1 bytes format: 0xxxxxxx *)\n ch := CHR(b1); ok := TRUE\n | 12, 13: (* 2 bytes format: 110xxxxx 10xxxxxx *)\n IF pos+1 < srcSize THEN\n INC(pos);\n b2 := src[pos];\n IF AND(b2, 0C0H) # 80H THEN\n Mark(\"Invalid UTF8 character\")\n ELSE\n ch := CHR(BOR(LSL(AND(b1, 1FH), 6), AND(b2, 3FH)));\n ok := TRUE\n END\n END\n | 14: (* 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx *)\n IF pos+2 < srcSize THEN\n INC(pos);\n b2 := src[pos];\n INC(pos);\n b3 := src[pos];\n IF (AND(b2, 0C0H) # 80H) OR (AND(b3, 0C0H) # 80H) THEN\n Mark(\"Invalid UTF8 character\")\n ELSE\n ch := CHR(BOR(LSL(AND(b1, 0FH), 12),\n BOR(LSL(AND(b2, 3FH), 6), AND(b3, 3FH))));\n ok := TRUE\n END\n END\n | 8..11, 15:\n (* ERROR + 4 bytes format: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx *)\n Mark(\"Invalid UTF8 character\")\n END\n END\n RETURN ok\n END getUTF8;\n\n PROCEDURE read();\n BEGIN\n IF getUTF8() THEN\n IF ch = 0AX THEN (* 0AX = \\n *)\n col := 0;\n INC(line)\n ELSE\n INC(col);\n END ;\n INC(pos)\n ELSE\n EOF := TRUE;\n ch := 0X\n END\n END read;\n\n PROCEDURE GetLine*(): INTEGER;\n RETURN line\n END GetLine;\n\n PROCEDURE Identifier(VAR sym: INTEGER);\n VAR i, k: INTEGER;\n BEGIN i := 0;\n REPEAT\n IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;\n read\n UNTIL (ch < \"0\") OR (ch > \"9\") & (ch < \"A\") OR (ch > \"Z\") & (ch < \"a\") OR\n (ch > \"z\");\n id[i] := 0X;\n IF i < maxKWX THEN k := KWX[i-1]; (*search for keyword*)\n WHILE (k < KWX[i]) & (id # keyTab[k].id) DO INC(k) END ;\n IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END\n ELSE sym := ident\n END\n END Identifier;\n\n PROCEDURE String;\n BEGIN read;\n strpos := strx;\n WHILE ~EOF & (ch # 22X) DO (* 22X = \" *)\n IF ch >= \" \" THEN\n IF strx < maxStrx-1 THEN\n strBuf[strx] := ch; INC(strx)\n ELSE\n Mark(\"string too long\")\n END\n END ;\n read\n END ;\n IF strx < maxStrx THEN strBuf[strx] := 0X; INC(strx) END;\n read; slen := strx-strpos\n END String;\n\n PROCEDURE HexString;\n VAR m, n: INTEGER;\n BEGIN read;\n strpos := strx;\n WHILE ~EOF & (ch # \"$\") DO\n WHILE ~EOF & (ch <= \" \") DO read END ; (*skip*)\n IF (\"0\" <= ch) & (ch <= \"9\") THEN m := ORD(ch) - ORD(\"0\")\n ELSIF (\"A\" <= ch) & (ch <= \"F\") THEN m := ORD(ch) - ORD(\"7\")\n ELSE m := 0; Mark(\"hexdig expected\")\n END ;\n read;\n IF (\"0\" <= ch) & (ch <= \"9\") THEN n := ORD(ch) - ORD(\"0\")\n ELSIF (\"A\" <= ch) & (ch <= \"F\") THEN n := ORD(ch) - ORD(\"7\")\n ELSE n := 0; Mark(\"hexdig expected\")\n END ;\n IF strx < maxStrx THEN\n strBuf[strx] := CHR(m*10H + n); INC(strx)\n ELSE\n Mark(\"string too long\")\n END ;\n read\n END ;\n read; slen := strx-strpos (*no 0X appended*)\n END HexString;\n\n PROCEDURE Ten(e: INTEGER): REAL;\n VAR x, t: REAL;\n BEGIN x := 1.0; t := 10.0;\n WHILE e > 0 DO\n IF ODD(e) THEN x := t * x END ;\n t := t * t; e := e DIV 2\n END ;\n RETURN x\n END Ten;\n\n PROCEDURE Number(VAR sym: INTEGER);\n CONST max = 2147483647 (*2^31 - 1*);\n maxChar = 0FFFFH ;\n VAR i, k, e, n, s, h: INTEGER; x: REAL;\n d: ARRAY 16 OF INTEGER;\n negE: BOOLEAN;\n BEGIN ival := 0; i := 0; n := 0; k := 0;\n REPEAT\n IF n < 16 THEN\n d[n] := ORD(ch)-ORD(\"0\"); INC(n)\n ELSE\n Mark(\"too many digits\"); n := 0\n END ;\n read\n UNTIL (ch < \"0\") OR (ch > \"9\") & (ch < \"A\") OR (ch > \"F\");\n IF (ch = \"H\") OR (ch = \"R\") OR (ch = \"X\") THEN (*hex*)\n REPEAT h := d[i];\n (* ex . ORD(\"A\")-ORD(\"0\") = 65-48 = 17 -> 17-7 = 10 *)\n IF h >= 10 THEN h := h-7 END ;\n k := k*10H + h; INC(i) (*no overflow check*)\n UNTIL i = n;\n IF ch = \"X\" THEN sym := char;\n IF k <= maxChar THEN ival := k ELSE Mark(\"illegal value\"); ival := 0 END\n ELSIF ch = \"R\" THEN sym := real; rval := SYSTEM.VAL(REAL, k)\n ELSE sym := int; ival := k\n END ;\n read\n ELSIF ch = \".\" THEN\n read;\n IF ch = \".\" THEN (*double dot*) ch := 7FX; (*decimal integer*)\n REPEAT\n IF d[i] < 10 THEN\n IF k <= (max-d[i]) DIV 10 THEN\n k := k *10 + d[i]\n ELSE Mark(\"too large\");\n k := 0\n END\n ELSE Mark(\"bad integer\")\n END ;\n INC(i)\n UNTIL i = n;\n sym := int; ival := k\n ELSE (*real number*) x := 0.0; e := 0;\n REPEAT (*integer part*) x := x * 10.0 + FLT(d[i]); INC(i) UNTIL i = n;\n WHILE (ch >= \"0\") & (ch <= \"9\") DO (*fraction*)\n x := x * 10.0 + FLT(ORD(ch) - ORD(\"0\")); DEC(e); read\n END ;\n IF (ch = \"E\") OR (ch = \"D\") THEN (*scale factor*)\n read; s := 0;\n IF ch = \"-\" THEN negE := TRUE; read\n ELSE negE := FALSE;\n IF ch = \"+\" THEN read END\n END ;\n IF (ch >= \"0\") & (ch <= \"9\") THEN\n REPEAT s := s*10 + ORD(ch)-ORD(\"0\"); read\n UNTIL (ch < \"0\") OR (ch >\"9\");\n IF negE THEN e := e-s ELSE e := e+s END\n ELSE Mark(\"digit?\")\n END\n END ;\n IF e < 0 THEN\n IF e >= minExp THEN x := x / Ten(-e) ELSE x := 0.0 END\n ELSIF e > 0 THEN\n IF e <= maxExp THEN\n x := Ten(e) * x\n ELSE\n x := 0.0; Mark(\"too large\")\n END\n END ;\n sym := real; rval := x\n END\n ELSE (*decimal integer*)\n REPEAT\n IF d[i] < 10 THEN\n IF k <= (max-d[i]) DIV 10 THEN\n k := k*10 + d[i]\n ELSE\n Mark(\"too large\"); k := 0\n END\n ELSE Mark(\"bad integer\")\n END ;\n INC(i)\n UNTIL i = n;\n sym := int; ival := k\n END\n END Number;\n\n PROCEDURE comment;\n VAR level: INTEGER;\n BEGIN\n level := 1; read;\n WHILE ~EOF & (level > 0) DO\n IF ch = \"(\" THEN read;\n IF ch = \"*\" THEN INC(level); read END\n ELSIF ch = \"*\" THEN read;\n IF ch = \")\" THEN DEC(level); read END\n ELSE read\n END\n END ;\n IF level # 0 THEN Mark(\"unterminated comment\") END\n END comment;\n\n PROCEDURE Get*(VAR sym: INTEGER);\n BEGIN\n prevLine := line;\n prevCol := col;\n REPEAT\n WHILE ~EOF & ((ch <= \" \") OR (ch > 7FX)) DO read END;\n IF EOF THEN sym := eot\n ELSE\n CASE ch OF (* \" \" < ch <= 7FX *)\n \"!\", \"%\", \"'\", \"?\", \"@\", \"\\\", \"_\", \"`\": read; sym := null\n | 22X : String; sym := string\n | \"#\" : read; sym := neq\n | \"$\" : HexString; sym := string\n | \"&\" : read; sym := and\n | \"(\" : read;\n IF ch = \"*\" THEN sym := null; comment\n ELSE sym := lparen END\n | \")\" : read; sym := rparen\n | \"*\" : read; sym := times\n | \"+\" : read; sym := plus\n | \",\" : read; sym := comma\n | \"-\" : read; sym := minus\n | \".\" : read;\n IF ch = \".\" THEN read; sym := upto\n ELSE sym := period END\n | \"/\" : read; sym := rdiv\n | \"0\"..\"9\": Number(sym)\n | \":\" : read;\n IF ch = \"=\" THEN read; sym := becomes\n ELSE sym := colon END\n | \";\" : read; sym := semicolon\n | \"<\" : read;\n IF ch = \"=\" THEN read; sym := leq\n ELSE sym := lss END\n | \"=\" : read; sym := eql\n | \">\" : read;\n IF ch = \"=\" THEN read; sym := geq\n ELSE sym := gtr END\n | \"A\"..\"Z\": Identifier(sym)\n | \"[\" : read; sym := lbrak\n | \"]\" : read; sym := rbrak\n | \"^\" : read; sym := arrow\n | \"a\"..\"z\": Identifier(sym)\n | \"{\" : read; sym := lbrace\n | \"|\" : read; sym := bar\n | \"}\" : read; sym := rbrace\n | \"~\" : read; sym := not\n | 7FX : read; sym := upto\n END\n END\n UNTIL sym # null\n END Get;\n\n PROCEDURE Init*(path: ARRAY OF CHAR);\n VAR f: Files.File;\n n, len: INTEGER;\n BEGIN\n pos := 0; line := 1; col := 0;\n EOF := FALSE; errpos := -1; errcnt := 0;\n Strings.Copy(path, inputPath);\n f := Files.Open(path);\n IF f = NIL THEN\n Mark(\"file not found\")\n ELSE\n len := Files.Size(f);\n IF (len = -1) OR (len >= maxSrcSize) THEN\n Mark(\"file too big\")\n ELSE\n Files.ReadBytes(f, src, n);\n srcSize := n;\n IF Files.Status(f) # Files.OK THEN\n Mark(\"error while reading the file\")\n END ;\n read\n END ;\n Files.Close(f)\n END\n END Init;\n\n PROCEDURE InitStr*(s: ARRAY OF BYTE);\n BEGIN\n pos := 0;\n line := 1;\n col := 0;\n EOF := FALSE;\n errpos := -1;\n errcnt := 0;\n src := s;\n srcSize := LEN(s);\n read\n END InitStr;\n\n PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);\n BEGIN keyTab[k].id := name; keyTab[k].sym := sym; INC(k)\n END EnterKW;\n\nBEGIN strx := 0; k := 0; KWX[0] := 0; KWX[1] := 0;\n EnterKW(if, \"IF\");\n EnterKW(do, \"DO\");\n EnterKW(of, \"OF\");\n EnterKW(or, \"OR\");\n EnterKW(to, \"TO\");\n EnterKW(in, \"IN\");\n EnterKW(is, \"IS\");\n EnterKW(by, \"BY\");\n KWX[2] := k;\n EnterKW(end, \"END\");\n EnterKW(nil, \"NIL\");\n EnterKW(var, \"VAR\");\n EnterKW(div, \"DIV\");\n EnterKW(mod, \"MOD\");\n EnterKW(for, \"FOR\");\n KWX[3] := k;\n EnterKW(else, \"ELSE\");\n EnterKW(then, \"THEN\");\n EnterKW(true, \"TRUE\");\n EnterKW(type, \"TYPE\");\n EnterKW(case, \"CASE\");\n KWX[4] := k;\n EnterKW(elsif, \"ELSIF\");\n EnterKW(false, \"FALSE\");\n EnterKW(array, \"ARRAY\");\n EnterKW(begin, \"BEGIN\");\n EnterKW(const, \"CONST\");\n EnterKW(until, \"UNTIL\");\n EnterKW(while, \"WHILE\");\n KWX[5] := k;\n EnterKW(record, \"RECORD\");\n EnterKW(repeat, \"REPEAT\");\n EnterKW(return, \"RETURN\");\n EnterKW(import, \"IMPORT\");\n EnterKW(module, \"MODULE\");\n KWX[6] := k;\n EnterKW(pointer, \"POINTER\");\n KWX[7] := k; KWX[8] := k;\n EnterKW(procedure, \"PROCEDURE\");\n KWX[9] := k;\n EnterKW(definition, \"DEFINITION\");\n KWX[10] := k\nEND OJS.\n" }, { "path": "src/Opcodes.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\nMODULE Opcodes;\n CONST\n (* access flags *)\n ACCxPUBLIC* = 0001H;\n ACCxPRIVATE* = 0002H;\n ACCxSTATIC* = 0008H;\n ACCxFINAL* = 0010H;\n ACCxSUPER* = 0020H;\n ACCxABSTRACT* = 0400H;\n\n (* types for NEWARRAY *)\n TBOOLEAN* = 4;\n TCHAR* = 5;\n TFLOAT* = 6;\n TBYTE* = 8;\n TINT* = 10;\n\n (* opcodes *)\n ACONSTNULL* = 1;\n ICONSTM1* = 2;\n ICONST0* = 3;\n ICONST1* = 4;\n ICONST2* = 5;\n ICONST3* = 6;\n ICONST4* = 7;\n ICONST5* = 8;\n FCONST0* = 11;\n FCONST1* = 12;\n FCONST2* = 13;\n BIPUSH* = 16;\n SIPUSH* = 17;\n LDC* = 18;\n LDCW* = 19;\n ILOAD* = 21;\n FLOAD* = 23;\n ALOAD* = 25;\n IALOAD* = 46;\n FALOAD* = 48;\n AALOAD* = 50;\n BALOAD* = 51;\n CALOAD* = 52;\n ISTORE* = 54;\n FSTORE* = 56;\n ASTORE* = 58;\n IASTORE* = 79;\n FASTORE* = 81;\n AASTORE* = 83;\n BASTORE* = 84;\n CASTORE* = 85;\n POP* = 87;\n POP2* = 88;\n DUP* = 89;\n DUP2* = 92;\n SWAP* = 95;\n IADD* = 96;\n FADD* = 98;\n ISUB* = 100;\n FSUB* = 102;\n IMUL* = 104;\n FMUL* = 106;\n FDIV* = 110;\n INEG* = 116;\n FNEG* = 118;\n ISHL* = 120;\n ISHR* = 122;\n IAND* = 126;\n IOR* = 128;\n IXOR* = 130;\n IINC* = 132;\n I2F* = 134;\n F2D* = 141;\n D2I* = 142;\n FCMPL* = 149;\n FCMPG* = 150;\n IFEQ* = 153;\n IFNE* = 154;\n IFLT* = 155;\n IFGE* = 156;\n IFGT* = 157;\n IFLE* = 158;\n IFICMPEQ* = 159;\n IFICMPNE* = 160;\n IFICMPLT* = 161;\n IFICMPGE* = 162;\n IFICMPGT* = 163;\n IFICMPLE* = 164;\n IFACMPEQ* = 165;\n IFACMPNE* = 166;\n GOTO* = 167;\n TABLESWITCH* = 170;\n IRETURN* = 172;\n FRETURN* = 174;\n ARETURN* = 176;\n RETURNx* = 177;\n GETSTATIC* = 178;\n PUTSTATIC* = 179;\n GETFIELD* = 180;\n PUTFIELD* = 181;\n INVOKEVIRTUAL* = 182;\n INVOKESPECIAL* = 183;\n INVOKESTATIC* = 184;\n INVOKEINTERFACE* = 185;\n NEW* = 187;\n NEWARRAY* = 188;\n ANEWARRAY* = 189;\n ARRAYLENGTH* = 190;\n ATHROW* = 191;\n CHECKCAST* = 192;\n INSTANCEOF* = 193;\n MULTIANEWARRAY* = 197;\n IFNULL* = 198;\n IFNONNULL* = 199;\n GOTOW* = 200;\nEND Opcodes.\n" }, { "path": "src/Os.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\nDEFINITION Os;\n PROCEDURE GetEnv(VAR out: ARRAY OF CHAR; name: ARRAY OF CHAR);\n\n (* Get time in seconds since 2010-01-01-UTC *)\n PROCEDURE CurrentTime(): INTEGER;\n\n (* Terminate the current program. The input \"status\" is the exit code\n returned to the OS. *)\n PROCEDURE Exit(status: INTEGER);\nEND Os.\n" }, { "path": "src/Out.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(* Simple procedures to print to standard output *)\nDEFINITION Out;\n PROCEDURE Char(ch: CHAR);\n PROCEDURE String(str: ARRAY OF CHAR);\n PROCEDURE Real(x: REAL; n: INTEGER);\n PROCEDURE Int(x, n: INTEGER);\n PROCEDURE Ln;\n PROCEDURE Hex(x: INTEGER);\nEND Out.\n" }, { "path": "src/Strings.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\n(*\n Strings provides a set of operations on strings (i.e., on string constants and\n character arrays, both of which contain the character 0X as a terminator).\n All positions in strings start at 0.\n Strings.Length(s)\n returns the number of characters in s up to and excluding the first 0X.\n Strings.Insert(src, pos, dst)\n inserts the string src into the string dst at position pos\n (0 <= pos <= Length(dst)).\n If pos >= Length(dst), src is appended to dst. If the size of dst is not\n large enough to hold the result of the operation, the result is truncated so\n that dst is always terminated with a 0X.\n Strings.Append(s, dst)\n has the same effect as Insert(s, Length(s), dst).\n Strings.AppendChar(c, dst)\n has the same effect as WriteChar(c, dst, Length(dst))\n Strings.AppendInt(x, n, dst)\n has the same effect as WriteInt(x, n, dst, Length(dst))\n Strings.Delete(s, pos, n)\n deletes n characters from s starting at position pos (0 <= pos < Length(s)).\n If n > Length(s) - pos, the new length of s is pos.\n Strings.Replace(src, pos, dst)\n has the same effect as Delete(dst, pos, Length(src)) followed by an\n Insert(src, pos, dst).\n Strings.Extract(src, pos, n, dst)\n extracts a substring dst with n characters from position pos\n (0 <= pos < Length(src)) in src.\n If n > Length(src) - pos, dst is only the part of src from pos to\n Length(src) - 1. If the size of dst is not large enough to hold the result\n of the operation, the result is truncated so that dst is always terminated\n with a 0X.\n Strings.Pos(pat, s, pos)\n returns the position of the first occurrence of pat in s after position\n pos (inclusive). If pat is not found, -1 is returned.\n Strings.Cap(s)\n replaces each lower case letter in s by its upper case equivalent.\n Strings.Copy(s, dst)\n has the same effect as Insert(s, 0, dst).\n Strings.Write(s, dst, at)\n write the string s (and a final 0X) in dst at position at overwriting any\n existing characters. It returns the position of the terminal 0X. If the size\n of dst is not large enough to hold the result of the operation, the result\n is truncated so that dst is always terminated with a 0X and the function\n returns -1.\n Strings.WriteChar(c, dst, at)\n write the character c in dst at position at, if the size of dst is large\n enough to hold c while keeping the terminal character 0X. It returns the\n position of terminal 0X or -1 if nothing was written.\n Strings.WriteInt(x, n, dst)\n write in dst at position at the string representation of x padded with\n blanks on the left up to a length of n. If n is too small no padding is\n applied. If the size of dst is too small to hold x and the padding, the\n function does not append any characters. It returns the position of\n terminal 0X or -1 if nothing was written.\n*)\n\nMODULE Strings; (*HM 94-06-22, LB 2017 *)\n\nPROCEDURE Length* (s: ARRAY OF CHAR): INTEGER;\n VAR i: INTEGER;\nBEGIN\n i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;\n RETURN i\nEND Length;\n\nPROCEDURE Write* (src: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR;\n at: INTEGER): INTEGER;\n VAR i, ldest, lsrc: INTEGER;\nBEGIN\n ldest := LEN(dest)-1;\n lsrc := LEN(src);\n IF (at >= 0) & (ldest > 0) & (lsrc > 0) & (at < ldest) THEN\n i := 0;\n WHILE (at < ldest) & (i < lsrc) & (src[i] # 0X) DO\n dest[at] := src[i];\n INC(at);\n INC(i)\n END;\n dest[at] := 0X;\n IF (i < lsrc) & (src[i] # 0X) THEN at := -1 END\n ELSE at := -1\n END\n RETURN at\nEND Write;\n\nPROCEDURE Append* (extra: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);\n VAR n1, n2, i: INTEGER;\nBEGIN\n n1 := Length(dest); n2 := Length(extra); i := 0;\n WHILE (i < n2) & (i + n1 < LEN(dest)) DO dest[i + n1] := extra[i]; INC(i) END;\n IF i + n1 < LEN(dest) THEN dest[i + n1] := 0X\n ELSIF LEN(dest) # 0 THEN dest[LEN(dest)-1] := 0X END\nEND Append;\n\nPROCEDURE WriteChar* (c: CHAR; VAR dest: ARRAY OF CHAR; at: INTEGER): INTEGER;\nBEGIN\n IF (at >= 0) & (at+1 < LEN(dest)) THEN\n dest[at] := c;\n dest[at+1] := 0X;\n INC(at)\n ELSE at := -1\n END\n RETURN at\nEND WriteChar;\n\nPROCEDURE AppendChar* (c: CHAR; VAR dest: ARRAY OF CHAR);\n VAR i: INTEGER;\nBEGIN\n i := WriteChar(c, dest, Length(dest))\nEND AppendChar;\n\nPROCEDURE WriteInt* (x, n: INTEGER; VAR dest: ARRAY OF CHAR;\n at: INTEGER): INTEGER;\n VAR i, size, tot, neg: INTEGER;\n a: ARRAY 10 OF CHAR;\nBEGIN\n IF ROR(x, 31) = 1 THEN at := Write(\" -2147483648\", dest, at)\n ELSE i := 0;\n IF x < 0 THEN DEC(n); x := -x; neg := 1 ELSE neg := 0 END;\n REPEAT\n a[i] := CHR(x MOD 10 + 30H); x := x DIV 10; INC(i)\n UNTIL x = 0;\n size := LEN(dest);\n tot := at + i + neg;\n IF n >= i THEN tot := tot + (n - i) END;\n IF (at >= 0) & (tot < size) THEN\n WHILE n > i DO dest[at] := \" \"; DEC(n); INC(at) END;\n IF neg = 1 THEN dest[at] := \"-\"; INC(at) END;\n REPEAT DEC(i); dest[at] := a[i]; INC(at) UNTIL i = 0;\n dest[at] := 0X\n ELSE at := -1\n END\n END\n RETURN at\nEND WriteInt;\n\nPROCEDURE AppendInt* (x, n: INTEGER; VAR dest: ARRAY OF CHAR);\n VAR i: INTEGER;\nBEGIN\n i := WriteInt(x, n, dest, Length(dest))\nEND AppendInt;\n\nPROCEDURE Copy* (src: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);\n VAR i, ldest, lsrc: INTEGER;\nBEGIN\n ldest := LEN(dest)-1;\n lsrc := LEN(src);\n IF (ldest > 0) & (lsrc > 0) THEN\n i := 0;\n WHILE (i < ldest) & (i < lsrc) & (src[i] # 0X) DO\n dest[i] := src[i];\n INC(i)\n END;\n dest[i] := 0X\n END\nEND Copy;\n\nPROCEDURE Insert* (source: ARRAY OF CHAR; pos: INTEGER;\n VAR dest: ARRAY OF CHAR);\n VAR n1, n2, len, i, j: INTEGER;\nBEGIN\n n1 := Length(dest); n2 := Length(source); len := LEN(dest);\n IF pos < 0 THEN pos := 0 END;\n IF pos > n1 THEN Append(source, dest)\n ELSE\n (*--- make room for source*)\n IF pos + n2 < len THEN\n i := n1; j := i + n2; (*move also 0X if it is there*)\n WHILE i >= pos DO\n IF j < len THEN dest[j] := dest[i] END;\n DEC(i); DEC(j)\n END\n END;\n (*--- copy source to dest*)\n i := 0; j := pos;\n WHILE (i < n2) & (j < len) DO\n dest[j] := source[i];\n INC(i); INC(j)\n END;\n IF (j >= len) & (LEN(dest) # 0) THEN dest[len-1] := 0X END\n END\nEND Insert;\n\n\nPROCEDURE Delete* (VAR s: ARRAY OF CHAR; pos, n: INTEGER);\n VAR len, i: INTEGER;\nBEGIN\n len:=Length(s);\n IF pos < len THEN\n IF pos < 0 THEN pos:=0 END;\n IF pos + n < len THEN\n i:=pos + n; WHILE i < len DO s[i - n]:=s[i]; INC(i) END;\n IF i - n < LEN(s) THEN s[i - n]:=0X END\n ELSIF LEN(s) # 0 THEN s[pos]:=0X\n END\n END\nEND Delete;\n\n\nPROCEDURE Replace* (source: ARRAY OF CHAR; pos: INTEGER;\n VAR dest: ARRAY OF CHAR);\nBEGIN\n Delete(dest, pos, Length(source));\n Insert(source, pos, dest)\nEND Replace;\n\n\nPROCEDURE Extract* (source: ARRAY OF CHAR; pos, n: INTEGER;\n VAR dest: ARRAY OF CHAR);\n VAR len, destLen, i: INTEGER;\nBEGIN\n IF (LEN(dest) # 0) & (LEN(source) # 0) THEN\n len := Length(source); destLen := LEN(dest) - 1;\n IF pos < 0 THEN pos := 0 END;\n IF pos >= len THEN dest[0] := 0X\n ELSE\n i := 0;\n WHILE (pos + i <= LEN(source)) & (source[pos + i] # 0X) & (i < n) DO\n IF i < destLen THEN dest[i] := source[pos + i] END;\n INC(i)\n END;\n dest[i] := 0X\n END\n END\nEND Extract;\n\n\nPROCEDURE Pos* (pattern, s: ARRAY OF CHAR; pos: INTEGER): INTEGER;\n VAR n1, n2, i, j, res: INTEGER; done: BOOLEAN;\nBEGIN\n n1 := Length(s); n2 := Length(pattern);\n IF n2 = 0 THEN res := 0\n ELSE\n res := -1;\n done := FALSE;\n i := pos;\n WHILE ~done & (i <= n1 - n2) DO\n IF s[i] = pattern[0] THEN\n j := 1; WHILE (j < n2) & (s[i + j] = pattern[j]) DO INC(j) END;\n IF j = n2 THEN res := i; done := TRUE END\n END;\n INC(i)\n END;\n END\n RETURN res\nEND Pos;\n\n\nPROCEDURE Cap* (VAR s: ARRAY OF CHAR);\n VAR i: INTEGER;\nBEGIN\n IF LEN(s) # 0 THEN\n i := 0;\n WHILE s[i] # 0X DO\n IF (\"a\" <= s[i]) & (s[i] <= \"z\") THEN\n s[i] := CHR(ORD(s[i]) - ORD(\"a\") + ORD(\"A\"))\n END;\n INC(i)\n END\n END\nEND Cap;\n\n\nPROCEDURE Match* (string, pattern: ARRAY OF CHAR): BOOLEAN;\n\n PROCEDURE M (name, mask: ARRAY OF CHAR; n, m: INTEGER): BOOLEAN;\n VAR res: BOOLEAN;\n BEGIN\n res := TRUE;\n WHILE (n >= 0) & (m >= 0) & (mask[m] # \"*\") DO\n IF name[n] # mask[m] THEN res := FALSE; n := 0; END;\n DEC(n); DEC(m)\n END;\n IF res THEN\n res := FALSE;\n (* ----- name empty | mask empty | mask ends with \"*\" *)\n IF m < 0 THEN res := n < 0\n ELSE\n (* ----- name empty | mask ends with \"*\" *)\n WHILE (m >= 0) & (mask[m] = \"*\") DO DEC(m) END;\n IF m < 0 THEN res := TRUE\n ELSE\n (* ----- name empty | mask still to be matched *)\n WHILE n >= 0 DO\n IF M(name, mask, n, m) THEN res := TRUE; n := 0 END;\n DEC(n)\n END\n END\n END\n END\n RETURN res\n END M;\n\nBEGIN\n RETURN M(string, pattern, Length(string)-1, Length(pattern)-1)\nEND Match;\n\nEND Strings.\n" }, { "path": "src/java/Files.java", "content": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\nimport java.io.FileNotFoundException;\nimport java.io.IOException;\nimport java.io.RandomAccessFile;\nimport java.nio.file.Paths;\n\nimport static java.nio.file.StandardCopyOption.REPLACE_EXISTING;\n\npublic final class Files {\n public static final int OK = 0;\n public static final int EOF = -1;\n public static final int IOERROR = -2;\n public static final int UTF8ERROR = -3;\n public static final char[] SEPARATOR = java.io.File.separator.toCharArray();\n\n // Ensure non-instantiability\n private Files() {}\n\n public static int Status(Files_FileDesc file) {\n return file.err;\n }\n\n public static int Rename(char[] from, char[] to) {\n int r = OK;\n try {\n java.nio.file.Files.move(Paths.get(toStr(from)), Paths.get(toStr(to)),\n REPLACE_EXISTING);\n } catch(IOException e) {\n r = IOERROR;\n }\n return r;\n }\n\n public static boolean Exists(char[] name) {\n boolean r;\n r = false;\n java.io.File f = new java.io.File(toStr(name));\n if(f.exists() && !f.isDirectory()) {\n r = true;\n }\n return r;\n }\n\n public static int Delete(char[] name) {\n int r;\n r = OK;\n java.io.File f = new java.io.File(toStr(name));\n try {\n if(!f.delete()) {\n r = IOERROR;\n }\n } catch(SecurityException e) {\n r = IOERROR;\n }\n return r;\n }\n\n public static Files_FileDesc Create(char[] name) {\n return open(name, \"rw\", true);\n }\n\n private static Files_FileDesc open(char[] name, String mode,\n boolean truncate) {\n Files_FileDesc file;\n file = new Files_FileDesc();\n try {\n file.f = new RandomAccessFile(toStr(name), mode);\n if(truncate) {\n file.f.setLength(0);\n }\n file.err = OK;\n } catch(FileNotFoundException e) {\n file = null;\n } catch(IOException e) {\n file.err = IOERROR;\n }\n return file;\n }\n\n public static Files_FileDesc Open(char[] name) {\n return open(name, \"r\", false);\n }\n\n public static void Close(Files_FileDesc file) {\n try {\n file.f.close();\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n\n private static String toStr(char[] name) {\n int i, len;\n len = name.length;\n i = 0;\n if(len > 0) {\n while(i < len && name[i] != '\\0') {\n i++;\n }\n }\n return new String(name, 0, i);\n }\n\n public static void WriteAsciiStr(Files_FileDesc file, char[] str) {\n int i;\n if(str.length > 0 && file.err == OK) {\n i = 0;\n while(i < str.length && str[i] != '\\0' && file.err == OK) {\n Write(file, (byte) (str[i] & 0xFF));\n i++;\n }\n Write(file, (byte) 0);\n }\n }\n\n public static void WriteStr(Files_FileDesc file, char[] str) {\n int i;\n if(str.length > 0 && file.err == OK) {\n i = 0;\n while(i < str.length && str[i] != '\\0' && file.err == OK) {\n WriteChar(file, str[i]);\n i++;\n }\n Write(file, (byte) 0);\n }\n }\n\n public static void Write(Files_FileDesc file, byte b) {\n if(file.err == OK) {\n try {\n file.f.write(b);\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n }\n\n public static void WriteChar(Files_FileDesc file, char c) {\n // 0x0000 <= c <= 0xFFFF\n if(file.err == OK) {\n if (c >= 0x0000 && c <= 0x007F) { // 1 bytes format: 0xxxxxxx\n Write(file, (byte) c);\n } else if(c >= 0x0800) { // 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx\n Write(file, (byte) (0xE0 | ((c >> 12) & 0x0F)));\n Write(file, (byte) (0x80 | ((c >> 6) & 0x3F)));\n Write(file, (byte) (0x80 | (c & 0x3F)));\n } else { // 2 bytes format: 110xxxxx 10xxxxxx\n Write(file, (byte) (0xC0 | ((c >> 6) & 0x1F)));\n Write(file, (byte) (0x80 | (c & 0x3F)));\n }\n }\n }\n\n public static void WriteBytes(Files_FileDesc file, byte[] b) {\n if(file.err == OK) {\n try {\n file.f.write(b);\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n }\n\n public static void WriteNBytes(Files_FileDesc file, byte[] b, int len) {\n if(file.err == OK) {\n try {\n file.f.write(b, 0, len);\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n }\n\n /* Little endian */\n public static void WriteInt(Files_FileDesc file, int x) {\n if(file.err == OK) {\n Write(file, (byte) (x & 0xFF));\n Write(file, (byte) ((x >> 8) & 0xFF));\n Write(file, (byte) ((x >> 16) & 0xFF));\n Write(file, (byte) ((x >> 24) & 0xFF));\n }\n }\n\n /*\n LEB128\n\n LEB128 (\"Little-Endian Base 128\") is a variable-length encoding for arbitrary\n signed or unsigned integer quantities.\n Each LEB128 encoded value consists of one to five bytes, which together\n represent a single 32-bit value.\n Each byte has its most significant bit set except for the final byte in the\n sequence, which has its most significant bit clear. The remaining seven bits\n of each byte are payload, with the least significant seven bits of the\n quantity in the first byte, the next seven in the second byte and so on.\n In the case of a signed LEB128, the most significant PAYLOAD bit of\n the final byte in the sequence is sign-extended to produce the final value.\n\n With 7 bits I can store numbers in this range:\n -2^6 <= x <= 2^6-1\n -64 <= x <= 63\n -64 <= x < 64\n -0x40 <= x < 0x40\n\n example:\n -908 = 11111111111111111111110001110100 in two's complement\n\n 1111 1111111 1111111 1111000 1110100 -> group of 7 bits\n\n write 8 bits -> 1 1110100\n ^----------- always one so these bits represent an\n unsigned byte >= 128\n\n shift -908 7 bits to the right -> 1111 1111111 1111111 1111000 = -8\n -64 <= -8 < 64 , write it in 8 bits -> 01111000\n */\n public static void WriteNum(Files_FileDesc file, int x) {\n if(file.err == OK) {\n while((x < -0x40 || x >= 0x40) && file.err == OK) {\n Write(file, (byte) ((x & 0x7F) + 0x80));\n x = x >> 7;\n }\n Write(file, (byte) (x & 0x7F));\n }\n }\n\n /*\n example: read -999999999 = 11000100011001010011011000000001\n = 1100 0100011 0010100 1101100 0000001\n back from 10000001 11101100 10010100 10100011 01111100\n\n 1 0000001\n ^----------- one so these bits represent an unsigned byte\n >= 128\n\n remove the first one -> 1 0000001 - 0x80 =\n 00000001 =\n 0000 0000000 0000000 0000000 0000001\n The number 0000001 represents the first least significant 7 bits group\n of the original number.\n The next byte read 11101100, encode the next 7 bits group (after\n removing the first one, like before), so we shift it by 7 and add it to\n the previous number:\n\n 1 1101100 >= 128\n remove the first one -> 1 1101100 - 0x80 =\n 0 1101100 =\n 0000 0000000 0000000 0000000 1101100\n shift to the left by 7 on a 32 bit range ->\n 00000000000000000011011000000000\n\n and add it to the previous number:\n 00000000000000000011011000000000 +\n 00000000000000000000000000000001\n = 00000000000000000011011000000001\n = 0000 0000000 0000000 1101100 0000001\n\n We keep doing the above for the next bytes with the MSB set to 1\n resulting in the sum 0000 0100011 0010100 1101100 0000001.\n\n\n the last byte 01111100 = 124 < 128\n\n 0 1 111100\n ^---------- sign of the original number\n ^----------- tag, always 0 for the last byte read.\n\n We separate the sign bit of the original number form the rest.\n\n Sign\n 0 1 111100 AND 0x40\n = 0 1 111100 AND\n 0 1 000000\n = 0 1 000000\n\n The rest\n 0 1 111100 AND 0x3F\n = 0 1 111100 AND\n 0 0 111111\n = 0 0 111100\n\n We now can sign extend this last most significant 7 bits of the original\n number by subtracting 0 0 111100 with 0 1 000000:\n\n 0000 0000000 0000000 0000000 0 0 111100 -\n 0000 0000000 0000000 0000000 0 1 000000\n = 1111 1111111 1111111 1111111 1 1 111100\n\n Now we can do a final shift and sum it with\n 0000 0100011 0010100 1101100 0000001, to obtain the result\n\n\n 1111 1111111 1111111 1111111 1 1 111100 << 28\n = 1100 0000000 0000000 0000000 0000000\n\n 0000 0100011 0010100 1101100 0000001 +\n 1100 0000000 0000000 0000000 0000000\n = 1100 0100011 0010100 1101100 0000001\n = -999999999\n\n */\n public static int ReadNum(Files_FileDesc file) {\n int n, y, b, x;\n x = 0;\n if(file.err == OK) {\n n = 0;\n y = 0;\n b = read(file);\n while(b >= 0x80) {\n y += ((b - 0x80) << n);\n n += 7;\n b = read(file);\n }\n b = (b & 0x3F) - (b & 0x40);\n x = y + (b << n);\n }\n return x;\n }\n\n public static byte Read(Files_FileDesc file) {\n byte b = 0;\n if(file.err == OK) {\n b = (byte) read(file);\n }\n return b;\n }\n\n public static char ReadChar(Files_FileDesc file) {\n int b1, b2, b3;\n char ch = '\\0';\n b1 = read(file);\n if (file.err == OK) {\n switch(b1 >> 4) {\n case 0:\n case 1:\n case 2:\n case 3:\n case 4:\n case 5:\n case 6:\n case 7: // 1 bytes format: 0xxxxxxx\n ch = (char) b1;\n break;\n\n case 12:\n case 13: // 2 bytes format: 110xxxxx 10xxxxxx\n b2 = read(file);\n if(file.err == OK && (b2 & 0xC0) != 0x80) {\n file.err = UTF8ERROR;\n }\n ch = (char) (((b1 & 0x1F) << 6) | (b2 & 0x3F));\n break;\n\n case 14: // 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx\n b2 = read(file);\n b3 = read(file);\n if(file.err == OK && ((b2 & 0xC0) != 0x80 || (b3 & 0xC0) != 0x80)) {\n file.err = UTF8ERROR;\n }\n ch = (char) (((b1 & 0x0F) << 12) |\n ((b2 & 0x3F) << 6) |\n (b3 & 0x3F));\n break;\n\n default: // ERROR + 4 bytes format: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx\n file.err = UTF8ERROR;\n ch = '\\0';\n }\n }\n return ch;\n }\n\n private static int read(Files_FileDesc file) {\n int x;\n x = 0;\n if(file.err == OK) {\n try {\n x = file.f.read();\n if(x < 0) {\n file.err = EOF;\n }\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n return x;\n }\n\n public static void ReadBytes(Files_FileDesc file, byte[] b, int[] n) {\n if(file.err == OK) {\n try {\n n[0] = file.f.read(b);\n if(n[0] < 0) {\n file.err = EOF;\n }\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n }\n\n /* Little endian */\n public static int ReadInt(Files_FileDesc file) {\n int x0, x1, x2, x3, x;\n x0 = read(file); x1 = read(file); x2 = read(file); x3 = read(file);\n x = (((((x3 << 8) + x2) << 8) + x1) << 8) + x0;\n return x;\n }\n\n public static void ReadAsciiStr(Files_FileDesc file, char[] str) {\n int i, ch, last;\n if(str.length > 0 && file.err == OK) {\n i = 0;\n last = str.length - 1;\n ch = read(file);\n while(i < last && ch != '\\0' && file.err == OK) {\n str[i] = (char) ch;\n ch = read(file);\n i++;\n }\n str[i] = '\\0';\n }\n }\n\n public static int ReadStr(Files_FileDesc file, char[] str) {\n int i, last;\n char ch;\n i = 0;\n if(str.length > 0 && file.err == OK) {\n last = str.length - 1;\n ch = ReadChar(file);\n while(i < last && ch != '\\0' && file.err == OK) {\n str[i] = ch;\n ch = ReadChar(file);\n i++;\n }\n str[i] = '\\0';\n }\n return i;\n }\n\n public static int Seek(Files_FileDesc file, int pos) {\n int r;\n r = OK;\n try {\n file.f.seek(pos);\n if(file.err == EOF) {\n file.err = OK;\n }\n } catch(IOException e) {\n r = IOERROR;\n }\n return r;\n }\n\n public static int Size(Files_FileDesc file) {\n int len;\n len = -1;\n if(file.err == OK) {\n try {\n len = (int) file.f.length();\n } catch(IOException e) {\n file.err = IOERROR;\n }\n }\n return len;\n }\n}\n" }, { "path": "src/java/Files_FileDesc.java", "content": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\nimport java.io.RandomAccessFile;\n\npublic class Files_FileDesc {\n public RandomAccessFile f;\n public int err;\n public Files_FileDesc() {}\n\n public Files_FileDesc copy() {\n Files_FileDesc x = new Files_FileDesc();\n x.f = this.f;\n x.err = this.err;\n return x;\n }\n}\n" }, { "path": "src/java/In.java", "content": "/*\n Copyright 2019 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\nimport java.util.Scanner;\n\npublic final class In {\n\n static public boolean Done;\n static private Scanner scanner;\n\n // Ensure non-instantiability\n private In() {}\n\n static {\n Done = true;\n scanner = new Scanner(System.in, \"UTF-8\");\n }\n\n\n static public void Char(char[] ch) {\n Done = true;\n try {\n int c = System.in.read();\n if (c == -1) {\n Done = false;\n } else {\n ch[0] = (char) (c & 0xFF);\n }\n } catch(Exception e) {\n Done = false;\n }\n }\n\n static public void String(char[] str) {\n int i, ldest, lsrc;\n char[] line;\n\n Done = true;\n try {\n line = scanner.nextLine().toCharArray();\n ldest = str.length - 1;\n lsrc = line.length;\n if(ldest > 0) {\n i = 0;\n while(i < ldest && i < lsrc && line[i] != '\\0') {\n str[i] = line[i];\n i++;\n }\n str[i] = '\\0';\n }\n } catch(Exception e) {\n Done = false;\n }\n }\n\n static public void Real(float[] x) {\n Done = true;\n try {\n x[0] = scanner.nextFloat();\n } catch(Exception e) {\n Done = false;\n }\n }\n\n static public void Int(int[] i) {\n Done = true;\n try {\n i[0] = scanner.nextInt();\n } catch(Exception e) {\n Done = false;\n }\n }\n}\n" }, { "path": "src/java/Math.java", "content": "/*\n Copyright 2020 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\npublic final class Math {\n public static final float pi = 3.14159265358979323846f;\n public static final float e = 2.71828182845904523536f;\n\n // Ensure non-instantiability\n private Math() {}\n\n public static float sqrt(float x) {\n return (float) java.lang.Math.sqrt(x);\n }\n\n public static float power(float x, float base) {\n return (float) java.lang.Math.pow(base, x);\n }\n\n public static float exp(float x) {\n return (float) java.lang.Math.exp(x);\n }\n\n public static float ln(float x) {\n return (float) java.lang.Math.log(x);\n }\n\n public static float log(float x, float b) {\n return (float) (java.lang.Math.log(x) / java.lang.Math.log(b));\n }\n\n public static float round(float x) {\n return (float) java.lang.Math.round(x);\n }\n\n public static float sin(float x) {\n return (float) java.lang.Math.sin(x);\n }\n\n public static float cos(float x) {\n return (float) java.lang.Math.cos(x);\n }\n\n public static float tan(float x) {\n return (float) java.lang.Math.tan(x);\n }\n\n public static float arcsin(float x) {\n return (float) java.lang.Math.asin(x);\n }\n\n public static float arccos(float x) {\n return (float) java.lang.Math.acos(x);\n }\n\n public static float arctan(float x) {\n return (float) java.lang.Math.atan(x);\n }\n\n public static float arctan2(float x, float y) {\n return (float) java.lang.Math.atan2(x, y);\n }\n\n public static float sinh(float x) {\n return (float) java.lang.Math.sinh(x);\n }\n\n public static float cosh(float x) {\n return (float) java.lang.Math.cosh(x);\n }\n\n public static float tanh(float x) {\n return (float) java.lang.Math.tanh(x);\n }\n\n public static float arcsinh(float x) {\n return (float) java.lang.Math.log(x +\n (float) java.lang.Math.sqrt(x * x + 1.0f));\n }\n\n public static float arccosh(float x) {\n return (float) java.lang.Math.log(x +\n (float) java.lang.Math.sqrt(x * x - 1.0f));\n }\n\n public static float arctanh(float x) {\n return (float) (0.5 * java.lang.Math.log((1.0f + x) / (1.0f - x)));\n }\n\n}\n" }, { "path": "src/java/OberonRuntime.java", "content": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\nimport java.io.IOException;\nimport java.util.Locale;\n\npublic final class OberonRuntime {\n\n // Ensure non-instantiability\n private OberonRuntime() {}\n\n /*\n Euclidean division (from \"Division and Modulus for Computer Scientists\")\n\n For any real numbers x and y with y # 0, there exists a unique\n pair of numbers q and r that satisfy the following conditions:\n - q is a signed integer\n - x = q*y + r\n - 0 <= r < |y|\n\n Euclidean division satisfies the following:\n 1. x DIV (-y) = - (x DIV y)\n 2. x MOD (-y) = x MOD y\n 3. x DIV 2^n = x ASR n (arithmetic/signed shift right)\n 4. x * 2^n = x LSL n (logical shift left)\n 5. x MOD 2^n = x and (2^n - 1)\n\n */\n public static int DIV(int x, int y) {\n int q = x / y;\n int r = x % y;\n if (r < 0) {\n if (y > 0) {\n q = q - 1;\n } else {\n q = q + 1;\n }\n }\n return q;\n }\n\n public static int MOD(int x, int y) {\n int r = x % y;\n if (r < 0) {\n if (y > 0) {\n r = r + y;\n } else {\n r = r - y;\n }\n }\n return r;\n }\n\n public static int ASR(int x, int n) {\n return x >> n;\n }\n\n\n public static int ROR(int x, int n) {\n // see Integer.rotateRight()\n return (x >>> n) | (x << -n);\n }\n\n public static int StrCmp(char[] s0, char[] s1) {\n int cmp;\n int i = 0;\n int len = java.lang.Math.min(s0.length, s1.length);\n while(i < len && s0[i] == s1[i] && s0[i] != '\\0') {\n i++;\n }\n if(i < len) {\n // this is safe, it will never overflow as cmp is an int (32 bits) and\n // s0, s1 are of type char (16 bits)\n cmp = s0[i] - s1[i];\n } else {\n cmp = s0.length - s1.length;\n }\n\n return cmp;\n }\n\n public static void ARGS(String[] args, int i, char[] out) {\n int end;\n if(out.length > 0) {\n end = 0;\n if(i < args.length) {\n end = args[i].length();\n if(end >= out.length) {\n end = out.length - 1;\n }\n System.arraycopy(args[i].toCharArray(), 0, out, 0, end);\n }\n out[end] = '\\0';\n }\n }\n\n public static int ReadInt() {\n int c;\n int num = 0;\n boolean neg = false;\n try {\n c = System.in.read();\n if(c == '-') {\n neg = true;\n c = System.in.read();\n }\n while(c != -1 && c != ' ' && c != '\\n') {\n num = (num*10) + c - '0';\n c = System.in.read();\n }\n } catch(IOException e) { num = 0;}\n if(neg) {\n num = -num;\n }\n return num;\n }\n\n public static void WriteInt(int num) {\n if(num <= 999 && num >= -99) {\n System.out.printf(Locale.US, \"%4d\", num);\n } else {\n System.out.printf(Locale.US, \" %d\", num);\n }\n }\n\n public static void WriteReal(float num) {\n System.out.printf(Locale.US, \" %f\", num);\n }\n\n public static void WriteChar(int c) {\n System.out.print((char)c);\n }\n\n public static void WriteLn() {\n System.out.print('\\n');\n }\n\n public static boolean eot() {\n int available = 0;\n try {\n available = System.in.available();\n } catch(IOException e) { }\n return available == 0;\n }\n}\n" }, { "path": "src/java/Os.java", "content": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\npublic final class Os {\n\n private static long date2010x01x01xUTC = 1262304000000L;\n\n // Ensure non-instantiability\n private Os() {}\n\n private static String toString(char[] name) {\n int i;\n\n i = 0;\n while(i < name.length && name[i] != '\\0') {\n i++;\n }\n return new String(name, 0, i);\n }\n\n public static void GetEnv(char[] out, char[] name) {\n int i;\n\n if(out.length > 0 && name.length > 0) {\n try {\n String s = System.getenv(toString(name));\n i = 0;\n if(s != null) {\n i = java.lang.Math.min(s.length(), out.length-1);\n System.arraycopy(s.toCharArray(), 0, out, 0, i);\n }\n out[i] = '\\0';\n } catch(Exception e) {\n out[0] = '\\0';\n }\n }\n }\n\n public static int CurrentTime() {\n return (int) ((System.currentTimeMillis() - date2010x01x01xUTC) / 1000);\n }\n\n public static void Exit(int status) {\n System.exit(status);\n }\n}\n" }, { "path": "src/java/Out.java", "content": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*/\n\nimport java.io.PrintStream;\nimport java.io.UnsupportedEncodingException;\n\npublic final class Out {\n\n // Ensure non-instantiability\n private Out() {}\n\n static {\n try {\n System.setOut(new PrintStream(System.out, true, \"UTF-8\"));\n System.setErr(new PrintStream(System.err, true, \"UTF-8\"));\n } catch(UnsupportedEncodingException e) {\n // keep defaults\n }\n }\n\n public static void Char(char ch) {\n System.out.print(ch);\n }\n\n public static void String(char[] str) {\n int i = 0;\n int len = str.length;\n while(i < len && str[i] != '\\0') {\n i++;\n }\n System.out.print(new String(str, 0, i));\n }\n\n public static void Real(float x, int n) {\n if(n <= 0) {\n System.out.print(x);\n } else {\n System.out.printf(\"%\" + n + \"f\", x);\n }\n }\n\n public static void Int(int x, int n) {\n if(n <= 0) {\n System.out.print(x);\n } else {\n System.out.printf(\"%\" + n + \"d\", x);\n }\n }\n\n public static void Ln() {\n System.out.print('\\n');\n }\n\n public static void Hex(int x) {\n System.out.printf(\"%08X\", x);\n }\n\n}\n" }, { "path": "src/oberonc.Mod", "content": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICENSE file.\n*)\n\nMODULE oberonc;\nIMPORT OJS, OJP, Out, Os, Strings;\n\n PROCEDURE Help;\n BEGIN\n Out.String(\"Oberon-07 compiler v1.X\"); Out.Ln;\n Out.Ln;\n Out.String(\"Usage: oberonc outputFolder sourceFile1.Mod[+] sourceFile2.Mod[+] ...\"); Out.Ln;\n Out.Ln;\n Out.String(\"It compiles the list of provided source module files and places the generated\"); Out.Ln;\n Out.String(\"classes in the existing 'outputFolder'.\"); Out.Ln;\n Out.String(\"The optional suffix '+' allows the compiler to create a new symbol file. If this\"); Out.Ln;\n Out.String(\"option is not specified, a change in the interface of the module results in a\"); Out.Ln;\n Out.String(\"compilation error.\"); Out.Ln;\n END Help;\n\n PROCEDURE Main;\n VAR i, len, n, ret: INTEGER;\n folder, arg: ARRAY OJS.maxPath OF CHAR;\n newSym: BOOLEAN;\n BEGIN\n ret := 0;\n n := ARGNUM();\n IF n < 2 THEN\n Help\n ELSE\n ARGS(0, folder);\n FOR i := 1 TO n-1 DO\n ARGS(i, arg);\n len := Strings.Length(arg);\n IF arg[len-1] = \"+\" THEN\n newSym := TRUE;\n arg[len-1] := 0X\n ELSE\n newSym := FALSE\n END ;\n OJP.Compile(arg, newSym, folder);\n IF OJS.errcnt > 0 THEN\n ret := 1\n END\n END\n END ;\n Os.Exit(ret)\n END Main;\nEND oberonc.\n" }, { "path": "tests/TestRunner.java", "content": "import java.io.ByteArrayInputStream;\nimport java.io.ByteArrayOutputStream;\nimport java.io.File;\nimport java.io.InputStream;\nimport java.io.PrintStream;\nimport java.lang.reflect.Method;\n\npublic class TestRunner {\n private static final String suitePath = \"tests/base/\";\n private static final String outFolder = \"tests/out/\";\n\n public static void main(String[] args) {\n int[] tot = new int[1];\n int[] successful = new int[1];\n int[] failed = new int[1];\n String[] tests = {\n \"VarInit\", \"DivMul\", \"ProcVariables0\", \"ProcVariables1\", \"ProcVariables2\",\n \"ProcVariables3\", \"ProcVariables4\", \"ProcVariables5\", \"ProcVariables6\",\n \"RecordAndTypeExtension\", \"ProcComparisons\", \"FragileBaseClass\",\n \"Strings0\", \"Strings1\", \"Strings2\", \"OpenArrays2\", \"OpenArrays3\",\n \"TestABS\", \"TestCPS\", \"TestODD\", \"TestOOP\", \"SetTest\", \"Out0\",\n \"UTF8String\", \"TestAnonymousName\", \"RecordAssignment\", \"TestShift\",\n \"TestByteType\", \"TestINC0\", \"TestINC1\", \"Arrays2\", \"Arrays3\", \"TestFor\",\n \"Out3\", \"EmptyArrayAndRecord\", \"ArrayAssignment\", \"OpenArrays\",\n \"TestAssignmentMix\", \"TestEqualSignature00\", \"BitFunc\", \"Out4\",\n \"ProcType\", \"ConstantFoldingAndLoadOp\", \"CommutativeSwap\", \"Out5\",\n \"TestFunction0\", \"RealExpressions\", \"Pattern2a\", \"Pattern2b\", \"Pattern2c\",\n \"Out2\", \"TestReturn0\", \"CaseNum0\", \"CaseNum1\", \"TestINCLAndEXCL\",\n \"CaseRecord0\", \"CaseRecord1\", \"CaseRecord2\", \"TestTypeConvFun\",\n \"TestFor1\", \"Out1\", \"TestAssert\", \"CaseChar0\", \"Out6\", \"TestSystemVal\",\n \"TestNestedProcs\", \"Pattern1\", \"TestStringsMod\", \"OutTest\",\n \"ProcVariables7\", \"RecordAssignment2\", \"RecordParam\", \"CaseRecord3\",\n \"VarParGuard\", \"TestTypeTest\", \"TestConstFunc\", \"TestMath\", \"CaseRecord4\",\n \"UniqueTypeAndProcNames\", \"ForwardPointerRef\"\n };\n successful[0] = 0;\n failed[0] = 0;\n tot[0] = 0;\n for(String test : tests) {\n check(tot, successful, failed, compileAndRun(test));\n }\n\n check(tot, successful, failed, compileAndRunArgs(\"TestCmdLineArgs\", \"\",\n new String[] {\"Hello\", \"World!\"}));\n testImports(tot, successful, failed);\n testCyclicImports(tot, successful, failed);\n testWithInputs(tot, successful, failed);\n testTypeGuardExt(tot, successful, failed);\n check(tot, successful, failed,\n compileAndFail(\"TestReadOnlyPar\", 3, \"read only\"));\n check(tot, successful, failed,\n compileAndFail(\"ArrayConstantSize\", 2, \"not a valid length\"));\n check(tot, successful, failed,\n compileAndFail(\"TestExprVarPar\", 2, \"Only variables allowed\"));\n System.err.println(\"TOTAL: \" + tot[0]);\n System.err.println(\"SUCCESSFUL: \" + successful[0]);\n System.err.println(\"FAILED: \" + failed[0]);\n }\n\n private static void check(int[] tot, int[] successful, int[] failed,\n boolean res) {\n if(res) {\n successful[0]++;\n } else {\n failed[0]++;\n }\n tot[0]++;\n }\n\n private static void testImports(int[] tot, int[] successful, int[] failed) {\n boolean res, res0, res1;\n int i;\n // the compilation order matters\n String[][] suite = {\n {\"TestImport00\", \"TestImport01\"},\n {\"TestImport10\", \"TestImport11\"},\n {\"TestImport20\", \"TestImport21\", \"TestImport22\"},\n {\"TestImport30\", \"TestImport31\"},\n {\"TestImport40\", \"TestImport41\", \"TestImport42\"},\n {\"TestImport50\", \"TestImport51\", \"TestImport52\", \"TestImport53\"},\n {\"TestImport60\", \"TestImport61\", \"TestImport62\"},\n {\"TestImport70\", \"TestImport71\"},\n {\"TestImport81\", \"TestImport82\", \"TestImport80\"},\n {\"TestImport90\", \"TestImport91\"},\n {\"TestImport100\"},\n {\"TestImport120\", \"TestImport121\", \"TestImport122\"},\n {\"TestImport130\", \"TestImport131\"},\n {\"TestImport140\", \"TestImport141\", \"TestImport142\"},\n {\"TestImport150\", \"TestImport151\"},\n };\n\n for(String[] test : suite) {\n res = true;\n for(i = 0; i < test.length && res; i++) {\n res = compileAndRun(test[i]);\n }\n check(tot, successful, failed, res);\n }\n res0 = compileAndRun(\"TestImport110\");\n res1 = compile(\"TestImport111\", false) == 0;\n res = compileAndRun(\"TestImport112\");\n check(tot, successful, failed, res0 && res1 && res);\n }\n\n private static void testCyclicImports(int[] tot, int[] successful,\n int[] failed) {\n\n check(tot, successful, failed, compile(\"TestCyclicImport00A\", true) == 0 &&\n compile(\"TestCyclicImport01A\", true) == 0 &&\n compileAndFail(\"TestCyclicImport00B\", 2,\n \"recursive import\"));\n\n check(tot, successful, failed, compile(\"TestCyclicImport00A\", true) == 0 &&\n compile(\"TestCyclicImport01B\", true) == 0 &&\n compileAndFail(\"TestCyclicImport00B\", 2,\n \"recursive import\"));\n\n check(tot, successful, failed, compile(\"TestCyclicImport10A\", true) == 0 &&\n compile(\"TestCyclicImport12\", true) == 0 &&\n compile(\"TestCyclicImport11\", true) == 0 &&\n compileAndFail(\"TestCyclicImport10B\", 2,\n \"recursive import\"));\n }\n\n private static void testWithInputs(int[] tot, int[] successful,\n int[] failed) {\n int i;\n String[] tests = {\n \"Samples0\", \"Samples1\", \"Samples2\", \"MagicSquares\", \"PrimeNumbers\",\n \"Fractions\", \"Permutations\", \"Powers\"\n };\n String[] inputs = {\n \"0 8 5\\n\", \"1 80 5\\n\", \"2 1 2 3 2\\n\", \"3\\n\", \"20\\n\", \"20\\n\", \"3 7 11\\n\\n\",\n \"32\\n\"\n };\n\n for(i = 0; i < tests.length; i++) {\n check(tot, successful, failed, compileAndRunWithInput(tests[i],\n inputs[i]));\n }\n }\n\n private static void testTypeGuardExt(int[] tot, int[] successful,\n int[] failed) {\n check(tot, successful, failed, compile(\"ExtTypes\", true) == 0 &&\n compileAndRun(\"TestTypeGuardExt\"));\n }\n\n private static boolean assertEquals(String name, String expected, String actual) {\n boolean res = expected.equals(actual);\n if(!res) {\n System.err.println(\"Test '\" + suitePath + name + \".Mod\" + \"' FAILED:\");\n System.err.println(\"EXPECTING:\\n\" + \"'\" + expected + \"'\");\n System.err.println(\"FOUND:\\n\" + \"'\" + actual + \"'\");\n System.err.println(\"---END---\\n\");\n }\n return res;\n }\n\n private static boolean compileAndRunArgs(String name, String input,\n String[] argv) {\n boolean res;\n InputStream org_in = System.in;\n PrintStream org_out = System.out;\n try {\n ByteArrayOutputStream out = new ByteArrayOutputStream();\n PrintStream ps = new PrintStream(out);\n InputStream in = new ByteArrayInputStream(input.getBytes());\n System.setIn(in);\n System.setOut(ps);\n if(compile(name, false) != 0) {\n System.err.println(\"Compilation of \" + suitePath + name + \".Mod\" +\n \" FAILED:\");\n System.err.println(out.toString());\n System.err.println(\"---END---\\n\");\n res = false;\n } else {\n ClassLoader classLoader = TestRunner.class.getClassLoader();\n Class aClass = classLoader.loadClass(name);\n Method main = aClass.getMethod(\"main\", String[].class);\n main.invoke(null, (Object) argv);\n res = assertEquals(name, getExpectedOutput(name), out.toString());\n }\n } catch (Exception e) {\n System.err.println(\"EXCEPTION thrown while executing \" + suitePath +\n name + \".Mod:\");\n e.printStackTrace();\n System.err.println(\"---END---\\n\");\n res = false;\n }\n System.setIn(org_in);\n System.setOut(org_out);\n return res;\n }\n\n private static int compile(String name, boolean newSym) {\n OJP.Compile((suitePath + name + \".Mod\\0\").toCharArray(), newSym,\n outFolder.toCharArray());\n return OJS.errcnt;\n }\n\n private static boolean compileAndRunWithInput(String name, String input) {\n return compileAndRunArgs(name, input, null);\n }\n\n private static boolean compileAndRun(String name) {\n return compileAndRunArgs(name, \"\", null);\n }\n\n private static boolean compileAndFail(String name, int errors, String msg) {\n boolean res;\n int errcnt;\n\n ByteArrayOutputStream out = new ByteArrayOutputStream();\n PrintStream ps = new PrintStream(out);\n System.setOut(ps);\n errcnt = compile(name, false);\n if(errcnt != errors) {\n System.err.println(\"Test '\" + name + \"' FAILED:\");\n System.err.println(\"EXPECTING: \" + errors + \" compilation error[s]\");\n System.err.println(\"FOUND: \" + errcnt);\n System.err.println(\"---END---\\n\");\n res = false;\n } else {\n res = out.toString().contains(msg);\n if(!res) {\n System.err.println(\"Test '\" + name + \"' FAILED:\");\n System.err.println(\"EXPECTED ERROR: \" + msg);\n System.err.println(\"NOT FOUND IN: \" + out.toString());\n System.err.println(\"---END---\\n\");\n }\n }\n return res;\n }\n\n private static String getExpectedOutput(String name) {\n char[] expected = new char[2000];\n String res;\n\n Files_FileDesc f = Files.Open((suitePath + name + \".txt\\0\").toCharArray());\n if(f == null) {\n System.err.println(\"ERROR: cannot open \" + suitePath + name + \".txt\");\n res = \"\";\n } else {\n Files.ReadStr(f, expected);\n Files.Close(f);\n res = new String(expected, 0, Strings.Length(expected));\n }\n return res;\n }\n}\n" }, { "path": "tests/base/ArrayAssignment.Mod", "content": "MODULE ArrayAssignment;\n TYPE\n arr2 = ARRAY 2 OF INTEGER;\n multy = ARRAY 2, 4 OF INTEGER;\n R = RECORD\n x : arr2;\n y : ARRAY 2, 2 OF INTEGER\n END;\n VAR\n a : arr2;\n m : multy;\n b : ARRAY 2 OF INTEGER;\n d0, d1 : ARRAY 2 OF R;\n e0, e1 : ARRAY 2, 9 OF R;\n PROCEDURE localAssignment(VAR c2 : arr2; VAR z2 : multy);\n VAR\n a2 : arr2;\n m2 : multy;\n b2 : ARRAY 2 OF INTEGER;\n d2, d3 : ARRAY 2 OF R;\n e2, e3 : ARRAY 2, 9 OF R;\n BEGIN\n b2[0] := 5; \n a2 := b2;\n WriteInt(a2[0]); (* 5 *)\n a2[0] := 6;\n WriteInt(b2[0]); (* 5 *)\n a2 := c2;\n WriteInt(a2[0]); (* 7 *) \n a2[0] := 6;\n WriteInt(c2[0]); (* 7 *) \n c2 := a2;\n a2[0] := 8;\n WriteInt(c2[0]); (* 6 *) \n WriteInt(a2[0]); (* 8 *) \n d2[1].x := b2;\n WriteInt(d2[1].x[0]); (* 5 *)\n d2[1].x[0] := 10;\n WriteInt(b2[0]); (* 5 *)\n a2 := d2[1].x;\n WriteInt(a2[0]); (* 10 *)\n d2[0].y[1][0] := 11;\n d2[0].y[0] := d2[0].y[1];\n WriteInt(d2[0].y[0][0]); (* 11 *)\n d2[0].y[0][0] := 12;\n WriteInt(d2[0].y[1][0]); (* 11 *)\n WriteInt(d2[0].y[0][0]); (* 12 *)\n d3[0].x[1] := 15;\n d2 := d3;\n WriteInt(d2[0].x[1]); (* 15 *)\n d2[0].x[1] := 16;\n WriteInt(d3[0].x[1]); (* 15 *)\n WriteInt(d2[0].x[1]); (* 16 *)\n e3[0][8].x[1] := 25;\n e2 := e3;\n WriteInt(e2[0][8].x[1]); (* 25 *)\n e2[0][8].x[1] := 26;\n WriteInt(e3[0][8].x[1]); (* 25 *)\n WriteInt(e2[0][8].x[1]); (* 26 *)\n m2 := z2;\n WriteInt(m2[0][1]); (* 77 *) \n m2[0][1] := 66;\n WriteInt(z2[0][1]); (* 77 *) \n z2 := m2;\n m2[0][1] := 88;\n WriteInt(z2[0][1]); (* 66 *) \n WriteInt(m2[0][1]); (* 88 *)\n END localAssignment;\nBEGIN \n a[0] := 7;\n m[0][1] := 77;\n localAssignment(a, m);\n a := b;\n d0[1].x := b;\n a := d0[1].x;\n d0[0].y[0] := d0[0].y[1];\n d0 := d1;\n e0[0][1].x := b;\n a := e0[0][1].x;\n e0[0][0].y[0] := e0[0][0].y[1];\n e0[0][0].y := e0[0][0].y;\n e0[0][0].y := e1[0][0].y;\n e0 := e1;\nEND ArrayAssignment." }, { "path": "tests/base/ArrayAssignment.txt", "content": " 5 5 7 7 6 8 5 5 10 11 11 12 15 15 16 25 25 26 77 77 66 88" }, { "path": "tests/base/ArrayConstantSize.Mod", "content": "MODULE ArrayConstantSize;\n VAR N: INTEGER;\n e: ARRAY 2*N OF CHAR;\nEND ArrayConstantSize." }, { "path": "tests/base/Arrays2.Mod", "content": "MODULE Arrays2;\n TYPE X = ARRAY 1 OF INTEGER;\n VAR\n a : X;\n b : ARRAY 1 OF INTEGER;\n (*i : ARRAY 3, 2 OF INTEGER;\n j : ARRAY 2, 4 OF INTEGER;*)\n i0 : ARRAY 4, 3, 2 OF INTEGER;\n j0 : ARRAY 4, 3, 2 OF INTEGER;\n PROCEDURE P(s : X);\n BEGIN WriteInt(s[0] + 1); (* 3 *)\n END P;\nBEGIN\n a[0] := 1;\n b[0] := 2;\n a := b;\n WriteInt(a[0]); (* 2 *)\n (*i := j; illegal assignment *)\n i0[1, 1, 1] := 8;\n j0[1][1][1] := 9;\n WriteInt(i0[1, 1, 1]); (* 8 *);\n i0 := j0;\n WriteInt(i0[1, 1, 1]); (* 9 *);\n P(a);\n P(b);\nEND Arrays2." }, { "path": "tests/base/Arrays2.txt", "content": " 2 8 9 3 3" }, { "path": "tests/base/Arrays3.Mod", "content": "MODULE Arrays3;\n TYPE ARR = ARRAY 3 OF INTEGER;\n ARR2 = ARRAY 3, 2 OF INTEGER;\n VAR\n x : ARRAY 3 OF INTEGER;\n y : ARR;\n i : ARRAY 3, 2 OF INTEGER;\n k0, m0 : ARRAY 0 OF INTEGER;\n k1, m1 : ARRAY 3, 0 OF INTEGER;\n PROCEDURE P1(VAR b, c : ARRAY OF INTEGER; d : ARRAY OF INTEGER);\n VAR y2 : ARR;\n (*y3 : ARRAY 0 OF INTEGER;\n y4 : ARRAY 1 OF INTEGER;*)\n BEGIN\n (* b := c; illegal assignment *)\n (* b := d; illegal assignment *)\n y2[1] := 0;\n y2 := b;\n WriteInt(y2[1]); (*88*)\n (* y3 := b; illegal assignment *)\n (*y4:= b; trap *)\n END P1;\n\n PROCEDURE P4(b : ARRAY OF ARRAY OF INTEGER);\n VAR k : INTEGER;\n BEGIN\n k := b[0][1];\n WriteInt(k) (*8*)\n END P4;\n\n PROCEDURE P3(VAR b : ARRAY OF ARRAY OF INTEGER);\n BEGIN b[0][1] := 8\n END P3;\n\n PROCEDURE P5(VAR b : ARR2);\n VAR c : ARRAY 3, 2 OF INTEGER;\n BEGIN\n c[0][1] := 9;\n b := c\n END P5;\n\nBEGIN\n y[1] := 88;\n P1(y, y, y);\n x[1] := 1;\n y[1] := 99;\n y := x;\n WriteInt(y[1]); (*1*)\n i[0][1] := 0;\n P3(i);\n WriteInt(i[0][1]); (*8*)\n P4(i);\n P5(i);\n WriteInt(i[0][1]); (*9*)\n k0 := m0;\n k1 := m1;\nEND Arrays3." }, { "path": "tests/base/Arrays3.txt", "content": " 88 1 8 8 9" }, { "path": "tests/base/BitFunc.Mod", "content": "MODULE BitFunc;\n VAR x: ARRAY 18 OF BYTE;\n i: INTEGER;\n ch: CHAR;\n\n PROCEDURE next(in: ARRAY OF BYTE; VAR i: INTEGER): CHAR;\n VAR x, size, b1, b2, b3: INTEGER;\n ch: CHAR;\n BEGIN\n ch := 0X;\n size := LEN(in);\n IF i < size THEN\n b1 := in[i];\n x := ASR(b1, 4);\n CASE x OF\n 0..7: (* 1 bytes format: 0xxxxxxx *)\n ch := CHR(b1); INC(i)\n | 12,13: (* 2 bytes format: 110xxxxx 10xxxxxx *)\n IF i+1 < size THEN\n INC(i);\n b2 := in[i];\n IF AND(b2, 0C0H) = 80H THEN\n ch := CHR(BOR(LSL(AND(b1, 1FH), 6), AND(b2, 3FH)))\n END;\n INC(i)\n END\n | 14: (* 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx *)\n IF i+2 < size THEN\n INC(i);\n b2 := in[i];\n INC(i);\n b3 := in[i];\n IF (AND(b2, 0C0H) = 80H) & (AND(b3, 0C0H) = 80H) THEN\n ch := CHR(BOR(LSL(AND(b1, 0FH), 12),\n BOR(LSL(AND(b2, 3FH), 6), AND(b3, 3FH))));\n END;\n INC(i)\n END\n | 8..11, 15: (* ERROR + 4 bytes format: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx *)\n ch := 0X\n END\n END\n RETURN ch\n END next;\n\nBEGIN\n x[0] := 041H;\n x[1] := 0D0H;\n x[2] := 094H;\n x[3] := 0D0H;\n x[4] := 0B0H;\n x[5] := 0E2H;\n x[6] := 082H;\n x[7] := 0ACH;\n x[8] := 0E4H;\n x[9] := 0B8H;\n x[10] := 096H;\n x[11] := 0E7H;\n x[12] := 095H;\n x[13] := 08CH;\n x[14] := 0F0H;\n x[15] := 000H;\n x[16] := 000H;\n x[17] := 000H;\n i := NOT(-1); (* 0 *)\n ch := next(x, i);\n WHILE ch # 0X DO\n WriteChar(ch);\n WriteInt(ORD(ch));\n WriteLn;\n ch := next(x, i)\n END\nEND BitFunc." }, { "path": "tests/base/BitFunc.txt", "content": "A 65\nД 1044\nа 1072\n€ 8364\n世 19990\n界 30028\n" }, { "path": "tests/base/CaseChar0.Mod", "content": "MODULE CaseChar0;\n CONST C = \"C\";\n VAR i, a : CHAR;\nBEGIN\n i := \"B\";\n CASE i OF\n \"A\"..\"C\", \"Z\":\n a := \"1\"; \n | \"I\".. \"K\":\n a := \"2\"; \n | \"W\":\n a := \"3\"; \n END;\n WriteChar(a); (* 1 *)\n CASE C OF\n 22X:\n i := \"4\"; \n | \"A\"..\"C\", \"Z\":\n i := \"5\"; \n END;\n WriteChar(i) (* 5 *)\nEND CaseChar0." }, { "path": "tests/base/CaseChar0.txt", "content": "15" }, { "path": "tests/base/CaseNum0.Mod", "content": "MODULE CaseNum0;\n VAR i, a : INTEGER;\n \n PROCEDURE P(i : INTEGER);\n VAR a : INTEGER;\n BEGIN\n CASE i OF\n 8..10, 14:\n a := 1; \n |2..4, 15..20, 25:\n a := 2; \n |5..6:\n a := 3; \n END;\n WriteInt(a)\n END P;\n\n PROCEDURE P1;\n VAR i: INTEGER;\n BEGIN\n i := 8;\n CASE i OF\n 0..255: WriteInt(8)\n END;\n i := 0;\n CASE i OF\n -255..0: WriteInt(9)\n END\n END P1;\n\n PROCEDURE P2;\n VAR i: INTEGER;\n BEGIN\n i := -1;\n CASE i OF\n -1: WriteInt(-1)\n | 0: WriteInt(0)\n | +1: WriteInt(1)\n END\n END P2;\n\nBEGIN\n i := 2;\n CASE i OF\n 8..10, 14:\n a := 1; \n |2..4, 15..20, 25:\n a := 2; \n |5..6:\n a := 3; \n END;\n WriteInt(a); (* 2 *)\n P(9); (* 1 *)\n P(4); (* 2 *)\n P(6); (* 3 *)\n P2; (* -1 *)\n P1 (* 8 9 *)\nEND CaseNum0." }, { "path": "tests/base/CaseNum0.txt", "content": " 2 1 2 3 -1 8 9" }, { "path": "tests/base/CaseNum1.Mod", "content": "MODULE CaseNum1;\n TYPE ARR = ARRAY 3 OF RECORD c: CHAR END;\n VAR b: ARR;\n\n PROCEDURE P(i: INTEGER);\n VAR a: INTEGER;\n BEGIN\n CASE i OF\n 8..10, 14:\n a := 1;\n |2..4, 15..20, 25:\n CASE i OF\n 3, 15..19:\n a := 2;\n |25:\n a := 3;\n END;\n |5..6:\n a := 4;\n END;\n WriteInt(a)\n END P;\n\n PROCEDURE NoLocals(i: INTEGER);\n BEGIN\n CASE i OF\n 5: WriteInt(i)\n END\n END NoLocals;\n\n PROCEDURE P2(i: ARR);\n BEGIN\n CASE i[2].c OF\n \"P\": WriteInt(ORD(i[2].c))\n END\n END P2;\n\n PROCEDURE P3(i: ARR);\n BEGIN\n CASE ORD(i[2].c) OF\n 80: WriteChar(i[2].c)\n END\n END P3;\n\nBEGIN\n P(9); (* 1 *)\n P(18); (* 2 *)\n P(25); (* 3 *)\n P(6); (* 4 *)\n NoLocals(5); (* 5 *)\n b[2].c := \"P\";\n P2(b); (* 80 *)\n P3(b) (* \"P\" *)\nEND CaseNum1.\n" }, { "path": "tests/base/CaseNum1.txt", "content": " 1 2 3 4 5 80P" }, { "path": "tests/base/CaseRecord0.Mod", "content": "MODULE CaseRecord0;\n TYPE\n R = RECORD a: INTEGER END ;\n R0 = RECORD (R) b: REAL END ;\n R1 = RECORD (R) b: INTEGER END ;\n R2 = RECORD (R) b: SET END ;\n P = POINTER TO R;\n P0 = POINTER TO R0;\n P1 = POINTER TO R1;\n P2 = POINTER TO R2;\n\n VAR p, old: P; p1 : P1; i : INTEGER;\n\n PROCEDURE VarPar(VAR p: P);\n VAR i : INTEGER;\n BEGIN\n CASE p OF\n P0: p.b := 2.5; i := 0 |\n P1: p.b := 8; i:= 8 |\n P2: p.b := {0, 2}; i:= 2\n END;\n WriteInt(i); (* 8 *)\n NEW(p);\n p.a := 9\n END VarPar;\n\n\nBEGIN\n NEW(p1); p := p1; p.a := 1;\n CASE p OF\n P0: p.b := 2.5; i := 0 |\n P1: p.b := p.a + p.b + p.b DIV 3; i:= p.a |\n P2: p.b := {0, 2}; i:= 2\n END;\n WriteInt(i); (* 1 *)\n old := p;\n VarPar(p);\n WriteInt(p.a); (* 9 *)\n IF old # p THEN WriteInt(10) END\nEND CaseRecord0.\n" }, { "path": "tests/base/CaseRecord0.txt", "content": " 1 8 9 10" }, { "path": "tests/base/CaseRecord1.Mod", "content": "MODULE CaseRecord1;\n TYPE \n R = RECORD a: INTEGER END ;\n R0 = RECORD (R) b: INTEGER END ;\n R1 = RECORD (R) b: REAL END ;\n R2 = RECORD (R) b: SET END ;\n\n VAR r1: R1; r : R; i : INTEGER;\n\n PROCEDURE P(VAR r : R);\n BEGIN\n CASE r OF\n R0: r.b := 10; i := 0 |\n R1: r.b := 2.5; i:= 1 |\n R2: r.b := {0, 2}; i:= 2\n END;\n WriteInt(i)\n END P;\n\nBEGIN\n P(r1);\n i := -1;\n P(r)\nEND CaseRecord1." }, { "path": "tests/base/CaseRecord1.txt", "content": " 1 -1" }, { "path": "tests/base/CaseRecord2.Mod", "content": "MODULE CaseRecord2;\n TYPE \n P = POINTER TO R;\n P0 = POINTER TO R0;\n P1 = POINTER TO R1;\n P2 = POINTER TO R2;\n R = RECORD a: INTEGER; next : P END ;\n R0 = RECORD (R) b: INTEGER; c : ARRAY 11 OF INTEGER END ;\n R1 = RECORD (R) b: REAL END ;\n R2 = RECORD (R) b: SET END ;\n \n VAR p: P; p0 : P0; p1 : P1; p2 : P2; i : INTEGER;\n \n PROCEDURE Run(p : P);\n VAR tmp : P;\n BEGIN\n CASE p OF\n P0: p.b := 10; p.c[p.b] := p.b; i := 0;\n tmp := p.next;\n CASE tmp OF\n P2: tmp.b := {3}; i := 1 \n END;\n | P1: p.b := 2.5; i:= 2;\n CASE p OF\n P1: p.b := 3.0; i := 3 \n END;\n | P2: p.b := {0, 2}; i:= 4\n END;\n WriteInt(i)\n END Run;\nBEGIN\n NEW(p1);\n p := p1;\n Run(p);\n NEW(p0);\n NEW(p2);\n p := p0;\n p.next := p2;\n Run(p);\nEND CaseRecord2." }, { "path": "tests/base/CaseRecord2.txt", "content": " 3 1" }, { "path": "tests/base/CaseRecord3.Mod", "content": "MODULE CaseRecord3;\n TYPE\n P = POINTER TO R;\n P0 = POINTER TO R0;\n P1 = POINTER TO R1;\n P2 = POINTER TO R2;\n R = RECORD a: INTEGER END ;\n R0 = RECORD (R) b: REAL; y: P0 END ;\n R1 = RECORD (R0) c: INTEGER END ;\n R2 = RECORD (R1) d: REAL; z: ARRAY 10 OF P1 END ;\n\n VAR p: P; p2 : P2; i : INTEGER;\nBEGIN\n NEW(p2); NEW(p2.z[2]); NEW(p2.z[3]);\n p2.d := 2.0;\n p2.c := 6;\n p2.z[2].b := 3.0;\n p2.a := 1;\n p2.z[3].c := 8;\n p2.y := p2.z[3];\n p := p2;\n CASE p OF\n P0: p.b := 1.5 + p(P2).d + p(P2).z[2].b + FLT(p.a) +\n FLT(p.y(P1).c) + FLT(p(P1).c DIV 3);\n WriteInt(FLOOR(p.b)); (* 17 *)\n i:= p.a |\n P2: p.b := 1.8; i:= 2\n END;\n WriteInt(i) (* 1 *)\nEND CaseRecord3.\n" }, { "path": "tests/base/CaseRecord3.txt", "content": " 17 1" }, { "path": "tests/base/CaseRecord4.Mod", "content": "MODULE CaseRecord4;\n TYPE\n A = POINTER TO ADesc;\n ADesc = RECORD\n next: A\n END;\n\n B = POINTER TO RECORD(ADesc)\n value: INTEGER\n END;\n\n VAR x: B;\n fn: PROCEDURE(z: A);\n\n PROCEDURE CaseGuardOnParam(a: A);\n BEGIN\n IF a # NIL THEN\n CASE a OF\n B:\n WriteChar(\"B\"); WriteLn;\n (* BUG-FIX: here 'a' has type B thanks to the implicit type guard:\n so 'a.next' is equivalent to 'a(B).next'. The 'next' field has type\n A and the formal parameter 'a' must be treated as of type A while\n we type check the function call to CaseGuardOnParam *)\n CaseGuardOnParam(a.next);\n (* BUG-FIX: In the signature of CaseGuardOnParam, 'a' must have type\n A, regardless of implicit type guards. Only when 'a' appears in\n expressions we can assume it has type 'B' *)\n fn := CaseGuardOnParam\n END\n END\n END CaseGuardOnParam;\n\nBEGIN\n NEW(x); x.next := NIL;\n CaseGuardOnParam(x)\nEND CaseRecord4.\n" }, { "path": "tests/base/CaseRecord4.txt", "content": "B\n" }, { "path": "tests/base/CommutativeSwap.Mod", "content": "MODULE CommutativeSwap;\n VAR i : INTEGER; a : ARRAY 10 OF INTEGER;\nBEGIN\n i := 5;\n a[i+3] := 5;\n WriteInt(1 - i + 3 * i); (* 11 *)\n WriteInt(2 - a[i+3]); (* -3 *)\nEND CommutativeSwap." }, { "path": "tests/base/CommutativeSwap.txt", "content": " 11 -3" }, { "path": "tests/base/ConstantFoldingAndLoadOp.Mod", "content": "MODULE ConstantFoldingAndLoadOp;\n CONST con = 100;\n TYPE\n V = RECORD\n x : ARRAY 10 OF INTEGER;\n END;\n VAR\n i,j : INTEGER;\n c : ARRAY 2 OF INTEGER;\n d : V;\n e : ARRAY 2 OF BOOLEAN;\n b : BOOLEAN;\n\n PROCEDURE PrintBool(x : BOOLEAN);\n BEGIN IF x THEN WriteInt(1) ELSE WriteInt(0) END;\n END PrintBool;\nBEGIN\n j := 2;\n c[0] := 3;\n d.x[0] := 4;\n e[0] := TRUE;\n i := 2 * 3 + 10 DIV 2;\n WriteInt(i);\n i := 2*c[0];\n WriteInt(i);\n i := 2*d.x[0];\n WriteInt(i);\n i := 2*con;\n WriteInt(i);\n i := j*c[0];\n WriteInt(i);\n i := j*d.x[0];\n WriteInt(i);\n i := j*con;\n WriteInt(i);\n WriteLn;\n i := c[0] - 2;\n WriteInt(i);\n i := d.x[0] - 2;\n WriteInt(i);\n i := con - 2;\n WriteInt(i);\n i := c[0] - j;\n WriteInt(i);\n i := d.x[0] - j;\n WriteInt(i);\n i := con - j;\n WriteInt(i);\n i := con + 0;\n WriteInt(i);\n i := con - 0;\n WriteInt(i);\n WriteLn;\n b := TRUE & e[0];\n PrintBool(b);\n b := b & e[0];\n PrintBool(b);\n b := e[0] & TRUE;\n PrintBool(b);\n b := e[0] & b;\n PrintBool(b);\n b := (TRUE & e[0]) OR e[0];\n PrintBool(b);\n b := TRUE OR TRUE;\n PrintBool(b);\nEND ConstantFoldingAndLoadOp." }, { "path": "tests/base/ConstantFoldingAndLoadOp.txt", "content": " 11 6 8 200 6 8 200\n 1 2 98 1 2 98 100 100\n 1 1 1 1 1 1" }, { "path": "tests/base/DivMul.Mod", "content": "MODULE DivMul;\n CONST eight = 8;\n\n PROCEDURE PrintDiv(a,b : INTEGER);\n BEGIN\n WriteInt(a);\n WriteInt(b);\n WriteInt(a DIV b);\n WriteInt(a MOD b);\n WriteLn\n END PrintDiv;\n \n PROCEDURE Division; \n VAR x,y : INTEGER;\n a : ARRAY 2 OF INTEGER;\n BEGIN\n PrintDiv(8, 3);\n PrintDiv(8, -3);\n PrintDiv(-8, 3);\n PrintDiv(-8, -3);\n PrintDiv(1, 2);\n PrintDiv(1, -2);\n PrintDiv(-1, 2);\n PrintDiv(-1, -2);\n WriteInt(10 DIV 8);\n WriteInt(10 MOD eight);\n WriteLn;\n x := 8;\n WriteInt(10 DIV x);\n WriteInt(10 MOD x);\n x := 10;\n WriteInt(x DIV 8);\n WriteInt(x MOD eight);\n y := 8;\n WriteInt(x DIV y);\n WriteInt(x MOD y);\n WriteLn;\n a[0] := 8;\n WriteInt(10 DIV a[0]);\n WriteInt(10 MOD a[0]);\n a[0] := 10;\n WriteInt(a[0] DIV 8);\n WriteInt(a[0] MOD eight);\n a[1] := 8;\n WriteInt(a[0] DIV a[1]);\n WriteInt(a[0] MOD a[1]);\n END Division;\n \n PROCEDURE Multiplication; \n TYPE V = RECORD x : INTEGER END;\n VAR x,y : INTEGER;\n a : ARRAY 2 OF INTEGER;\n b : V;\n BEGIN\n WriteInt(4 * 8);\n WriteInt(4 * eight);\n WriteLn;\n x := 8;\n b.x := 8;\n WriteInt(4 * x);\n WriteInt(4 * b.x);\n x := 4;\n b.x := 4;\n WriteInt(x * 8);\n WriteInt(b.x * eight);\n y := 8;\n WriteInt(x * y);\n WriteInt(y * b.x);\n WriteLn;\n a[0] := 8;\n WriteInt(4 * a[0]);\n WriteInt(b.x * a[0]);\n a[0] := 4;\n b.x := 8;\n WriteInt(a[0] * 8);\n WriteInt(a[0] * b.x);\n a[1] := 8;\n WriteInt(a[0] * a[1]);\n END Multiplication;\nBEGIN\n Division;\n WriteLn;\n Multiplication\nEND DivMul." }, { "path": "tests/base/DivMul.txt", "content": " 8 3 2 2\n 8 -3 -2 2\n -8 3 -3 1\n -8 -3 3 1\n 1 2 0 1\n 1 -2 0 1\n -1 2 -1 1\n -1 -2 1 1\n 1 2\n 1 2 1 2 1 2\n 1 2 1 2 1 2\n 32 32\n 32 32 32 32 32 32\n 32 32 32 32 32" }, { "path": "tests/base/EmptyArrayAndRecord.Mod", "content": "MODULE EmptyArrayAndRecord;\n TYPE\n EMPTY0 = RECORD END;\n EMPTY2 = RECORD e : RECORD END END;\n EMPTY3 = RECORD e : ARRAY 0 OF INTEGER END;\n EMPTY4 = RECORD e : ARRAY 0, 2 OF EMPTY0 END;\n EMPTY5 = RECORD e : ARRAY 2, 0 OF EMPTY0 END;\n EMPTY6 = RECORD i : INTEGER; e : ARRAY 2, 0 OF EMPTY0 END;\n AEMPTY = ARRAY 0 OF INTEGER;\n AEMPTY2 = ARRAY 0, 2 OF INTEGER;\n AEMPTY3 = ARRAY 0, 2 OF EMPTY0;\n AEMPTY4 = ARRAY 2, 0 OF EMPTY0;\n VAR \n empty0, empty1 : EMPTY0;\n empty2, empty3 : EMPTY2;\n empty4, empty5 : EMPTY3;\n empty6, empty7 : EMPTY4;\n empty8, empty9 : EMPTY5;\n empty10, empty11 : EMPTY6;\n aempty0, aempty1 : AEMPTY;\n aempty2, aempty3 : AEMPTY2;\n aempty4, aempty5 : AEMPTY3;\n aempty6, aempty7 : AEMPTY4;\n x, y : ARRAY 1 OF EMPTY0;\n y0, y1 : ARRAY 2, 0 OF EMPTY0;\n y2, y3 : ARRAY 3 OF RECORD i : INTEGER; j : ARRAY 0 OF EMPTY0; END;\n e : EMPTY0;\n i : INTEGER;\nBEGIN \n empty0 := empty1;\n empty2 := empty3;\n empty4 := empty5;\n empty6 := empty7;\n empty8 := empty9;\n empty10 := empty11;\n aempty0 := aempty1;\n aempty2 := aempty3;\n aempty4 := aempty5;\n aempty6 := aempty7;\n x := y;\n x[i] := e;\n y0 := y1;\n y2[i].j := y3[i].j;\n i := 10;\n WriteInt(i);\nEND EmptyArrayAndRecord." }, { "path": "tests/base/EmptyArrayAndRecord.txt", "content": " 10" }, { "path": "tests/base/ExtTypes.Mod", "content": "MODULE ExtTypes;\n TYPE\n pR0* = POINTER TO R0;\n pR1* = POINTER TO R1;\n R0 = RECORD x: INTEGER END;\n R1 = RECORD(R0) y*: INTEGER END;\nEND ExtTypes." }, { "path": "tests/base/ForwardPointerRef.Mod", "content": "MODULE ForwardPointerRef;\n TYPE\n P0 = POINTER TO R0;\n R0 = RECORD i: INTEGER END;\n\n R1 = RECORD\n j: INTEGER;\n dsc: POINTER TO R1;\n next: POINTER TO R2\n END;\n\n P2 = POINTER TO R2;\n R2 = RECORD c: CHAR END;\n\n VAR\n p0: P0;\n pa: POINTER TO R1;\n pb: P2;\n\nBEGIN\n NEW(p0);\n p0.i := 3;\n WriteInt(p0.i); (* 3 *)\n\n NEW(pa);\n pa.j := 4;\n WriteInt(pa.j); (* 4 *)\n pa.dsc := pa;\n WriteInt(pa.dsc.j); (* 4 *)\n\n NEW(pb);\n pb.c := \"C\";\n pa.next := pb;\n WriteChar(pa.next.c); (* C *)\n WriteLn;\nEND ForwardPointerRef." }, { "path": "tests/base/ForwardPointerRef.txt", "content": " 3 4 4C\n" }, { "path": "tests/base/Fractions.Mod", "content": "MODULE Fractions; (*NW 10.10.07; Tabulate fractions 1/n*)\n CONST Base = 10; N = 32;\n \n PROCEDURE Go;\n VAR i, j, m, n, r: INTEGER;\n d: ARRAY N OF INTEGER; (*digits*)\n x: ARRAY N OF INTEGER; (*index*)\n BEGIN n := ReadInt(); i := 2;\n WHILE i <= n DO j := 0;\n WHILE j < i DO x[j] := 0; j := j+1 END ;\n m := 0; r := 1;\n WHILE x[r] = 0 DO\n x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; m := m+1\n END ;\n WriteInt(i); WriteChar(CHR(9)); WriteChar(\".\"); j := 0;\n WHILE j < x[r] DO WriteChar(CHR(d[j] + 48)); j := j+1 END ;\n WriteChar(\"'\");\n WHILE j < m DO WriteChar(CHR(d[j] + 48)); j := j+1 END ;\n WriteLn; i := i+1\n END\n END Go;\n\nBEGIN Go\nEND Fractions." }, { "path": "tests/base/Fractions.txt", "content": " 2\t.5'0\n 3\t.3'3\n 4\t.25'0\n 5\t.2'0\n 6\t.1'6\n 7\t.1'428571\n 8\t.125'0\n 9\t.1'1\n 10\t.1'0\n 11\t.0'90\n 12\t.08'3\n 13\t.0'769230\n 14\t.0'714285\n 15\t.0'6\n 16\t.0625'0\n 17\t.0'5882352941176470\n 18\t.0'5\n 19\t.0'526315789473684210\n 20\t.05'0\n" }, { "path": "tests/base/FragileBaseClass.Mod", "content": "MODULE FragileBaseClass;\n TYPE\n List = POINTER TO ListDesc;\n Node = POINTER TO NodeDesc;\n List2 = POINTER TO List2Desc;\n ListDesc = RECORD\n head: Node;\n add: PROCEDURE(l: List; i: INTEGER);\n addAll: PROCEDURE(l: List; i: ARRAY OF INTEGER);\n size: PROCEDURE(s: List): INTEGER;\n END;\n List2Desc = RECORD(ListDesc)\n count: INTEGER;\n END;\n NodeDesc = RECORD\n x: INTEGER;\n next: Node;\n END;\n VAR\n l: List;\n arr: ARRAY 2 OF INTEGER;\n\n PROCEDURE addList(l: List; i: INTEGER);\n VAR n: Node;\n BEGIN\n NEW(n);\n n.x := i;\n n.next := l.head;\n l.head := n;\n END addList;\n\n PROCEDURE addList2(l: List; i: INTEGER);\n BEGIN\n addList(l, i);\n INC(l(List2).count)\n END addList2;\n\n\n (*\n First version, the base class implements addAll without using the add\n method. This works fine.\n *)\n PROCEDURE addAllListA(l: List; i: ARRAY OF INTEGER);\n VAR j: INTEGER;\n n: Node;\n BEGIN\n FOR j := 0 TO LEN(i)-1 DO\n NEW(n);\n n.x := i[j];\n n.next := l.head;\n l.head := n\n END\n END addAllListA;\n\n (*\n Second version, the base class implements addAll by calling \"add\" in a loop.\n This works fine and does not break the subclass because \"add\" is called as\n a static invocation to addList. This is not possible in Java that resolves\n \"add\" dynamically.\n *)\n PROCEDURE addAllListB(l: List; i: ARRAY OF INTEGER);\n VAR j: INTEGER;\n BEGIN\n FOR j := 0 TO LEN(i)-1 DO\n addList(l, i[j])\n END\n END addAllListB;\n\n (*\n Third version, the base class implements addAll by calling \"add\" in a loop.\n This manifest the fragile base class problem. This is similar to Java normal\n dynamic dispatch of the method call \"add\": l.add(l, i[j]) will invoke\n addList2 that will invoke addList and so increment the count twice per\n element of the array i.\n *)\n PROCEDURE addAllListC(l: List; i: ARRAY OF INTEGER);\n VAR j: INTEGER;\n BEGIN\n FOR j := 0 TO LEN(i)-1 DO\n l.add(l, i[j])\n END\n END addAllListC;\n\n PROCEDURE addAllList2A(l: List; i: ARRAY OF INTEGER);\n VAR len: INTEGER;\n BEGIN\n addAllListA(l, i);\n len := LEN(i);\n INC(l(List2).count, len)\n END addAllList2A;\n\n PROCEDURE addAllList2B(l: List; i: ARRAY OF INTEGER);\n VAR len: INTEGER;\n BEGIN\n addAllListB(l, i);\n len := LEN(i);\n INC(l(List2).count, len)\n END addAllList2B;\n\n PROCEDURE addAllList2C(l: List; i: ARRAY OF INTEGER);\n VAR len: INTEGER;\n BEGIN\n addAllListC(l, i);\n len := LEN(i);\n INC(l(List2).count, len)\n END addAllList2C;\n\n PROCEDURE sizeList(l: List) :INTEGER;\n VAR\n size: INTEGER;\n tmp: Node;\n BEGIN\n size := 0;\n tmp := l.head;\n WHILE(tmp # NIL) DO INC(size); tmp := tmp.next END;\n RETURN size\n END sizeList;\n\n PROCEDURE sizeList2(l: List) :INTEGER;\n RETURN l(List2).count\n END sizeList2;\n\n PROCEDURE newList2(addAll: PROCEDURE(l: List; i: ARRAY OF INTEGER)): List2;\n VAR l: List2;\n BEGIN\n NEW(l);\n l.head := NIL;\n l.add := addList2;\n l.addAll := addAll;\n l.size := sizeList2;\n RETURN l\n END newList2;\nBEGIN\n arr[0] := 8; arr[1] := 9;\n l := newList2(addAllList2A);\n l.addAll(l, arr);\n WriteInt(l.size(l));\n\n l := newList2(addAllList2B);\n l.addAll(l, arr);\n WriteInt(l.size(l));\n\n l := newList2(addAllList2C);\n l.addAll(l, arr);\n WriteInt(l.size(l))\nEND FragileBaseClass." }, { "path": "tests/base/FragileBaseClass.txt", "content": " 2 2 4" }, { "path": "tests/base/MagicSquares.Mod", "content": "MODULE MagicSquares; (*for Oberon-0 NW 25.1.2013*)\n\n PROCEDURE Generate; (*magic square of order 3, 5, 7, ... *)\n VAR i, j, x, nx, nsq, n: INTEGER;\n M: ARRAY 13 OF ARRAY 13 OF INTEGER;\n BEGIN n := ReadInt();\n nsq := n*n; x := 0;\n i := n DIV 2; j := n-1;\n WHILE x < nsq DO\n nx := n + x; j := (j-1) MOD n; x := x+1; M[i][j] := x;\n WHILE x < nx DO\n i := (i+1) MOD n; j := (j+1) MOD n;\n x := x+1; M[i][j] := x\n END\n END ;\n i := 0;\n REPEAT j := 0;\n REPEAT WriteInt(M[i][j]); j := j+1 UNTIL j = n;\n WriteLn; i := i+1\n UNTIL i = n\n END Generate;\n\nBEGIN Generate\nEND MagicSquares." }, { "path": "tests/base/MagicSquares.txt", "content": " 3 8 4\n 5 1 9\n 7 6 2\n" }, { "path": "tests/base/OpenArrays.Mod", "content": "MODULE OpenArrays;\n VAR x : ARRAY 1 OF INTEGER;\n y : ARRAY 2 OF INTEGER;\n\n PROCEDURE P2(a : ARRAY OF INTEGER; VAR b : ARRAY OF INTEGER);\n VAR k : INTEGER;\n BEGIN\n WriteInt(b[0]); (* 1 *) \n (* a[0] := 1; read only*)\n (* a[3] := 2; read only*)\n b[0] := 2;\n (* b[3] := 2; TRAP *) \n k := a[0];\n (* k := a[3]; TRAP *) \n k := b[0];\n WriteInt(k); (* 2 *) \n (* k := b[3]; TRAP *)\n END P2;\n\n PROCEDURE P1(a : ARRAY OF INTEGER; VAR b : ARRAY OF INTEGER);\n VAR k : INTEGER;\n BEGIN\n (* a[0] := 1; read only*)\n (* a[3] := 2; read only*)\n b[0] := 1;\n (* b[3] := 2; TRAP *) \n k := a[0];\n (* k := a[3]; TRAP *) \n k := b[0];\n (* k := b[3]; TRAP *)\n P2(a, b) \n END P1;\nBEGIN \n P1(x, y);\n WriteInt(y[0]); (* 2 *) \nEND OpenArrays." }, { "path": "tests/base/OpenArrays.txt", "content": " 1 2 2" }, { "path": "tests/base/OpenArrays2.Mod", "content": "MODULE OpenArrays2;\n TYPE ARR = ARRAY 3 OF INTEGER;\n VAR\n x : ARR;\n i : INTEGER;\n \n PROCEDURE P1(VAR b : ARRAY OF INTEGER; c : ARR; VAR d : ARR; e : ARRAY OF INTEGER);\n BEGIN\n WriteInt(b[i]);\n WriteInt(c[i]);\n WriteInt(d[i]);\n WriteInt(e[i])\n END P1; \n\nBEGIN\n i := 1;\n x[i] := 8;\n P1(x, x, x, x)\nEND OpenArrays2.\n" }, { "path": "tests/base/OpenArrays2.txt", "content": " 8 8 8 8" }, { "path": "tests/base/OpenArrays3.Mod", "content": "MODULE OpenArrays3;\n TYPE ARR = ARRAY 3 OF INTEGER;\n R = RECORD i : INTEGER END;\n VAR\n d : ARRAY 10 OF INTEGER;\n x : ARRAY 3 OF INTEGER;\n e : ARRAY 10 OF R;\n y : ARRAY 3 OF R;\n f : ARRAY 10 OF ARRAY 3 OF INTEGER;\n z : ARRAY 3 OF ARR;\n \n PROCEDURE P0(VAR a : ARRAY OF INTEGER; b : ARRAY OF R; c : ARRAY OF ARR);\n BEGIN\n d := a;\n WriteInt(d[1]);\n e := b;\n WriteInt(e[1].i);\n f := c;\n WriteInt(f[1][1])\n END P0; \n \n PROCEDURE P1(VAR a : ARRAY OF INTEGER; b : ARRAY OF R; c : ARRAY OF ARR);\n VAR\n d : ARRAY 10 OF INTEGER;\n e : ARRAY 10 OF R;\n f : ARRAY 10 OF ARR;\n BEGIN\n d[1] := -1; e[1].i := -1; f[1][1] := -1;\n d := a;\n WriteInt(d[1]);\n e := b;\n WriteInt(e[1].i);\n f := c;\n WriteInt(f[1][1])\n END P1; \n\nBEGIN\n d[1] := -1; x[1] := 1;\n e[1].i := -1; y[1].i := 2;\n f[1][1] := -1; z[1][1] := 3;\n P0(x, y, z);\n WriteLn;\n x[1] := 4;\n y[1].i := 5;\n z[1][1] := 6;\n P1(x, y, z)\nEND OpenArrays3." }, { "path": "tests/base/OpenArrays3.txt", "content": " 1 2 3\n 4 5 6" }, { "path": "tests/base/Out0.Mod", "content": "MODULE Out0;\n CONST con = 100;\n TYPE\n V = RECORD x : ARRAY 10 OF INTEGER END;\n Hello = RECORD world : INTEGER; x : ARRAY 3 OF ARRAY 10 OF V; END;\n int = INTEGER;\n ARR = ARRAY 9 OF int;\n ARR2 = ARRAY 9 OF V;\n VAR\n a : ARRAY 4 OF INTEGER;\n b : ARRAY 3 OF ARRAY 5 OF INTEGER;\n c : ARRAY 1 OF ARRAY 2 OF ARRAY 3 OF ARRAY 4 OF INTEGER;\n d : V;\n e : Hello;\n f : int;\n g : ARR;\n h : ARR2;\n z : RECORD y : int END;\n i, j : INTEGER;\n k : BOOLEAN;\n\nBEGIN\n a[2] := 8;\n WriteInt(a[2]);\n b[2][3] := 9;\n WriteInt(b[2][3]);\n c[0][1][2][3] := 10;\n WriteInt(c[0][1][2][3]);\n d.x[9] := 11;\n WriteInt(d.x[9]);\n e.world := 12;\n WriteInt(e.world);\n e.x[2][3].x[3] := 13;\n WriteInt(e.x[2][3].x[3]);\n f := 14;\n WriteInt(f);\n g[6] := 15;\n WriteInt(g[6]);\n h[8].x[2] := 16;\n WriteInt(h[8].x[2]);\n z.y := 17;\n WriteInt(z.y);\n i := -z.y + c[0][1][2][3] + h[8].x[2] * e.x[2][3].x[3] -1;\n WriteInt(i);\n j := 2;\n k := (i = j) OR (i >= j);\n IF k THEN WriteInt(1) END\nEND Out0." }, { "path": "tests/base/Out0.txt", "content": " 8 9 10 11 12 13 14 15 16 17 200 1" }, { "path": "tests/base/Out1.Mod", "content": "MODULE Out1;\n CONST con = 100;\n VAR \n a : ARRAY 4 OF INTEGER;\n b : ARRAY 3 OF ARRAY 5 OF INTEGER;\n c : ARRAY 4 OF INTEGER;\n i, j : INTEGER;\n\nBEGIN \n i := 1;\n j := 2;\n a[j] := 1;\n WriteInt(a[j]);\n a[2] := 2;\n WriteInt(a[2]);\n a[i+j] := 3;\n WriteInt(a[i+j]);\n b[i][j] := 4;\n WriteInt(b[i][j]);\n b[2][4] := 5;\n WriteInt(b[2][4]);\n a[a[i]] := 6;\n WriteInt(a[a[i]]);\n a[c[i]] := 7;\n WriteInt(a[c[i]]);\nEND Out1." }, { "path": "tests/base/Out1.txt", "content": " 1 2 3 4 5 6 7" }, { "path": "tests/base/Out2.Mod", "content": "MODULE Out2;\n CONST con = 100;\n TYPE \n R0 = RECORD x, y : INTEGER END; \n R1 = RECORD u : INTEGER; \n v : ARRAY 4 OF R0; \n v2 : ARRAY 4 OF ARRAY 6 OF R0; \n w : INTEGER; \n r0 : R0 \n END; \n R2 = RECORD r1 : R1 END; \n VAR \n i, j: INTEGER;\n s : ARRAY 2 OF R1;\n a : R0;\n b : R2;\n\nBEGIN \n a.x := 10;\n WriteInt(a.x);\n b.r1.r0.x := 11;\n WriteInt(b.r1.r0.x);\n i := 1;\n j := 2;\n s[i].u := 12;\n WriteInt(s[i].u);\n s[1].w := 13;\n WriteInt(s[1].w);\n s[i].v[j].x := 14;\n WriteInt(s[i].v[j].x);\n s[1].v[2].x := 15;\n WriteInt(s[1].v[2].x);\n s[0].v[i].y := 16;\n WriteInt(s[0].v[i].y);\n s[0].r0.y := 17;\n WriteInt(s[0].r0.y);\n s[0].v2[i][j].y := 18;\n WriteInt(s[0].v2[i][j].y);\nEND Out2." }, { "path": "tests/base/Out2.txt", "content": " 10 11 12 13 14 15 16 17 18" }, { "path": "tests/base/Out3.Mod", "content": "MODULE Out3;\n CONST con = 100;\n VAR \n i, j, k : INTEGER;\n o, x : BOOLEAN;\n PROCEDURE gdc(m, n : INTEGER) : INTEGER;\n BEGIN\n WHILE m > n DO m := m - n\n ELSIF n > m DO n := n - m\n END;\n RETURN m\n END gdc;\nBEGIN \n i := 5;\n j := 5;\n IF i > j THEN \n k := 1;\n WriteInt(k)\n ELSIF i = j THEN\n k := 2;\n WriteInt(k);\n o := TRUE;\n IF k >= 1 THEN\n WHILE (i # j) OR o & (k < 4) DO \n k := k + 1;\n WriteInt(k)\n END\n END\n ELSE\n k := 3;\n WriteInt(k)\n END;\n WHILE (i # j) OR o & (k <= 4) DO \n k := k + 1;\n WriteInt(k)\n END;\n REPEAT \n i := i + 1;\n WriteInt(i)\n UNTIL (( i = 6) & o) OR ((j = 6) OR ~o);\n IF i > 0 THEN WriteInt(7) END;\n i := +12; x := TRUE;\n o := (8 > 3) & x & (i IN {0..13});\n IF o THEN WriteInt(8) END;\n i := 8;\n WriteLn;\n REPEAT \n i := i + 1;\n WriteInt(i)\n UNTIL ( (i = 15) OR (j = 10) & ~o) & ((j # 6) OR ~o);\n WriteInt(gdc(8, 12))\nEND Out3." }, { "path": "tests/base/Out3.txt", "content": " 2 3 4 5 6 7 8\n 9 10 11 12 13 14 15 4" }, { "path": "tests/base/Out4.Mod", "content": "MODULE Out4;\n TYPE\n R0 = RECORD x, y : INTEGER END;\n R1 = RECORD r0 : R0 END;\n R8 = RECORD x : ARRAY 2 OF INTEGER END;\n R9 = ARRAY 3 OF INTEGER;\n R11 = RECORD v : ARRAY 4 OF R0 END;\n ARR = ARRAY 2 OF R11;\n VAR\n i : INTEGER;\n\n PROCEDURE P0();\n VAR\n a : R8;\n b : R9;\n j : INTEGER;\n r1 : R1;\n s : ARR;\n PROCEDURE P1(o : BOOLEAN ; VAR z0, z2, z3 : INTEGER; VAR z1 : R9; VAR s : ARR);\n BEGIN\n o := TRUE;\n z0 := 20;\n z1[2] := 23;\n z2 := 21;\n z3 := 22;\n z0 := s[i].v[3].x + 6;\n s[i].v[3].x := z0 + 4;\n END P1;\n BEGIN\n i := 1;\n j := 10;\n WriteInt(j);\n a.x[1] := 11;\n WriteInt(a.x[1]);\n r1.r0.x := 12;\n WriteInt(r1.r0.x);\n b[2] := 13;\n WriteInt(b[2]);\n s[i].v[3].x := 14;\n WriteInt(s[i].v[3].x);\n P1(TRUE, j, a.x[1], r1.r0.x, b, s);\n WriteInt(j);\n WriteInt(a.x[1]);\n WriteInt(r1.r0.x);\n WriteInt(b[2]);\n WriteInt(s[i].v[3].x)\n END P0;\n\n PROCEDURE P9(o : BOOLEAN ; VAR z0 : INTEGER);\n BEGIN\n o := FALSE;\n z0 := z0 + 1;\n IF z0 # 4 THEN P9(o, z0) END\n END P9;\n PROCEDURE P10(VAR z0 : INTEGER);\n BEGIN\n z0 := z0 + 10\n END P10;\n\n PROCEDURE P8();\n VAR\n a, i, j : INTEGER;\n s : ARR;\n BEGIN\n a := 1;\n WriteInt(a);\n P9(TRUE, a);\n WriteInt(a);\n i := 1; j := 1;\n s[i*1].v[j-1].x := 90;\n P10(s[i*1].v[j-1].x);\n WriteInt(s[i*1].v[j-1].x)\n END P8;\nBEGIN\n P8(); P0()\nEND Out4." }, { "path": "tests/base/Out4.txt", "content": " 1 4 100 10 11 12 13 14 20 21 22 23 24" }, { "path": "tests/base/Out5.Mod", "content": "MODULE Out5;\n TYPE A = RECORD x : INTEGER END;\n VAR i: INTEGER;\n v : ARRAY 20 OF INTEGER;\n a : A;\nBEGIN \n i := 1;\n v[i] := 10;\n WriteInt(v[i]);\n i := v[i] + 1; \n WriteInt(i);\n v[i] := i + 1; \n WriteInt(v[i]);\n i := v[i] + v[i] - 4; \n WriteInt(i);\n a.x := 21;\n WriteInt(a.x);\n i := a.x + 1; \n WriteInt(i);\n a.x := i + 1; \n WriteInt(a.x);\n i := a.x + a.x - 22; \n WriteInt(i);\nEND Out5." }, { "path": "tests/base/Out5.txt", "content": " 10 11 12 20 21 22 23 24" }, { "path": "tests/base/Out6.Mod", "content": "MODULE Out6;\n TYPE \n R0 = RECORD x : INTEGER END; \n R1 = RECORD\n r0 : RECORD x : INTEGER END \n END; \n R2 = RECORD\n r0 : RECORD \n x : RECORD \n y : R0 \n END \n END \n END; \n VAR \n a : R0;\n b : R1;\n c : R2;\nBEGIN \n a.x := 10;\n WriteInt(a.x + a.x);\n b.r0.x := 11;\n WriteInt(b.r0.x + b.r0.x);\n c.r0.x.y.x := 12;\n WriteInt(c.r0.x.y.x + c.r0.x.y.x);\nEND Out6." }, { "path": "tests/base/Out6.txt", "content": " 20 22 24" }, { "path": "tests/base/OutTest.Mod", "content": "MODULE OutTest;\n IMPORT Out;\n VAR str: ARRAY 3 OF CHAR;\nBEGIN\n Out.Int(10, 0); Out.Ln;\n Out.String(\"Hello\");\n Out.Ln;\n\n str[0] := \"A\";\n str[1] := \"B\";\n str[2] := \"C\";\n Out.String(str);\n Out.Ln;\n\n str[0] := \"A\";\n str[1] := \"B\";\n str[2] := 0X;\n Out.String(str);\n Out.Ln;\n\n str[0] := \"A\";\n str[1] := 0X;\n str[2] := \"C\";\n Out.String(str);\n Out.Ln;\n\n str[0] := 0X;\n str[1] := \"B\";\n str[2] := \"C\";\n Out.String(str);\nEND OutTest.\n" }, { "path": "tests/base/OutTest.txt", "content": "10\nHello\nABC\nAB\nA\n" }, { "path": "tests/base/Pattern1.Mod", "content": "MODULE Pattern1;\nIMPORT SYSTEM;\n VAR ch: CHAR;\n k,j: INTEGER;\n x: REAL;\n s: SET;\nBEGIN\n ch := \"0\";\n WriteInt(ORD(ch));\n k := 10;\n WriteInt(k);\n k := -65536;\n WriteInt(k);\n k := -65537;\n WriteInt(k);\n k := 65535;\n WriteInt(k);\n k := 65536;\n WriteInt(k);\n k := 65537;\n WriteInt(k);\n x := 1.0;\n WriteReal(x);\n s := {0, 4, 8};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n s := {3..5};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n k := 5;\n s := {3..k};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n k := 18;\n s := {16..k};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n k := 3;\n s := {k..5};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n k := 3;\n s := {k..15};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n j := 5;\n s := {k..j};\n WriteInt(SYSTEM.VAL(INTEGER, s));\nEND Pattern1." }, { "path": "tests/base/Pattern1.txt", "content": " 48 10 -65536 -65537 65535 65536 65537 1.000000 273 56 56 458752 56 65528 56" }, { "path": "tests/base/Pattern2a.Mod", "content": "MODULE Pattern2a;\n VAR i, j, k, n: INTEGER;\n x, y: REAL;\nBEGIN\n i := 1+7;\n WriteInt(i);\n j := 7;\n i := 1+j;\n WriteInt(i);\n k := 1;\n i := j+k;\n WriteInt(i);\n i := j+1;\n WriteInt(i);\n i := j+0;\n WriteInt(i);\n i := 0+j;\n WriteInt(i);\n i := 1-7;\n WriteInt(i);\n j := 7;\n i := 1-j;\n WriteInt(i);\n i := j-1;\n WriteInt(i);\n i := j-0;\n WriteInt(i);\n i := 0-j;\n WriteInt(i);\n i := j-k;\n WriteInt(i);\n i := 3*7;\n WriteInt(i);\n j := 7;\n i := 3*j;\n WriteInt(i);\n i := j*3;\n WriteInt(i);\n i := 16*j;\n WriteInt(i);\n i := j*16;\n WriteInt(i);\n k := 3;\n i := k*j;\n WriteInt(i);\n i := 8 DIV 3;\n WriteInt(i);\n j := 8;\n i := j DIV 3;\n WriteInt(i);\n i := j DIV 4;\n WriteInt(i);\n k := 4;\n i := j DIV k;\n WriteInt(i); i := (-5) DIV 3;\n WriteInt(i);\n j := -5;\n i := j DIV 3;\n WriteInt(i);\n i := j DIV 4;\n WriteInt(i);\n k := 4;\n i := j DIV k;\n WriteInt(i); i := 8 MOD 3;\n WriteInt(i);\n j := 8;\n i := j MOD 3;\n WriteInt(i);\n i := j MOD 4;\n WriteInt(i);\n k := 4;\n i := j MOD k;\n WriteInt(i);\n i := (-5) MOD 3;\n WriteInt(i);\n j := -5;\n i := j MOD 3;\n WriteInt(i);\n i := j MOD 4;\n WriteInt(i);\n k := 4;\n i := j MOD k;\n WriteInt(i); j := 65539;\n i := j MOD 65536;\n WriteInt(i);\n j := 131075;\n i := j MOD 131072;\n WriteInt(i); i := 8;\n i := (i + 1) * (i - 1);\n WriteInt(i);\n k := 20;\n k := k DIV 17;\n WriteInt(k);\n n := 3;\n k := 8*n;\n WriteInt(k);\n k := n DIV 2;\n WriteInt(k);\n k := n MOD 16;\n WriteInt(k);\n y := 10.0;\n x := 6.0;\n x := -y / (x - 1.0);\n WriteReal(x);\nEND Pattern2a." }, { "path": "tests/base/Pattern2a.txt", "content": " 8 8 8 8 7 7 -6 -6 6 7 -7 6 21 21 21 112 112 21 2 2 2 2 -2 -2 -2 -2 2 2 0 0 1 1 3 3 3 3 63 1 24 1 3 -2.000000" }, { "path": "tests/base/Pattern2b.Mod", "content": "MODULE Pattern2b;\nIMPORT SYSTEM;\n VAR i, j: INTEGER;\n x, y: REAL;\n s, t: SET;\nBEGIN \n x := 1.0+7.0;\n WriteReal(x);\n y := 7.0;\n x := 1.0+y;\n WriteReal(x);\n y := 9.0;\n x := y-1.0;\n WriteReal(x);\n y := 4.0;\n x := y*2.0;\n WriteReal(x);\n y := 16.0;\n x := y/2.0;\n WriteReal(x);\n i := -8;\n WriteInt(i); \n j := 8;\n i := -j;\n WriteInt(i); \n x := -8.0;\n WriteReal(x); \n y := 8.0;\n x := -y;\n WriteReal(x); \n s := -{1, 3..31};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n t := {1, 3..31};\n s := -t;\n WriteInt(SYSTEM.VAL(INTEGER, s));\nEND Pattern2b." }, { "path": "tests/base/Pattern2b.txt", "content": " 8.000000 8.000000 8.000000 8.000000 8.000000 -8 -8 -8.000000 -8.000000 5 5" }, { "path": "tests/base/Pattern2c.Mod", "content": "MODULE Pattern2c;\nIMPORT SYSTEM;\n VAR s, t, u: SET;\nBEGIN \n s := {1, 5} + {2, 7, 4};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n s := {1, 5} * {7, 1, 2};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n s := {1, 5} - {7, 1, 2};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n s := {1, 5, 2} / {7, 1, 2};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5};\n s := u + {2, 7, 4};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5};\n s := u * {7, 1, 2};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5};\n s := u - {7, 1, 2};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5, 2};\n s := u / {7, 1, 2};\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5};\n t := {2, 7, 4};\n s := u + t;\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5};\n t := {7, 1, 2};\n s := u * t;\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5};\n t := {7, 1, 2};\n s := u - t;\n WriteInt(SYSTEM.VAL(INTEGER, s));\n u := {1, 5, 2};\n t := {7, 1, 2};\n s := u / t;\n WriteInt(SYSTEM.VAL(INTEGER, s));\nEND Pattern2c." }, { "path": "tests/base/Pattern2c.txt", "content": " 182 2 32 160 182 2 32 160 182 2 32 160" }, { "path": "tests/base/Permutations.Mod", "content": "MODULE Permutations; (*NW 22.1.2013 for Oberon-0*)\n VAR m, n: INTEGER;\n a: ARRAY 10 OF INTEGER;\n\n PROCEDURE perm(k: INTEGER);\n VAR i, x: INTEGER;\n BEGIN\n IF k = 0 THEN i := 0;\n WHILE i < n DO WriteInt(a[i]); i := i+1 END ;\n WriteLn\n ELSE perm(k-1); i := 0;\n WHILE i < k-1 DO\n x := a[i]; a[i] := a[k-1]; a[k-1] := x;\n perm(k-1);\n x := a[i]; a[i] := a[k-1]; a[k-1] := x;\n i := i+1\n END\n END\n END perm;\n\nBEGIN n := 0; m := ReadInt();\n WHILE ~eot() DO a[n] := m; n := n+1; m:= ReadInt() END ;\n perm(n)\nEND Permutations." }, { "path": "tests/base/Permutations.txt", "content": " 3 7 11\n 7 3 11\n 11 7 3\n 7 11 3\n 3 11 7\n 11 3 7\n" }, { "path": "tests/base/Powers.Mod", "content": "MODULE Powers; (*NW 25.1.2013 fo Oberon-07; Tabulate positive and negative powers of 2*)\n CONST N = 32; M = 11; (*M ~ N*log2*)\n \n PROCEDURE Go;\n VAR i, k, n, exp: INTEGER;\n c, r, t: INTEGER;\n d: ARRAY M OF INTEGER;\n f: ARRAY N OF INTEGER;\n BEGIN n := ReadInt(); d[0] := 1; k := 1; exp := 1;\n WHILE exp < n DO\n (*compute d = 2^exp*)\n c := 0; (*carry*) i := 0;\n WHILE i < k DO\n t := 2*d[i] + c;\n IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ;\n i := i+1\n END ;\n IF c = 1 THEN d[k] := 1; k := k+1 END ;\n (*write d*) i := M;\n WHILE i > k DO i := i-1; WriteChar(\" \") END ;\n WHILE i > 0 DO i := i-1; WriteChar(CHR(d[i] + 48)) END ;\n WriteInt(exp);\n (*compute f = 2^-exp*)\n WriteChar(CHR(9)); WriteChar(\"0\"); WriteChar(\".\");\n r := 0; i := 1;\n WHILE i < exp DO\n r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2;\n WriteChar(CHR(f[i] + 48)); i := i+1\n END ;\n f[exp] := 5; WriteChar(\"5\"); WriteLn; exp := exp + 1\n END\n END Go;\n\nBEGIN Go\nEND Powers." }, { "path": "tests/base/Powers.txt", "content": " 2 1\t0.5\n 4 2\t0.25\n 8 3\t0.125\n 16 4\t0.0625\n 32 5\t0.03125\n 64 6\t0.015625\n 128 7\t0.0078125\n 256 8\t0.00390625\n 512 9\t0.001953125\n 1024 10\t0.0009765625\n 2048 11\t0.00048828125\n 4096 12\t0.000244140625\n 8192 13\t0.0001220703125\n 16384 14\t0.00006103515625\n 32768 15\t0.000030517578125\n 65536 16\t0.0000152587890625\n 131072 17\t0.00000762939453125\n 262144 18\t0.000003814697265625\n 524288 19\t0.0000019073486328125\n 1048576 20\t0.00000095367431640625\n 2097152 21\t0.000000476837158203125\n 4194304 22\t0.0000002384185791015625\n 8388608 23\t0.00000011920928955078125\n 16777216 24\t0.000000059604644775390625\n 33554432 25\t0.0000000298023223876953125\n 67108864 26\t0.00000001490116119384765625\n 134217728 27\t0.000000007450580596923828125\n 268435456 28\t0.0000000037252902984619140625\n 536870912 29\t0.00000000186264514923095703125\n 1073741824 30\t0.000000000931322574615478515625\n 2147483648 31\t0.0000000004656612873077392578125\n" }, { "path": "tests/base/PrimeNumbers.Mod", "content": "MODULE PrimeNumbers; (*NW 6.9.07; Tabulate prime numbers; for Oberon-07 NW 25.1.2013*)\n \n VAR n: INTEGER;\n p: ARRAY 400 OF INTEGER;\n v: ARRAY 20 OF INTEGER;\n\n PROCEDURE Primes(n: INTEGER);\n VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN;\n BEGIN x := 1; inc := 4; lim := 1; sqr := 4; m := 0; i := 3;\n WHILE i <= n DO\n REPEAT x := x + inc; inc := 6 - inc;\n IF sqr <= x THEN (*sqr = p[lim]^2*)\n v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim]\n END ;\n k := 2; prim := TRUE;\n WHILE prim & (k < lim) DO\n k := k+1;\n IF v[k] < x THEN v[k] := v[k] + p[k] END ;\n prim := x # v[k]\n END\n UNTIL prim;\n p[i] := x; WriteInt(x);\n IF m = 10 THEN WriteLn; m := 0 ELSE m := m+1 END ;\n i := i+1\n END ;\n IF m > 0 THEN WriteLn END\n END Primes;\n\nBEGIN n:= ReadInt(); WriteInt(n); WriteLn; Primes(n)\nEND PrimeNumbers." }, { "path": "tests/base/PrimeNumbers.txt", "content": " 20\n 5 7 11 13 17 19 23 29 31 37 41\n 43 47 53 59 61 67 71\n" }, { "path": "tests/base/ProcComparisons.Mod", "content": "MODULE ProcComparisons;\n VAR x: BOOLEAN;\n \n PROCEDURE P2(i : INTEGER): INTEGER;\n BEGIN \n RETURN 2\n END P2;\n \n PROCEDURE P1(i : INTEGER): INTEGER;\n BEGIN \n RETURN 1\n END P1;\n \nBEGIN\n IF P2 = P1 THEN WriteInt(0) END;\n IF P2 = P2 THEN WriteInt(1) END;\n IF P2 # P1 THEN WriteInt(2) END;\n IF P2 # NIL THEN WriteInt(3) END;\n IF P2 = NIL THEN WriteInt(4) END;\n x := P2 = P2;\n x := P2 = NIL\nEND ProcComparisons." }, { "path": "tests/base/ProcComparisons.txt", "content": " 1 2 3" }, { "path": "tests/base/ProcType.Mod", "content": "MODULE ProcType;\n TYPE\n P = PROCEDURE(x: INTEGER);\n VAR p : P;\n \n PROCEDURE I(x: INTEGER);\n BEGIN WriteInt(x)\n END I;\n\n PROCEDURE callP(p: P);\n BEGIN p(9)\n END callP;\n\nBEGIN\n (* p := P; illegal assignment *)\n (* callP(P); illegal value parameter *)\n p := I;\n p(8); (* 8 *)\n callP(I); (* 9 *)\nEND ProcType." }, { "path": "tests/base/ProcType.txt", "content": " 8 9" }, { "path": "tests/base/ProcVariables0.Mod", "content": "MODULE ProcVariables0;\n TYPE \n MyFun = PROCEDURE() : INTEGER;\n R = RECORD i : INTEGER END;\n P = POINTER TO R;\n VAR\n a: MyFun;\n b : PROCEDURE(r : R) : P;\n c : PROCEDURE(f : R) : P;\n r : R;\n p : P;\n\n PROCEDURE getNum8() : INTEGER;\n RETURN 8 \n END getNum8;\n\n PROCEDURE getNum7() : INTEGER;\n RETURN 7 \n END getNum7;\n \n PROCEDURE getPtr0(x : R) : P;\n VAR y : P;\n BEGIN\n NEW(y);\n y.i := x.i;\n RETURN y\n END getPtr0;\n \n PROCEDURE getPtr1(x : R) : P;\n VAR y : P;\n BEGIN\n NEW(y);\n y.i := x.i+1;\n RETURN y\n END getPtr1;\n \n PROCEDURE Run;\n VAR\n a0: MyFun;\n b0 : PROCEDURE(r : R) : P;\n c0 : PROCEDURE(f : R) : P;\n r0: R;\n p0 : P;\n BEGIN\n a0 := getNum8;\n WriteInt(a0());\n a0 := getNum7;\n WriteInt(a0());\n\n r0.i := 1;\n b0 := getPtr0;\n p0 := b0(r0);\n WriteInt(p0.i);\n b0 := getPtr1;\n p0 := b0(r0);\n WriteInt(p0.i);\n c0 := b0;\n p0 := c0(r0);\n WriteInt(p0.i)\n END Run;\nBEGIN\n Run;\n WriteLn;\n a := getNum8;\n WriteInt(a());\n a := getNum7;\n WriteInt(a());\n\n r.i := 1;\n b := getPtr0;\n p := b(r);\n WriteInt(p.i);\n b := getPtr1;\n p := b(r);\n WriteInt(p.i);\n c := b;\n p := c(r);\n WriteInt(p.i)\nEND ProcVariables0." }, { "path": "tests/base/ProcVariables0.txt", "content": " 8 7 1 2 2\n 8 7 1 2 2" }, { "path": "tests/base/ProcVariables1.Mod", "content": "MODULE ProcVariables1;\n TYPE \n R = RECORD i : INTEGER END;\n MyFun = PROCEDURE(r : R) : INTEGER;\n VAR\n a : ARRAY 2 OF MyFun;\n i : INTEGER;\n r : R;\n\n PROCEDURE F1(x : R) : INTEGER;\n RETURN x.i+1\n END F1;\n \n PROCEDURE F2(x : R) : INTEGER;\n RETURN x.i+2\n END F2;\n \n PROCEDURE Run;\n VAR\n a0 : ARRAY 2 OF MyFun;\n BEGIN\n r.i := 1;\n a0[0] := F1;\n a0[1] := F2;\n FOR i := 0 TO 1 DO\n WriteInt(a0[i](r))\n END\n END Run;\nBEGIN\n Run;\n WriteLn;\n r.i := 1;\n a[0] := F1;\n a[1] := F2;\n FOR i := 0 TO 1 DO\n WriteInt(a[i](r))\n END\nEND ProcVariables1." }, { "path": "tests/base/ProcVariables1.txt", "content": " 2 3\n 2 3" }, { "path": "tests/base/ProcVariables2.Mod", "content": "MODULE ProcVariables2;\n TYPE \n MyFun = PROCEDURE(x : INTEGER) : INTEGER;\n R = RECORD \n i : INTEGER; \n p : ARRAY 2 OF PROCEDURE(x : INTEGER) : INTEGER\n END;\n R1 = RECORD(R) j : CHAR END;\n VAR\n r : R;\n k : R1;\n i : BYTE;\n f : MyFun;\n\n PROCEDURE F1(x : INTEGER) : INTEGER;\n RETURN x+1\n END F1;\n \n PROCEDURE F2(x : INTEGER) : INTEGER;\n RETURN x+2\n END F2;\n \n PROCEDURE P1(x : INTEGER; y : MyFun) : INTEGER;\n RETURN y(x)\n END P1;\n \n PROCEDURE P2(x : INTEGER; VAR y : MyFun) : INTEGER;\n RETURN y(x)\n END P2;\n \n PROCEDURE Run;\n VAR\n r0 : R;\n k0 : R1;\n f0 : MyFun;\n BEGIN\n k0.i := 1;\n k0.p[0] := F1;\n k0.p[1] := F2;\n r0 := k0;\n FOR i := 0 TO 1 DO\n WriteInt(r0.p[i](r0.i))\n END;\n WriteLn;\n WriteInt(P1(1, F1));\n f0 := F2;\n WriteInt(P2(1, f0))\n END Run;\nBEGIN\n Run;\n WriteLn;\n k.i := 1;\n k.p[0] := F1;\n k.p[1] := F2;\n r := k;\n FOR i := 0 TO 1 DO\n WriteInt(r.p[i](r.i))\n END;\n WriteLn;\n WriteInt(P1(1, F1));\n f := F2;\n WriteInt(P2(1, f))\nEND ProcVariables2." }, { "path": "tests/base/ProcVariables2.txt", "content": " 2 3\n 2 3\n 2 3\n 2 3" }, { "path": "tests/base/ProcVariables3.Mod", "content": "MODULE ProcVariables3;\n TYPE PT = PROCEDURE (m, n: INTEGER);\n Object = POINTER TO RECORD w: INTEGER; p: PT END ;\n VAR obj: Object; a: ARRAY 4 OF PT;\n\n PROCEDURE P(m, n: INTEGER; q: PT; VAR obj: Object);\n BEGIN q(m, n); obj.p(m+1, n); a[m](m+2, n)\n END P;\n\n PROCEDURE X( x1,x2 : INTEGER);\n BEGIN\n WriteInt(x1);\n WriteInt(x2);\n WriteLn;\n END X;\n\nBEGIN\n NEW(obj);\n obj.p := X;\n a[1] := X;\n P(1, 8, X, obj)\nEND ProcVariables3." }, { "path": "tests/base/ProcVariables3.txt", "content": " 1 8\n 2 8\n 3 8\n" }, { "path": "tests/base/ProcVariables4.Mod", "content": "MODULE ProcVariables4;\n TYPE P0 = PROCEDURE(VAR x : REAL) : INTEGER;\n P1 = PROCEDURE(VAR x : REAL; VAR y : P0) : INTEGER;\n P2 = PROCEDURE(VAR x : REAL; y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER;\n P3 = PROCEDURE(VAR x : REAL; VAR y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER;\nVAR v: P0;\n v1: P1;\n v2: P2;\n v3: P3;\n f: REAL;\n\nPROCEDURE Floor(VAR x : REAL) : INTEGER;\n RETURN FLOOR(x)\nEND Floor;\n\nPROCEDURE Floor1(VAR x : REAL; VAR y : P0) : INTEGER;\n RETURN y(x)\nEND Floor1;\n\nPROCEDURE Floor2(VAR x : REAL; y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER;\n RETURN y(x)\nEND Floor2;\n\nPROCEDURE Floor3(VAR x : REAL; VAR y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER;\n RETURN y(x)\nEND Floor3;\n\nBEGIN\n f := 8.5;\n v := Floor;\n (* WriteInt(Floor(8.0)); ERROR: read-only *) \n WriteInt(v(f)); (* 8 *) \n f := 9.5;\n v1 := Floor1;\n WriteInt(v1(f, v)); (* 9 *) \n f := 10.5;\n v2 := Floor2;\n WriteInt(v2(f, v)); (* 10 *) \n v3 := Floor3;\n (* WriteInt(v3(f, v)); ERROR: incompatible parameters (see rule E)) *) \nEND ProcVariables4." }, { "path": "tests/base/ProcVariables4.txt", "content": " 8 9 10" }, { "path": "tests/base/ProcVariables5.Mod", "content": "MODULE ProcVariables5;\n TYPE\n T = PROCEDURE (x, y: INTEGER; z: BYTE);\n VAR\n v: T;\n i,j: INTEGER;\n\n PROCEDURE P (x, y: INTEGER; z: BYTE);\n BEGIN\n WriteInt(x+y+z)\n END P;\n\n PROCEDURE P1 (p: PROCEDURE (x, y: INTEGER; z: BYTE));\n BEGIN\n IF i = 0 THEN\n INC(i);\n v := p;\n p(1, 2, 3); (* 6 *)\n v(1, 2, 4); (* 7 *)\n P1(p);\n P1(v)\n END;\n END P1;\n\n PROCEDURE P2 (p: T);\n BEGIN\n IF j = 0 THEN\n INC(j);\n v := p;\n p(1, 2, 3); (* 6 *)\n v(1, 2, 4); (* 7 *)\n P1(p);\n P1(v);\n P2(p);\n P2(v)\n END;\n END P2;\nBEGIN\n i := 0;\n j := 0;\n v := P;\n P1(P);\n P2(P)\nEND ProcVariables5." }, { "path": "tests/base/ProcVariables5.txt", "content": " 6 7 6 7" }, { "path": "tests/base/ProcVariables6.Mod", "content": "MODULE ProcVariables6;\n TYPE\n Q = PROCEDURE (c: CHAR);\n VAR\n q: Q;\n\n PROCEDURE P0(VAR j: Q);\n PROCEDURE P1(c: CHAR);\n BEGIN\n WriteChar(c);\n WriteLn\n END P1;\n BEGIN\n j := P1\n END P0;\n\nBEGIN\n P0(q);\n q(\"a\")\nEND ProcVariables6.\n" }, { "path": "tests/base/ProcVariables6.txt", "content": "a\n" }, { "path": "tests/base/ProcVariables7.Mod", "content": "MODULE ProcVariables7;\n TYPE\n ProcA = PROCEDURE;\n ProcB = PROCEDURE;\n\n VAR\n a: ProcA;\n\n PROCEDURE A;\n BEGIN\n WriteChar(\"A\")\n END A;\n\n\n PROCEDURE B;\n BEGIN\n WriteChar(\"B\")\n END B;\n\n PROCEDURE C(x: PROCEDURE(b: BYTE; c: CHAR; r: REAL));\n BEGIN\n WriteChar(\"C\")\n END C;\n\nBEGIN\n a := NIL;\n a := A;\n a();\n a := B;\n a;\n C(NIL)\nEND ProcVariables7.\n" }, { "path": "tests/base/ProcVariables7.txt", "content": "ABC" }, { "path": "tests/base/RealExpressions.Mod", "content": "MODULE RealExpressions;\n CONST NaN* = 0.0/0.0;\n PROCEDURE One() : REAL;\n RETURN 1.0\n END One;\n PROCEDURE Arithmetic;\n VAR r, x, y : REAL;\n BEGIN\n x := 3.0;\n y := 2.0;\n r := x + y + One();\n WriteReal(r); WriteLn;\n r := x - y;\n WriteReal(r); WriteLn;\n r := x * y;\n WriteReal(r); WriteLn;\n r := x / y;\n WriteReal(r); WriteLn;\n WriteReal(3.5 + 10.0 * 2.0); WriteLn\n END Arithmetic;\n PROCEDURE Relations;\n VAR x, y : REAL;\n BEGIN\n x := 3.0;\n y := NaN;\n IF x = y THEN WriteInt(1) END;\n IF x <= y THEN WriteInt(1) END;\n IF x < y THEN WriteInt(1) END;\n IF x >= y THEN WriteInt(1) END;\n IF x > y THEN WriteInt(1) END;\n y := 1.E0;\n IF x = y THEN WriteInt(1) END;\n IF x <= y THEN WriteInt(2) END;\n IF x < y THEN WriteInt(3) END;\n IF x >= y THEN WriteInt(4) END;\n IF x > y THEN WriteInt(5) END;\n WriteLn\n END Relations;\nBEGIN\n Arithmetic;\n Relations\nEND RealExpressions.\n" }, { "path": "tests/base/RealExpressions.txt", "content": " 6.000000\n 1.000000\n 6.000000\n 1.500000\n 23.500000\n 4 5\n" }, { "path": "tests/base/RecordAndTypeExtension.Mod", "content": "MODULE RecordAndTypeExtension;\n TYPE\n A = RECORD\n x : INTEGER;\n next : POINTER TO A;\n next2 : POINTER TO RECORD y : REAL END;\n END;\n B = RECORD(A) b : INTEGER END;\n C = RECORD(A) c : BOOLEAN END;\n PTRA = POINTER TO A;\n PTRB = POINTER TO B;\n PTRC = POINTER TO C;\n VAR\n pa : PTRA;\n pb : POINTER TO B;\n a : A;\n b : B;\n k : INTEGER;\n\n PROCEDURE PrintBool(x : BOOLEAN);\n BEGIN\n IF x THEN WriteInt(1) ELSE WriteInt(0) END;\n WriteLn\n END PrintBool;\n\n PROCEDURE testRelation;\n VAR a, b : PTRA;\n BEGIN \n NEW(a);\n b := NIL;\n PrintBool(NIL = b);\n PrintBool(b = NIL);\n PrintBool(NIL # b);\n PrintBool(b # NIL);\n PrintBool(a = b);\n PrintBool(a # b);\n b := a;\n PrintBool(a = b);\n PrintBool(a # b);\n END testRelation;\n\n PROCEDURE typeTest(VAR a3 : A);\n VAR\n pa2 : POINTER TO A;\n pa2T : PTRA;\n pb2 : POINTER TO B;\n b2 : B;\n BEGIN\n b2 := a3(B);\n WriteInt(b2.b); (* 8 *)\n NEW(pb2);\n pb2.x := 9;\n pb2.b := 15;\n pa2 := pb2;\n WriteInt(pa2.x); (* 9 *)\n pa2.x := 10;\n WriteInt(pb2.x); (* 10 *)\n pa2T := pb2;\n WriteInt(pa2T.x); (* 10 *)\n k := a3(B).b;\n WriteInt(k); (* 8 *)\n (* k := pa2(B).b; incompatible types *)\n (* k := pa2T(B).b; incompatible types *)\n k := a3(A).x;\n WriteInt(k); (* 7 *)\n (* k := pa2(A).x; incompatible types *)\n (* k := pa2T(A).x; incompatible types *)\n (* PrintBool(i IS INTEGER); incompatible types *)\n (* k := a3(PTRB).b; incompatible types *)\n k := pa2(PTRB).b;\n WriteInt(k); (* 15 *)\n k := pa2T(PTRB).b;\n WriteInt(k); (* 15 *)\n (* k := a3(PTRA).x; incompatible types *)\n k := pa2(PTRA).x; (* Todo: here we generate an unnecessary CHECKCAST *)\n WriteInt(k); (* 10 *)\n k := pa2T(PTRA).x;\n WriteInt(k); (* 10 *)\n PrintBool(a3 IS B);\n (* PrintBool(pa2 IS B); incompatible types *)\n (*PrintBool(pa2T IS B); incompatible types *)\n PrintBool(a3 IS A);\n (* PrintBool(pa2 IS A); incompatible types *)\n (* PrintBool(pa2T IS A); incompatible types *)\n (* PrintBool(a3 IS PTRB); incompatible types *)\n PrintBool(pa2 IS PTRB);\n PrintBool(pa2T IS PTRB);\n (* PrintBool(a3 IS PTRA); incompatible types *)\n PrintBool(pa2 IS PTRA);\n PrintBool(pa2T IS PTRA);\n PrintBool(pa2T IS PTRC);\n END typeTest;\n\n PROCEDURE localPointer;\n VAR\n pa2 : POINTER TO A;\n pb2 : POINTER TO B;\n a2 : A;\n b2 : B;\n arr2 : ARRAY 1 OF POINTER TO A;\n mulArr2 : ARRAY 1,3 OF POINTER TO A;\n BEGIN\n pa2 := NIL;\n NEW(pa2);\n pa2.x := 10;\n a2 := pa2^;\n WriteInt(a2.x); (* 10 *)\n pa2.x := 11;\n a2.x := pa2^.x;\n WriteInt(a2.x); (* 11 *)\n a2.x := pa2.x;\n WriteInt(a2.x); (* 11 *)\n a := pa2^;\n NEW(arr2[0]);\n NEW(mulArr2[0][2]);\n mulArr2[0][2].x := 12;\n NEW(a2.next2);\n NEW(pb2);\n pb2.x := 99;\n b2.x := 13;\n a2 := b2;\n WriteInt(a2.x); (* 13 *)\n pa2 := pb2;\n WriteInt(pa2.x); (* 99 *)\n END localPointer;\n PROCEDURE NewPar(VAR x : PTRA);\n BEGIN NEW(x) END NewPar;\n\nBEGIN\n WriteInt(a.x); (* 0 *)\n localPointer;\n WriteInt(a.x); (* 11 *)\n WriteLn;\n (* varRuntimeCheck(b); this fails with an ArrayStoreException as expected.\n Maybe we should use our own Trap instead: 'type guard failure'*)\n b.b := 8;\n b.x := 7;\n typeTest(b);\n NewPar(pa);\n testRelation;\n NEW(pb);\n pa := pb;\n PrintBool(pa = pb)\nEND RecordAndTypeExtension." }, { "path": "tests/base/RecordAndTypeExtension.txt", "content": " 0 10 11 11 13 99 11\n 8 9 10 10 8 7 15 15 10 10 1\n 1\n 1\n 1\n 1\n 1\n 0\n 1\n 1\n 0\n 0\n 0\n 1\n 1\n 0\n 1\n" }, { "path": "tests/base/RecordAssignment.Mod", "content": "MODULE RecordAssignment;\n TYPE A = RECORD \n x : INTEGER;\n y : ARRAY 1, 2 OF INTEGER;\n END; \n D = RECORD d : REAL END;\n C = RECORD \n c : INTEGER;\n d : ARRAY 1, 1 OF D;\n END; \n B = RECORD(C)\n a : A;\n r : REAL;\n cArr : ARRAY 1 OF C;\n END;\n VAR \n a1 : ARRAY 1 OF A;\n a2 : RECORD a : A END;\n c1, c2 : C;\n b1, b2 : B;\n \n PROCEDURE initA(VAR x : A);\n BEGIN\n x.x := 1;\n x.y[0][0] := 2;\n x.y[0][1] := 3;\n END initA;\n \n PROCEDURE initD(VAR x : D);\n BEGIN x.d := 20.0\n END initD;\n \n PROCEDURE initC(VAR x : C);\n BEGIN \n x.c := 79;\n x.d[0][0].d := 99.0;\n END initC;\nBEGIN \n initA(a1[0]);\n a2.a := a1[0];\n a2.a.x := 11; \n a2.a.y[0][1] := 33;\n WriteInt(a1[0].x);\n WriteInt(a2.a.x);\n WriteInt(a1[0].y[0][1]);\n WriteInt(a2.a.y[0][1]);\n WriteLn;\n \n initC(c1);\n c2 := c1;\n c2.c := 80;\n c2.d[0][0].d := 100.0;\n WriteInt(c1.c);\n WriteInt(c2.c);\n WriteReal(c1.d[0][0].d);\n WriteReal(c2.d[0][0].d);\n WriteLn;\n \n b1.r := 4.0;\n initA(b1.a); \n initC(b1.cArr[0]);\n b1.c := 71;\n b1.d[0][0].d := 72.0;\n b2 := b1;\n b2.r := 44.0;\n b2.a.x := 11; \n b2.a.y[0][1] := 33;\n b2.cArr[0].c := 80;\n b2.cArr[0].d[0][0].d := 100.0;\n b2.c := 75;\n b2.d[0][0].d := 76.0;\n WriteReal(b1.r);\n WriteReal(b2.r);\n WriteInt(b1.a.x );\n WriteInt(b2.a.x );\n WriteInt(b1.a.y[0][1]);\n WriteInt(b2.a.y[0][1]);\n WriteInt(b1.cArr[0].c);\n WriteInt(b2.cArr[0].c);\n WriteReal(b1.cArr[0].d[0][0].d);\n WriteReal(b2.cArr[0].d[0][0].d);\n WriteInt(b1.c);\n WriteInt(b2.c);\n WriteReal(b1.d[0][0].d);\n WriteReal(b2.d[0][0].d);\n b2 := b2;\nEND RecordAssignment." }, { "path": "tests/base/RecordAssignment.txt", "content": " 1 11 3 33\n 79 80 99.000000 100.000000\n 4.000000 44.000000 1 11 3 33 79 80 99.000000 100.000000 71 75 72.000000 76.000000" }, { "path": "tests/base/RecordAssignment2.Mod", "content": "MODULE RecordAssignment2;\n TYPE RP = POINTER TO R;\n R = RECORD\n i: INTEGER;\n a: ARRAY 10 OF RP;\n p: RP;\n END;\n VAR\n gbl0, gbl1 : RP;\n\n PROCEDURE Init(VAR x: R; i: INTEGER);\n BEGIN\n x.i := i;\n NEW(x.a[2]);\n x.a[2].i := i;\n NEW(x.p);\n x.p.i := i;\n END Init;\n\n PROCEDURE Print(x: R);\n BEGIN\n WriteInt(x.i);\n WriteInt(x.a[2].i);\n WriteInt(x.p.i);\n WriteLn\n END Print;\n\n PROCEDURE Run(local: RP; x: R);\n VAR y: R;\n BEGIN\n Init(y, 1);\n y := x;\n Print(y); (* 8 8 8 *)\n\n Init(gbl0^, 2);\n gbl0^ := x;\n Print(gbl0^); (* 8 8 8 *)\n\n Init(gbl0^, 3);\n gbl0^ := local^;\n Print(gbl0^); (* 8 8 8 *)\n\n Init(gbl0^.a[2]^, 4);\n gbl0^.a[2]^ := local^;\n Print(gbl0^.a[2]^); (* 8 8 8 *)\n\n Init(gbl0^.p^, 5);\n gbl0^.p^ := local^;\n Print(gbl0^.p^); (* 8 8 8 *)\n\n Init(gbl0^.p^.p^, 6);\n gbl0^.p^.p^ := local^;\n Print(gbl0^.p^.p^) (* 8 8 6 *)\n\n END Run;\n\nBEGIN\n NEW(gbl0); NEW(gbl1);\n Init(gbl1^, 8);\n Run(gbl1, gbl1^)\nEND RecordAssignment2.\n" }, { "path": "tests/base/RecordAssignment2.txt", "content": " 8 8 8\n 8 8 8\n 8 8 8\n 8 8 8\n 8 8 8\n 8 8 6\n" }, { "path": "tests/base/RecordParam.Mod", "content": "MODULE RecordParam;\n TYPE RP = POINTER TO R;\n R = RECORD\n i: INTEGER;\n p: RP;\n END;\n VAR\n g0, g1, g2: RP;\n\n PROCEDURE Print(x: RP);\n BEGIN\n WriteInt(x.i);\n IF x.p = NIL THEN WriteInt(0) ELSE WriteInt(x.p.i) END;\n WriteLn\n END Print;\n\n PROCEDURE Init0(VAR x: RP; i: INTEGER);\n BEGIN\n x.i := i;\n NEW(x.p);\n x.p.i := i;\n END Init0;\n \n PROCEDURE Init1(x: RP; i: INTEGER);\n BEGIN\n x.i := i;\n NEW(x.p);\n x.p.i := i;\n END Init1;\n \n PROCEDURE Init2(VAR x: R; i: INTEGER);\n BEGIN\n x.i := i;\n NEW(x.p);\n x.p.i := i;\n END Init2;\n \nPROCEDURE Run*;\nBEGIN\n NEW(g0);\n g0.p := g0;\n Init0(g0.p, 8);\n Print(g0.p); (* 8 8 *)\n\n NEW(g1);\n g1.p := g1;\n Init1(g1.p, 8);\n Print(g1.p); (* 8 0 *)\n\n NEW(g2);\n g2.p := g2;\n Init2(g2.p^, 8);\n Print(g2.p); (* 8 0 *)\n\nEND Run;\n\nBEGIN\n Run\nEND RecordParam.\n" }, { "path": "tests/base/RecordParam.txt", "content": " 8 8\n 8 0\n 8 0\n" }, { "path": "tests/base/Samples0.Mod", "content": "MODULE Samples0;\n VAR n: INTEGER;\n PROCEDURE Multiply;\n VAR x, y, z: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt(); z := 0;\n WHILE x > 0 DO\n IF x MOD 2 = 1 THEN z := z + y END ;\n y := 2*y; x := x DIV 2\n END ;\n WriteInt(x); WriteInt(y); WriteInt(z); WriteLn\n END Multiply;\n \n PROCEDURE Divide;\n VAR x, y, r, q, w: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt(); r := x; q := 0; w := y;\n WHILE w <= r DO w := 2*w END ;\n WHILE w > y DO\n q := 2*q; w := w DIV 2;\n IF w <= r THEN r := r - w; q := q + 1 END\n END ;\n WriteInt(x); WriteInt(y); WriteInt(q); WriteInt(r); WriteLn\n END Divide;\n \n PROCEDURE BinSearch;\n VAR i, j, k, n, x: INTEGER;\n a: ARRAY 32 OF INTEGER;\n BEGIN x := ReadInt(); k := 0;\n WHILE ~eot() DO a[k] := ReadInt(); k := k + 1 END ;\n i := 0; j := n;\n WHILE i < j DO\n k := (i+j) DIV 2;\n IF x < a[k] THEN j := k ELSE i := k+1 END\n END ;\n WriteInt(i); WriteInt(j); WriteInt(a[j]); WriteLn\n END BinSearch;\n \nBEGIN n := ReadInt();\n IF n = 0 THEN Multiply ELSIF n = 1 THEN Divide ELSE BinSearch END\nEND Samples0." }, { "path": "tests/base/Samples0.txt", "content": " 0 80 40\n" }, { "path": "tests/base/Samples1.Mod", "content": "MODULE Samples1;\n VAR n: INTEGER;\n PROCEDURE Multiply;\n VAR x, y, z: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt(); z := 0;\n WHILE x > 0 DO\n IF x MOD 2 = 1 THEN z := z + y END ;\n y := 2*y; x := x DIV 2\n END ;\n WriteInt(x); WriteInt(y); WriteInt(z); WriteLn\n END Multiply;\n \n PROCEDURE Divide;\n VAR x, y, r, q, w: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt(); r := x; q := 0; w := y;\n WHILE w <= r DO w := 2*w END ;\n WHILE w > y DO\n q := 2*q; w := w DIV 2;\n IF w <= r THEN r := r - w; q := q + 1 END\n END ;\n WriteInt(x); WriteInt(y); WriteInt(q); WriteInt(r); WriteLn\n END Divide;\n \n PROCEDURE BinSearch;\n VAR i, j, k, n, x: INTEGER;\n a: ARRAY 32 OF INTEGER;\n BEGIN x := ReadInt(); k := 0;\n WHILE ~eot() DO a[k] := ReadInt(); k := k + 1 END ;\n i := 0; j := n;\n WHILE i < j DO\n k := (i+j) DIV 2;\n IF x < a[k] THEN j := k ELSE i := k+1 END\n END ;\n WriteInt(i); WriteInt(j); WriteInt(a[j]); WriteLn\n END BinSearch;\n \nBEGIN n := ReadInt();\n IF n = 0 THEN Multiply ELSIF n = 1 THEN Divide ELSE BinSearch END\nEND Samples1." }, { "path": "tests/base/Samples1.txt", "content": " 80 5 16 0\n" }, { "path": "tests/base/Samples2.Mod", "content": "MODULE Samples2;\n VAR n: INTEGER;\n PROCEDURE Multiply;\n VAR x, y, z: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt(); z := 0;\n WHILE x > 0 DO\n IF x MOD 2 = 1 THEN z := z + y END ;\n y := 2*y; x := x DIV 2\n END ;\n WriteInt(x); WriteInt(y); WriteInt(z); WriteLn\n END Multiply;\n \n PROCEDURE Divide;\n VAR x, y, r, q, w: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt(); r := x; q := 0; w := y;\n WHILE w <= r DO w := 2*w END ;\n WHILE w > y DO\n q := 2*q; w := w DIV 2;\n IF w <= r THEN r := r - w; q := q + 1 END\n END ;\n WriteInt(x); WriteInt(y); WriteInt(q); WriteInt(r); WriteLn\n END Divide;\n \n PROCEDURE BinSearch;\n VAR i, j, k, n, x: INTEGER;\n a: ARRAY 32 OF INTEGER;\n BEGIN x := ReadInt(); k := 0;\n WHILE ~eot() DO a[k] := ReadInt(); k := k + 1 END ;\n i := 0; j := n;\n WHILE i < j DO\n k := (i+j) DIV 2;\n IF x < a[k] THEN j := k ELSE i := k+1 END\n END ;\n WriteInt(i); WriteInt(j); WriteInt(a[j]); WriteLn\n END BinSearch;\n \nBEGIN n := ReadInt();\n IF n = 0 THEN Multiply ELSIF n = 1 THEN Divide ELSE BinSearch END\nEND Samples2." }, { "path": "tests/base/Samples2.txt", "content": " 0 0 2\n" }, { "path": "tests/base/SetTest.Mod", "content": "MODULE SetTest;\nIMPORT SYSTEM;\n CONST\n eight = 8;\n c0 = {6..eight};\n c1 = {0..4, 10, 30..31};\n six = {6};\n VAR s : SET;\n x,y : INTEGER;\n b : BOOLEAN;\n\n PROCEDURE PrintSet(x : SET);\n VAR i : INTEGER;\n BEGIN\n FOR i:= 0 TO 31 DO\n IF i IN x THEN WriteInt(i) END\n END;\n WriteLn\n END PrintSet;\n PROCEDURE PrintBool(x : BOOLEAN);\n BEGIN\n IF x THEN WriteInt(1) ELSE WriteInt(0) END;\n END PrintBool;\n PROCEDURE testRelation;\n VAR a : ARRAY 1 OF SET;\n b: SET;\n BEGIN\n a[0] := {4, 5, 3};\n b := {4, 5, 1, 8};\n IF a[0] = b THEN WriteInt(3) END;\n IF a[0] # b THEN WriteInt(4) END;\n WriteLn;\n a[0] := {4, 5, 3};\n b := {1..8};\n IF a[0] = b THEN WriteInt(3) END;\n IF a[0] # b THEN WriteInt(4) END;\n WriteLn;\n a[0] := {1..8};\n b := {3, 8, 1};\n IF a[0] = b THEN WriteInt(3) END;\n IF a[0] # b THEN WriteInt(4) END;\n WriteLn;\n a[0] := {1..3};\n b := {3, 2, 1};\n IF a[0] = b THEN WriteInt(3) END;\n IF a[0] # b THEN WriteInt(4) END;\n WriteLn;\n END testRelation;\n PROCEDURE testSetAndArrayAndField;\n TYPE\n V = RECORD\n s : SET;\n END;\n VAR\n i : INTEGER;\n f : ARRAY 2 OF SET;\n m : ARRAY 2 OF INTEGER;\n s, k : SET;\n b : BOOLEAN;\n d : V;\n BEGIN\n s := {9};\n m[0] := 5;\n m[1] := 15;\n k := {8..m[1]} - s;\n PrintSet(k); (* {8, 10..15} *)\n i := 31;\n k := {8..10, i } - s;\n PrintSet(k); (* {8, 10, 31} *)\n k := {8..10, m[1] } - s;\n PrintSet(k); (* {8, 10, 15} *)\n k := {8..10, 12..15 } - s;\n PrintSet(k); (* {8, 10, 12..15} *)\n k := {8..10, 12..m[1] } - s;\n PrintSet(k); (* {8, 10, 12..15} *)\n k := {8..10, m[0]..12 } - s;\n PrintSet(k); (* {5..8, 10..12} *)\n k := {8..10, m[0]..m[1] } - s;\n PrintSet(k); (* {5..8, 10..15} *)\n k := {m[0]..10, 12..m[1] } - s;\n PrintSet(k); (* {5..8, 10, 12..15} *)\n k := {8..m[1], 12..m[1] } - s;\n PrintSet(k); (* {8, 10..15} *)\n s := {3..20};\n k := s - {8..m[1], 12..m[1] };\n PrintSet(k); (* {3..7, 16..20} *)\n s := {9};\n k := {m[0]..m[1]} - s;\n PrintSet(k); (* {5..8, 10..15} *)\n k := {m[0]..13} - s;\n PrintSet(k); (* {5..8, 10..13} *)\n k := {8} - s;\n PrintSet(k); (* {8} *)\n k := s - {8};\n PrintSet(k); (* {9} *)\n k := {1..3} - {8};\n PrintSet(k); (* {1..3} *)\n k := s - s;\n PrintSet(k); (* {} *)\n s := {9};\n m[0] := 5;\n m[1] := 15;\n f[0] := {1..3};\n f[1] := {5};\n d.s := {1..10};\n k := {4, 1} - f[0];\n PrintSet(k); (* {4} *)\n k := f[0] - {2};\n PrintSet(k); (* {1, 3} *)\n k := {1..3} + {8};\n PrintSet(k); (* {1..3, 8} *)\n k := s - f[0];\n PrintSet(k); (* {9} *)\n k := f[0] - f[0];\n PrintSet(k); (* {} *)\n b := m[0] IN {1..3};\n PrintBool(b); (* 0 *)\n b := m[0] IN f[0];\n PrintBool(b); (* 0 *)\n b := m[0] IN d.s;\n PrintBool(b); (* 1 *)\n b := 1 IN {1..3};\n PrintBool(b); (* 1 *)\n b := 1 IN f[0];\n PrintBool(b); (* 1 *)\n b := 1 IN d.s;\n PrintBool(b); (* 1 *)\n END testSetAndArrayAndField;\nBEGIN\n x := 5;\n s:= {3..x};\n PrintSet(s);\n s:= {3..x, 20};\n PrintSet(s);\n y := 20;\n s:= {3..x, y};\n PrintSet(s);\n y := 20;\n s:= {y, 3..x};\n PrintSet(s);\n b := (4 IN s) OR (x > 10);\n PrintBool(b);\n WriteLn;\n s := s + c0; (* {3..8, 20} *)\n PrintSet(s);\n s := {1..20, 22} - c1; (* {5..9, 11..20, 22} *)\n PrintSet(s);\n s := s * {6..8, 20}; (* {6..8, 20} *)\n PrintSet(s);\n s := s / {1..20, 23..31}; (* {1..5, 9..19, 23..31} *)\n PrintSet(s);\n s := {1, 2, 3} / {3, 4}; (* {1 2 4} *)\n PrintSet(s);\n x := 30;\n s:= {x..3}; (* this is wrong as x > 3, maybe we should put a check at runtime *)\n PrintSet(s);\n PrintBool(31 IN {0..2});\n x := 31;\n PrintBool(x IN {0..2});\n x := -100;\n PrintBool(x IN {0..2});\n x := 33;\n PrintBool(x IN {0..2}); (* this is wrong as x >= 32, maybe we should put a check at runtime *)\n WriteLn;\n PrintSet(-{3..6, eight..31});\n s := {3..6, eight..31};\n PrintSet(-s);\n b := 1 IN {1..3}; (* this could be computed at compile-time*);\n PrintBool(b);\n testSetAndArrayAndField;\n testRelation;\n PrintSet({5, 6, 7} * six);\n PrintSet({5..7} / six);\n WriteInt(SYSTEM.VAL(INTEGER, {9..1}))\nEND SetTest.\n" }, { "path": "tests/base/SetTest.txt", "content": " 3 4 5\n 3 4 5 20\n 3 4 5 20\n 3 4 5 20\n 1\n 3 4 5 6 7 8 20\n 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 22\n 6 7 8 20\n 1 2 3 4 5 9 10 11 12 13 14 15 16 17 18 19 23 24 25 26 27 28 29 30 31\n 1 2 4\n 4 30 31\n 0 0 0 1\n 0 1 2 7\n 0 1 2 7\n 1 8 10 11 12 13 14 15\n 8 10 31\n 8 10 15\n 8 10 12 13 14 15\n 8 10 12 13 14 15\n 5 6 7 8 10 11 12\n 5 6 7 8 10 11 12 13 14 15\n 5 6 7 8 10 12 13 14 15\n 8 10 11 12 13 14 15\n 3 4 5 6 7 16 17 18 19 20\n 5 6 7 8 10 11 12 13 14 15\n 5 6 7 8 10 11 12 13\n 8\n 9\n 1 2 3\n\n 4\n 1 3\n 1 2 3 8\n 9\n\n 0 0 1 1 1 1 4\n 4\n 4\n 3\n 6\n 5 7\n 0" }, { "path": "tests/base/Strings0.Mod", "content": "MODULE Strings0;\n CONST baobab = \"BAOBAB\";\n C = \"C\";\n TYPE Arr = ARRAY 10 OF CHAR;\n VAR a : CHAR;\n b : ARRAY 10 OF CHAR;\n c : ARRAY 10 OF CHAR;\n PROCEDURE P(VAR x : ARRAY OF CHAR);\n BEGIN \n x := baobab;\n c := \"BAOBAB\"\n END P;\n \n PROCEDURE Init(VAR x : ARRAY OF CHAR);\n VAR i : INTEGER;\n BEGIN\n FOR i := 0 TO LEN(x)-1 DO\n x[i] := \"-\";\n END;\n END Init;\n \n PROCEDURE Print(x : ARRAY OF CHAR);\n VAR i : INTEGER;\n BEGIN\n FOR i := 0 TO LEN(x)-1 DO\n IF x[i] = 0X THEN\n WriteChar(\"$\")\n ELSE \n WriteChar(x[i])\n END;\n END;\n WriteLn\n END Print;\n \n PROCEDURE Print2(x : Arr);\n VAR i : INTEGER;\n BEGIN\n FOR i := 0 TO LEN(x)-1 DO\n IF x[i] = 0X THEN\n WriteChar(\"$\")\n ELSE \n WriteChar(x[i])\n END; END;\n WriteLn\n END Print2;\nBEGIN\n Init(b); \n b := \"BAOBAB\";\n Print(b);\n a := \"C\";\n WriteChar(a);\n a := C;\n WriteChar(a);\n WriteLn;\n P(b);\n Print2(b);\nEND Strings0." }, { "path": "tests/base/Strings0.txt", "content": "BAOBAB$---\nCC\nBAOBAB$---\n" }, { "path": "tests/base/Strings1.Mod", "content": "MODULE Strings1;\n CONST y = \"A\";\n VAR a: ARRAY 10 OF CHAR;\n x : CHAR;\n s0 : ARRAY 5 OF ARRAY 5 OF CHAR;\n s1 : ARRAY 5 OF CHAR;\n i : INTEGER;\n\n PROCEDURE PrintMid(x : ARRAY OF CHAR);\n BEGIN\n WriteChar(x[LEN(x) DIV 2])\n END PrintMid;\n \n PROCEDURE Cmp(x, y : ARRAY OF CHAR);\n BEGIN\n IF x = y THEN WriteInt(-1) END;\n IF y = x THEN WriteInt(-2) END;\n IF x # y THEN WriteInt(-3) END;\n IF y # x THEN WriteInt(-4) END;\n IF x > y THEN WriteInt(-5) END;\n IF y > x THEN WriteInt(-6) END;\n IF x < y THEN WriteInt(-7) END;\n IF y < x THEN WriteInt(-8) END;\n IF x >= y THEN WriteInt(-9) END;\n IF y >= x THEN WriteInt(-10) END;\n IF x <= y THEN WriteInt(-11) END;\n IF y <= x THEN WriteInt(-12) END;\n END Cmp;\n\n\n PROCEDURE Comparisons;\n VAR a, b : ARRAY 15 OF CHAR;\n c : ARRAY 0 OF CHAR;\n\n PROCEDURE replace0x(VAR str: ARRAY OF CHAR);\n VAR i: INTEGER;\n found: BOOLEAN;\n BEGIN\n found := FALSE;\n FOR i := 0 TO LEN(str)-1 DO\n IF (str[i] = 0X) OR found THEN\n str[i] := \"X\";\n found := TRUE\n END;\n END;\n END replace0x;\n BEGIN\n a := \"Hello\";\n b := \"World\";\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n b := \"Hello\";\n Cmp(a, b);\n WriteLn;\n\n a := \"HelloWorld\";\n b := \"Hello\";\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n b := \"HelloWorld\";\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n b := \"\";\n Cmp(a, b);\n WriteLn;\n\n a := \"\";\n b := \"Hello\";\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n Cmp(a, c);\n WriteLn;\n\n a := \"Hello\";\n Cmp(c, a);\n WriteLn;\n\n a := \"Hello\";\n b := \"World\";\n replace0x(a);\n replace0x(b);\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n b := \"Hello\";\n replace0x(a);\n replace0x(b);\n Cmp(a, b);\n WriteLn;\n\n a := \"HelloWorld\";\n b := \"Hello\";\n replace0x(a);\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n b := \"HelloWorld\";\n replace0x(a);\n replace0x(b);\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n b := \"\";\n replace0x(a);\n Cmp(a, b);\n WriteLn;\n\n a := \"\";\n b := \"Hello\";\n replace0x(a);\n replace0x(b);\n Cmp(a, b);\n WriteLn;\n\n a := \"Hello\";\n replace0x(a);\n Cmp(a, c);\n WriteLn;\n\n a := \"Hello\";\n replace0x(a);\n Cmp(c, a);\n WriteLn;\n\n\n END Comparisons;\n\nBEGIN\n PrintMid(\"Hello\");\n WriteLn;\n IF a = \"Hello\" THEN WriteInt(0) END;\n IF \"Hello\" = \"Hello\" THEN WriteInt(1) END;\n IF \"Hello\" = a THEN WriteInt(2) END;\n IF a # \"Hello\" THEN WriteInt(3) END;\n IF \"Hello\" # \"Hello\" THEN WriteInt(4) END;\n IF \"Hello\" # a THEN WriteInt(5) END;\n IF a > \"Hello\" THEN WriteInt(6) END;\n IF \"Hello\" > \"Hello\" THEN WriteInt(7) END;\n IF \"Hello\" > a THEN WriteInt(8) END;\n IF a < \"Hello\" THEN WriteInt(9) END;\n IF \"Hello\" < \"Hello\" THEN WriteInt(10) END;\n IF \"Hello\" < a THEN WriteInt(11) END;\n IF a >= \"Hello\" THEN WriteInt(12) END;\n IF \"Hello\" >= \"Hello\" THEN WriteInt(13) END;\n IF \"Hello\" >= a THEN WriteInt(14) END;\n IF a <= \"Hello\" THEN WriteInt(15) END;\n IF \"Hello\" <= \"Hello\" THEN WriteInt(16) END;\n IF \"Hello\" <= a THEN WriteInt(17) END;\n IF \"HELL\" = \"HELLO\" THEN WriteInt(18) END;\n WriteLn;\n Comparisons;\n WriteLn;\n x := \"A\";\n IF x = \"A\" THEN WriteInt(1) END;\n IF \"A\" = x THEN WriteInt(2) END;\n IF \"A\" = y THEN WriteInt(3) END;\n s0[0] := \"ZAB\";\n i := -1;\n IF \"ABC\" < s0[1+i] THEN WriteInt(4) END;\n IF s0[1+i] > \"ABC\" THEN WriteInt(5) END;\n IF \"ABC\" < \"ZBC\" THEN WriteInt(6) END;\n IF \"A\" < \"Z\" THEN WriteInt(7) END;\n s1[0] := \"A\";\n IF s1[1+i] = \"A\" THEN WriteInt(8) END;\n IF \"A\" = s1[1+i] THEN WriteInt(9) END;\n IF \"A\" = y THEN WriteInt(10) END;\nEND Strings1." }, { "path": "tests/base/Strings1.txt", "content": "l\n 1 3 5 8 9 13 14 15 16\n -3 -4 -6 -7 -10 -11\n -1 -2 -9 -10 -11 -12\n -3 -4 -5 -8 -9 -12\n -3 -4 -6 -7 -10 -11\n -3 -4 -5 -8 -9 -12\n -3 -4 -6 -7 -10 -11\n -3 -4 -5 -8 -9 -12\n -3 -4 -6 -7 -10 -11\n -3 -4 -6 -7 -10 -11\n -1 -2 -9 -10 -11 -12\n -3 -4 -5 -8 -9 -12\n -3 -4 -5 -8 -9 -12\n -3 -4 -5 -8 -9 -12\n -3 -4 -5 -8 -9 -12\n -3 -4 -5 -8 -9 -12\n -3 -4 -6 -7 -10 -11\n\n 1 2 3 4 5 6 7 8 9 10" }, { "path": "tests/base/Strings2.Mod", "content": "MODULE Strings2;\n\nCONST\n a = \"a\";\n abcd = \"abcd\";\n\nVAR\n s4: ARRAY 4 OF CHAR;\n s5: ARRAY 5 OF CHAR;\n f: ARRAY 20 OF CHAR;\n\n PROCEDURE P(x: ARRAY OF CHAR);\n VAR i : INTEGER;\n BEGIN\n FOR i := 0 TO LEN(x)-1 DO\n IF x[i] = 0X THEN\n WriteChar(\"$\")\n ELSE\n WriteChar(x[i])\n END;\n END;\n WriteLn\n END P;\n\n PROCEDURE K;\n VAR f: ARRAY 20 OF CHAR;\n BEGIN\n f := \"Hello\";\n IF f = \"\" THEN WriteInt(1) END;\n f := \"\";\n IF f = \"\" THEN WriteInt(2) END;\n f[0] := 0X;\n IF f = \"\" THEN WriteInt(3) END\n END K;\nBEGIN\n s4 := a; P(s4);\n s4 := \"a\"; P(s4);\n s4 := \"ab\"; P(s4);\n P(a);\n P(\"a\");\n P(\"ab\");\n (* s4 := abcd; String too long *)\n (*s4 := \"abcd\"; String too long *)\n s5 := abcd; P(s5);\n s5 := \"abcd\"; P(s5);\n s5 := \"\"; P(s5);\n f := \"Hello\";\n IF f = \"\" THEN WriteInt(1) END;\n f := \"\";\n IF f = \"\" THEN WriteInt(2) END;\n f[0] := 0X;\n IF f = \"\" THEN WriteInt(3) END;\n K\nEND Strings2." }, { "path": "tests/base/Strings2.txt", "content": "a$$$\na$$$\nab$$\na$\na$\nab$\nabcd$\nabcd$\n$bcd$\n 2 3 2 3" }, { "path": "tests/base/TestABS.Mod", "content": "MODULE TestABS;\n CONST r = -1.2; i = -2;\n VAR x, y : INTEGER;\n a, b : REAL;\n z : BYTE;\n \nBEGIN\n b := r;\n y := i;\n a := ABS(r);\n WriteReal(a);\n a := ABS(b);\n WriteReal(a);\n x := ABS(i);\n WriteInt(x);\n x := ABS(y);\n WriteInt(x);\n WriteLn;\n b := 7.3;\n y := 8;\n WriteReal(ABS(b));\n WriteInt(ABS(y));\n z := 10;\n WriteInt(ABS(z))\nEND TestABS." }, { "path": "tests/base/TestABS.txt", "content": " 1.200000 1.200000 2 2\n 7.300000 8 10" }, { "path": "tests/base/TestAnonymousName.Mod", "content": "MODULE TestAnonymousName;\n TYPE Anonymous0 = RECORD i :CHAR END;\n \n VAR x : RECORD i :INTEGER END;\n y : Anonymous0;\n c : CHAR;\nBEGIN\n y.i := \"A\";\n c := y.i;\n x.i := 0;\n WriteChar(c)\nEND TestAnonymousName." }, { "path": "tests/base/TestAnonymousName.txt", "content": "A" }, { "path": "tests/base/TestAssert.Mod", "content": "MODULE TestAssert;\n VAR x : INTEGER;\n \nBEGIN\n x := 2;\n ASSERT(TRUE);\n ASSERT(x > 0);\n ASSERT((x > 0) & (x > 5) OR (x < 8) & (x # 3));\n WriteInt(1)\nEND TestAssert." }, { "path": "tests/base/TestAssert.txt", "content": " 1" }, { "path": "tests/base/TestAssignmentMix.Mod", "content": "MODULE TestAssignmentMix;\n TYPE A = RECORD i : INTEGER END;\n B = RECORD(A) j : REAL END;\n TA = ARRAY 1 OF A;\n TB = ARRAY 1 OF B;\n VAR\n (*ta : TA;\n tb : TB;*)\n a : A;\n b : B;\n pa : POINTER TO A;\n pb : POINTER TO B;\n (*ta2 : ARRAY 1 OF A;\n tb2 : ARRAY 1 OF B;*)\nBEGIN\n (*b := a; illegal assignment *)\n a := b; \n (* pb := pa; illegal assignment *)\n pa := pb;\n (* tb := ta; illegal assignment *)\n (* tb2 := ta2; illegal assignment *)\n (* ta := tb; illegal assignment *)\n (* ta2 := tb2; illegal assignment *)\nEND TestAssignmentMix.\n" }, { "path": "tests/base/TestAssignmentMix.txt", "content": "" }, { "path": "tests/base/TestByteType.Mod", "content": "MODULE TestByteType;\n VAR x : INTEGER;\n y : BYTE;\n r : RECORD y : BYTE END;\n ar : ARRAY 1 OF BYTE;\n\n PROCEDURE P1(i : BYTE): INTEGER;\n BEGIN\n RETURN i + 1\n END P1;\n\n PROCEDURE P2(i : INTEGER): BYTE;\n BEGIN\n RETURN i + 1\n END P2;\n\n PROCEDURE Par1(b : BYTE);\n BEGIN\n WriteInt(b)\n END Par1;\n\n PROCEDURE Par2(b : INTEGER);\n BEGIN\n WriteInt(b)\n END Par2;\n\n PROCEDURE Ret1(): BYTE;\n BEGIN\n RETURN 8\n END Ret1;\n\n PROCEDURE Ret2(): INTEGER;\n BEGIN\n RETURN 800\n END Ret2;\n\n PROCEDURE P3;\n VAR x : INTEGER;\n y : BYTE;\n r : RECORD y : BYTE END;\n ar : ARRAY 1 OF BYTE;\n BEGIN\n WriteInt(P1(255));\n WriteInt(P2(256));\n WriteLn;\n y := 255;\n WriteInt(y);\n x := 129;\n WriteInt(x);\n y := x;\n x := y + 1;\n WriteInt(x);\n x := y;\n WriteInt(x);\n WriteLn;\n r.y := 255;\n WriteInt(r.y);\n x := 129;\n WriteInt(x);\n r.y := x;\n x := r.y + 1;\n WriteInt(x);\n x := r.y;\n WriteInt(x);\n WriteLn;\n ar[0] := 255;\n WriteInt(ar[0]);\n x := 129;\n WriteInt(x);\n ar[0] := x;\n x := ar[0] + 1;\n WriteInt(x);\n x := ar[0];\n WriteInt(x);\n x := y;\n IF x = y THEN WriteInt(1) END\n END P3;\n\nBEGIN\n WriteInt(P1(255));\n WriteInt(P2(256));\n WriteLn;\n y := 255;\n WriteInt(y);\n x := 129;\n WriteInt(x);\n y := x;\n x := y + 1;\n WriteInt(x);\n x := y;\n WriteInt(x);\n WriteLn;\n r.y := 255;\n WriteInt(r.y);\n x := 129;\n WriteInt(x);\n r.y := x;\n x := r.y + 1;\n WriteInt(x);\n x := r.y;\n WriteInt(x);\n WriteLn;\n ar[0] := 255;\n WriteInt(ar[0]);\n x := 129;\n WriteInt(x);\n ar[0] := x;\n x := ar[0] + 1;\n WriteInt(x);\n x := ar[0];\n WriteInt(x);\n x := y;\n IF x = y THEN WriteInt(1) END;\n WriteLn;\n P3;\n WriteLn;\n WriteInt(Ret1());\n WriteInt(Ret2());\n Par1(8);\n Par2(800);\n y := 8;\n WriteInt(y);\n x := 800;\n WriteInt(x)\nEND TestByteType.\n" }, { "path": "tests/base/TestByteType.txt", "content": " 256 1\n 255 129 130 129\n 255 129 130 129\n 255 129 130 129 1\n 256 1\n 255 129 130 129\n 255 129 130 129\n 255 129 130 129 1\n 8 800 8 800 8 800" }, { "path": "tests/base/TestCPS.Mod", "content": "MODULE TestCPS;\n\nTYPE F = PROCEDURE(i: INTEGER);\n\nPROCEDURE log(i : INTEGER);\nBEGIN \n WriteInt(i)\nEND log;\n\nPROCEDURE tailFact(n,a : INTEGER; ret : F);\nBEGIN\n IF n = 0 THEN ret(a)\n ELSE tailFact(n-1, n*a, ret) END\nEND tailFact;\n\nBEGIN\n tailFact(6, 1, log)\nEND TestCPS." }, { "path": "tests/base/TestCPS.txt", "content": " 720" }, { "path": "tests/base/TestCmdLineArgs.Mod", "content": "MODULE TestCmdLineArgs;\n VAR x: INTEGER;\n y: ARRAY 10 OF CHAR;\n \n PROCEDURE Print(x: ARRAY OF CHAR);\n VAR i,j : INTEGER;\n BEGIN\n i := 0;\n j := LEN(x)-1;\n WHILE (i < j) & (x[i] # 0X) DO\n WriteChar(x[i]);\n INC(i)\n END;\n WriteLn\n END Print;\n PROCEDURE P(x: ARRAY OF CHAR);\n BEGIN\n ARGS(0, x)\n END P;\n PROCEDURE Main();\n VAR\n buf0: ARRAY 0 OF CHAR;\n buf1: ARRAY 1 OF CHAR;\n buf2: ARRAY 2 OF CHAR;\n buf: ARRAY 10 OF CHAR;\n i: INTEGER;\n r: RECORD a: INTEGER END;\n g: ARRAY 2 OF RECORD buf: ARRAY 2 OF CHAR END;\n BEGIN \n ARGS(1, buf0);\n Print(buf0);\n ARGS(1, buf1);\n Print(buf1);\n ARGS(10, buf);\n Print(buf);\n ARGS(1, buf2);\n Print(buf2);\n\n r.a := 1;\n ARGS(r.a, g[1+i].buf);\n Print(buf2);\n\n P(buf);\n Print(buf);\n FOR i := 0 TO ARGNUM()-1 DO ARGS(i, buf); Print(buf) END\n END Main;\n \nBEGIN\n WriteInt(ARGNUM());\n WriteLn;\n FOR x := 0 TO ARGNUM()-1 DO ARGS(x, y); Print(y) END\nEND TestCmdLineArgs." }, { "path": "tests/base/TestCmdLineArgs.txt", "content": " 0\n\n\n\nW\nW\nHello\nHello\nWorld!\n" }, { "path": "tests/base/TestConstFunc.Mod", "content": "MODULE TestConstFunc;\n IMPORT SYSTEM;\n CONST\n negReal = -2.5;\n posReal = 3.2;\n posInt = 2;\n a = \"A\";\n intA = 65;\n abs = ABS(negReal);\n odd = ODD(posInt);\n floor = FLOOR(posReal);\n flt = FLT(posInt);\n ord = ORD(a);\n chr = CHR(intA);\n lsl = LSL(intA, posInt);\n asr = ASR(intA, posInt);\n ror = ROR(intA, posInt);\n and = AND(intA, posInt);\n bor = BOR(intA, posInt);\n not = NOT(intA);\n set = {5};\n int = SYSTEM.VAL(INTEGER, set);\n TYPE arr5 = ARRAY 5 OF INTEGER;\n ARR = ARRAY 3 OF INTEGER;\n VAR\n r: REAL; i, j: INTEGER; c: CHAR;\n z: ARRAY 5 OF INTEGER; s: SET;\n y: ARRAY 4 OF ARR;\n\n PROCEDURE WriteBool(b: BOOLEAN);\n BEGIN\n WriteInt(ORD(b))\n END WriteBool;\n\n PROCEDURE LenP(a0: ARRAY OF INTEGER; a1: arr5; VAR a2: ARRAY OF ARR);\n CONST\n (* len0 = LEN(a0); ERROR expression not constant *)\n len1 = LEN(a1);\n len2 = LEN(a2[0]);\n len3 = AND(LEN(a2[0]), 1);\n VAR u: INTEGER;\n BEGIN\n u := 1;\n a2[0][u] := 1;\n WriteInt(len1); WriteInt(LEN(a1));\n WriteInt(len2); WriteInt(LEN(a2[0]));\n WriteInt(len3); WriteInt(AND(LEN(a2[0]), a2[0][u]))\n END LenP;\n\n\n PROCEDURE P;\n CONST\n negReal = -2.5;\n posReal = 3.2;\n posInt = 2;\n a = \"A\";\n intA = 65;\n abs = ABS(negReal);\n odd = ODD(posInt);\n floor = FLOOR(posReal);\n flt = FLT(posInt);\n ord = ORD(a);\n chr = CHR(intA);\n lsl = LSL(intA, posInt);\n asr = ASR(intA, posInt);\n ror = ROR(intA, posInt);\n and = AND(intA, posInt);\n bor = BOR(intA, posInt);\n not = NOT(intA);\n set = {5};\n int = SYSTEM.VAL(INTEGER, set);\n TYPE arr5 = ARRAY 5 OF INTEGER;\n ARR = ARRAY 3 OF INTEGER;\n VAR\n r: REAL; i, j: INTEGER; c: CHAR;\n z: ARRAY 5 OF INTEGER; s: SET;\n y: ARRAY 4 OF ARR;\n BEGIN\n r := negReal;\n WriteReal(abs); WriteReal(ABS(r)); WriteLn;\n i := posInt;\n WriteBool(odd); WriteBool(ODD(i)); WriteLn;\n r := posReal;\n WriteInt(floor); WriteInt(FLOOR(r)); WriteLn;\n i := posInt;\n WriteReal(flt); WriteReal(FLT(i)); WriteLn;\n c := a;\n WriteInt(ord); WriteInt(ORD(c)); WriteLn;\n i := intA;\n WriteChar(chr); WriteChar(CHR(i)); WriteLn;\n LenP(z, z, y); WriteLn;\n i := intA;\n j := posInt;\n WriteInt(lsl); WriteInt(LSL(i, j)); WriteLn;\n WriteInt(asr); WriteInt(ASR(i, j)); WriteLn;\n WriteInt(ror); WriteInt(ROR(i, j)); WriteLn;\n WriteInt(and); WriteInt(AND(i, j)); WriteLn;\n WriteInt(bor); WriteInt(BOR(i, j)); WriteLn;\n WriteInt(not); WriteInt(NOT(i)); WriteLn;\n s := set;\n WriteInt(int); WriteInt(SYSTEM.VAL(INTEGER, s)); WriteLn;\n END P;\n\nBEGIN\n r := negReal;\n WriteReal(abs); WriteReal(ABS(r)); WriteLn;\n i := posInt;\n WriteBool(odd); WriteBool(ODD(i)); WriteLn;\n r := posReal;\n WriteInt(floor); WriteInt(FLOOR(r)); WriteLn;\n i := posInt;\n WriteReal(flt); WriteReal(FLT(i)); WriteLn;\n c := a;\n WriteInt(ord); WriteInt(ORD(c)); WriteLn;\n i := intA;\n WriteChar(chr); WriteChar(CHR(i)); WriteLn;\n LenP(z, z, y); WriteLn;\n i := intA;\n j := posInt;\n WriteInt(lsl); WriteInt(LSL(i, j)); WriteLn;\n WriteInt(asr); WriteInt(ASR(i, j)); WriteLn;\n WriteInt(ror); WriteInt(ROR(i, j)); WriteLn;\n WriteInt(and); WriteInt(AND(i, j)); WriteLn;\n WriteInt(bor); WriteInt(BOR(i, j)); WriteLn;\n WriteInt(not); WriteInt(NOT(i)); WriteLn;\n s := set;\n WriteInt(int); WriteInt(SYSTEM.VAL(INTEGER, s)); WriteLn;\n P\nEND TestConstFunc." }, { "path": "tests/base/TestConstFunc.txt", "content": " 2.500000 2.500000\n 0 0\n 3 3\n 2.000000 2.000000\n 65 65\nAA\n 5 5 3 3 1 1\n 260 260\n 16 16\n 1073741840 1073741840\n 0 0\n 67 67\n -66 -66\n 32 32\n 2.500000 2.500000\n 0 0\n 3 3\n 2.000000 2.000000\n 65 65\nAA\n 5 5 3 3 1 1\n 260 260\n 16 16\n 1073741840 1073741840\n 0 0\n 67 67\n -66 -66\n 32 32\n" }, { "path": "tests/base/TestCyclicImport00A.Mod", "content": "MODULE TestCyclicImport00;\n TYPE R0* = RECORD k*: INTEGER END;\nEND TestCyclicImport00.\n" }, { "path": "tests/base/TestCyclicImport00B.Mod", "content": "MODULE TestCyclicImport00;\n IMPORT TestCyclicImport01;\n\n TYPE R0* = RECORD k*: INTEGER END;\n VAR\n r1: TestCyclicImport01.R1;\nBEGIN\n r1.x := 1\nEND TestCyclicImport00.\n" }, { "path": "tests/base/TestCyclicImport01A.Mod", "content": "MODULE TestCyclicImport01;\n IMPORT TestCyclicImport00;\n\n TYPE R1* = RECORD x*: INTEGER END;\n VAR\n r0: TestCyclicImport00.R0;\nBEGIN\n r0.k := 2\nEND TestCyclicImport01.\n" }, { "path": "tests/base/TestCyclicImport01B.Mod", "content": "MODULE TestCyclicImport01;\n IMPORT TestCyclicImport00;\n\n TYPE R1* = RECORD x*: INTEGER END;\n VAR\n r0*: TestCyclicImport00.R0; (* re-export R0*)\nBEGIN\n r0.k := 2\nEND TestCyclicImport01.\n" }, { "path": "tests/base/TestCyclicImport10A.Mod", "content": "MODULE TestCyclicImport10;\n TYPE R0* = RECORD k*: INTEGER END;\n\nEND TestCyclicImport10.\n" }, { "path": "tests/base/TestCyclicImport10B.Mod", "content": "MODULE TestCyclicImport10;\n IMPORT TestCyclicImport11;\n\n TYPE R0* = RECORD k*: INTEGER END;\n VAR\n j: INTEGER;\nBEGIN\n j := TestCyclicImport11.i\nEND TestCyclicImport10.\n" }, { "path": "tests/base/TestCyclicImport11.Mod", "content": "MODULE TestCyclicImport11;\n IMPORT TestCyclicImport12;\n VAR\n i*: INTEGER;\nBEGIN\n i := TestCyclicImport12.w\nEND TestCyclicImport11.\n" }, { "path": "tests/base/TestCyclicImport12.Mod", "content": "MODULE TestCyclicImport12;\n IMPORT TestCyclicImport10;\n VAR\n r0: TestCyclicImport10.R0;\n w*: INTEGER;\nBEGIN\n r0.k := 2;\n w := 8\nEND TestCyclicImport12.\n" }, { "path": "tests/base/TestEqualSignature00.Mod", "content": "MODULE TestEqualSignature00;\n TYPE\n A = RECORD i : INTEGER END;\n B = RECORD(A) k : CHAR END;\n P0 = PROCEDURE(x : ARRAY OF B);\n P1 = PROCEDURE(x : B);\n PTRB = POINTER TO B;\n P2 = PROCEDURE(x : PTRB);\n ARR = ARRAY 10 OF B;\n P3 = PROCEDURE(x : BYTE; y : CHAR; z : ARRAY OF B) : CHAR;\n P4 = PROCEDURE(z : ARR; x : PROCEDURE(z : ARR) : CHAR) : CHAR;\n VAR\n p0: P0;\n p1: P1;\n p2: P2;\n p3: P3;\n p4: P4;\n x : ARRAY 1 OF B;\n pb : PTRB;\n y : ARR;\n\n PROCEDURE H0(x : ARRAY OF B);\n BEGIN\n WriteChar(x[0].k)\n END H0;\n\n PROCEDURE H1(x : B);\n BEGIN\n WriteChar(x.k)\n END H1;\n\n PROCEDURE H2(x : PTRB);\n BEGIN\n WriteChar(x.k)\n END H2;\n\n PROCEDURE H3(x : BYTE; y : CHAR; z : ARRAY OF B) : CHAR;\n RETURN CHR(x+ORD(y)+z[0].i)\n END H3;\n\n PROCEDURE H4(z : ARR; x : PROCEDURE(z : ARR) : CHAR) : CHAR;\n RETURN x(z)\n END H4;\n\n PROCEDURE H5() : CHAR;\n RETURN \"F\"\n END H5;\n PROCEDURE L(u : ARR) : CHAR;\n RETURN u[0].k\n END L;\nBEGIN\n p0 := H0;\n x[0].k := \"A\";\n p0(x); (* A *)\n p1 := H1;\n x[0].k := \"B\";\n p1(x[0]); (* B *)\n p2 := H2;\n NEW(pb);\n pb.k := \"C\";\n p2(pb); (* C *)\n p3 := H3;\n x[0].i := 2;\n WriteChar(p3(1, \"A\", x)); (* D *)\n p4 := H4;\n y[0].k := \"E\";\n WriteChar(p4(y, L)); (* E *)\n WriteChar(H5())\nEND TestEqualSignature00." }, { "path": "tests/base/TestEqualSignature00.txt", "content": "ABCDEF" }, { "path": "tests/base/TestExprVarPar.Mod", "content": "MODULE TestExprVarPar;\n VAR a: INTEGER;\n\n PROCEDURE G(VAR i: INTEGER); END G;\n\nBEGIN\n G(a+1)\nEND TestExprVarPar.\n" }, { "path": "tests/base/TestFor.Mod", "content": "MODULE TestFor;\n CONST minus1 = -1;\n TYPE R0 = RECORD x, y : INTEGER END;\n ARR = ARRAY 5 OF INTEGER;\n VAR i, x: INTEGER;\n r0 : R0;\n v : ARR;\n \n PROCEDURE P3(VAR v3 : ARR);\n BEGIN\n v3[0] := 1; \n r0.x := 4;\n FOR i := r0.x + 3 TO r0.x + 3 + v3[0] + v3[0] DO\n WriteInt(i) \n END;\n END P3;\n \n PROCEDURE P2(VAR k : INTEGER);\n BEGIN\n v[0] := 1; \n r0.x := 4;\n FOR k := r0.x + 3 TO r0.x + 3 + v[0] + v[0] DO\n WriteInt(k) \n END;\n END P2;\n \n PROCEDURE P1(j : INTEGER);\n VAR i1: INTEGER;\n r1 : R0;\n v1 : ARRAY 5 OF INTEGER;\n BEGIN\n FOR i1 := 0 TO 2 BY 1 DO\n WriteInt(i1) \n END;\n x := 3;\n FOR i1 := x TO 5 DO\n WriteInt(i1)\n END;\n j := 8;\n FOR i1 := 6 TO j DO\n WriteInt(i1)\n END;\n FOR i1 := j TO 0 BY minus1 DO\n WriteInt(i1)\n END;\n WriteLn;\n r1.x := 0;\n FOR i1 := r1.x TO 2 DO\n WriteInt(i1) \n END;\n r1.x := 2;\n FOR i1 := 3 TO r1.x + 3 DO\n WriteInt(i1) \n END;\n WriteLn;\n v1[0] := 1; \n r1.x := 4;\n FOR i1 := r1.x + 3 TO r1.x + 3 + v1[0] + v1[0] DO\n WriteInt(i1) \n END;\n END P1;\nBEGIN\n FOR i := 0 TO 2 BY 1 DO\n WriteInt(i) \n END;\n x := 3;\n FOR i := x TO 5 DO\n WriteInt(i)\n END;\n x := 8;\n FOR i := 6 TO x DO\n WriteInt(i)\n END;\n FOR i := x TO 0 BY minus1 DO\n WriteInt(i)\n END;\n WriteLn;\n r0.x := 0;\n FOR i := r0.x TO 2 DO\n WriteInt(i) \n END;\n r0.x := 2;\n FOR i := 3 TO r0.x + 3 DO\n WriteInt(i) \n END;\n WriteLn;\n v[0] := 1; \n r0.x := 4;\n FOR i := r0.x + 3 TO r0.x + 3 + v[0] + v[0] DO\n WriteInt(i) \n END;\n WriteLn;\n P1(0);\n i := 0;\n WriteLn;\n P2(i);\n WriteLn;\n P3(v);\n WriteLn;\nEND TestFor." }, { "path": "tests/base/TestFor.txt", "content": " 0 1 2 3 4 5 6 7 8 8 7 6 5 4 3 2 1 0\n 0 1 2 3 4 5\n 7 8 9\n 0 1 2 3 4 5 6 7 8 8 7 6 5 4 3 2 1 0\n 0 1 2 3 4 5\n 7 8 9\n 7 8 9\n 7 8 9\n" }, { "path": "tests/base/TestFor1.Mod", "content": "MODULE TestFor1;\n VAR v, beg, end : INTEGER;\n \n PROCEDURE For0;\n VAR v, beg, end : INTEGER;\n BEGIN\n beg := 3;\n end := 10;\n FOR v := beg TO end BY 2 DO WriteInt(v) END;\n WriteLn\n END For0;\n \n PROCEDURE For1;\n BEGIN\n beg := 0;\n end := 3;\n FOR v := beg TO end DO WriteInt(v) END;\n WriteLn\n END For1;\n \n PROCEDURE For2(VAR v1, beg1, end1 : INTEGER; v0, beg0, end0 : INTEGER );\n BEGIN\n FOR v1 := beg1 TO end1 BY 2 DO WriteInt(v1) END;\n WriteLn;\n FOR v0 := beg0 TO end0 DO WriteInt(v0) END;\n WriteLn;\n FOR v1 := beg TO end0 DO WriteInt(v1) END;\n WriteLn\n END For2;\n PROCEDURE For4;\n BEGIN\n beg := 10;\n end := 3;\n FOR v := beg TO end BY -1 DO WriteInt(v) END;\n WriteLn\n END For4;\nBEGIN\n For0; For1; For2(v, beg, end, 0, 3, 10); For4\nEND TestFor1." }, { "path": "tests/base/TestFor1.txt", "content": " 3 5 7 9\n 0 1 2 3\n 0 2\n 3 4 5 6 7 8 9 10\n 0 1 2 3 4 5 6 7 8 9 10\n 10 9 8 7 6 5 4 3\n" }, { "path": "tests/base/TestFunction0.Mod", "content": "MODULE TestFunction0;\n VAR x : INTEGER;\n \n PROCEDURE P1(i : INTEGER): INTEGER;\n PROCEDURE P2(j, z : INTEGER) : INTEGER;\n VAR k : INTEGER;\n BEGIN\n k := z;\n RETURN k + j\n END P2;\n BEGIN \n RETURN i + P2(i, 2)\n END P1;\n\nBEGIN\n x := P1(1);\n WriteInt(x);\nEND TestFunction0." }, { "path": "tests/base/TestFunction0.txt", "content": " 4" }, { "path": "tests/base/TestINC0.Mod", "content": "MODULE TestINC0;\n VAR xg : INTEGER;\n yg : BYTE;\n ig : ARRAY 2 OF INTEGER; \n jg : RECORD x : INTEGER END;\n \n PROCEDURE P0(VAR i : INTEGER; VAR j : BYTE);\n BEGIN \n INC(i);\n WriteInt(i); (* 2 *)\n INC(i, 130);\n WriteInt(i); (* 132 *)\n INC(i, -128);\n WriteInt(i); (* 4 *)\n DEC(j);\n WriteInt(j); (* 255 *)\n DEC(j, 130);\n WriteInt(j); (* 125 *)\n INC(j, 4);\n WriteInt(j); (* 129 *)\n DEC(j, -128);\n WriteInt(j) (* 1 *)\n END P0;\n \n \n PROCEDURE P2;\n VAR i : INTEGER; \n j : BYTE;\n BEGIN \n i := 1; j := 0;\n INC(i);\n WriteInt(i); (* 2 *)\n INC(i, 130);\n WriteInt(i); (* 132 *)\n INC(i, -128);\n WriteInt(i); (* 4 *)\n DEC(j);\n WriteInt(j); (* 255 *)\n DEC(j, 130);\n WriteInt(j); (* 125 *)\n INC(j, 4);\n WriteInt(j); (* 129 *)\n DEC(j, -128);\n WriteInt(j) (* 1 *)\n END P2; \n \n PROCEDURE P3(VAR a0 : INTEGER; VAR a1 : ARRAY OF INTEGER);\n VAR i : ARRAY 2 OF INTEGER;\n j : RECORD x : INTEGER END;\n x : INTEGER;\n b : ARRAY 2 OF BYTE;\n BEGIN \n x := 0;\n i[0] := 2; i[1] := 3;\n INC(i[0]);\n WriteInt(i[0]); (* 3 *)\n INC(i[x+1]);\n WriteInt(i[x+1]); (* 4 *)\n \n j.x := 3;\n INC(j.x);\n WriteInt(j.x); (* 4 *)\n \n INC(a0);\n WriteInt(a0); (* 2 *)\n \n x := 0;\n INC(a1[x+1]);\n WriteInt(a1[x+1]); (* 4 *)\n \n INC(ig[0]);\n WriteInt(ig[0]); (* 3 *)\n INC(ig[x+1]);\n WriteInt(ig[x+1]); (* 5 *)\n xg := 0;\n INC(ig[xg+1]);\n WriteInt(ig[xg+1]); (* 6 *)\n jg.x := 6;\n INC(jg.x);\n WriteInt(jg.x); (* 7 *)\n \n INC(a1[xg+1]);\n WriteInt(a1[xg+1]); (* 7 *)\n \n b[1] := 10;\n INC(b[x+1]);\n WriteInt(b[x+1]); (* 11 *)\n \n i[0] := 2; i[1] := 3;\n INC(i[0], 7);\n WriteInt(i[0]); (* 9 *)\n INC(i[x+1], 7);\n WriteInt(i[x+1]); (* 10 *)\n \n j.x := 3;\n INC(j.x, 2);\n WriteInt(j.x); (* 5 *)\n x := 98;\n a0 := 1;\n INC(a0, x);\n WriteInt(a0); (* 99 *)\n x := 0;\n a1[x+1] := 80;\n xg := 20;\n INC(a1[x+1], xg);\n WriteInt(a1[x+1]); (* 100 *)\n x := 3;\n DEC(x, -1);\n WriteInt(x); (* 4 *)\n END P3; \n\n PROCEDURE P4(VAR a0 : INTEGER; VAR a1 : ARRAY OF INTEGER);\n VAR i : ARRAY 2 OF INTEGER;\n j : RECORD x : INTEGER END;\n x, r : INTEGER;\n b : ARRAY 2 OF BYTE;\n BEGIN\n x := 0;\n r := 0;\n i[0] := 2; i[1] := 3;\n\n INC(r, i[0]);\n WriteInt(r); (* 2 *)\n INC(r, i[x+1]);\n WriteInt(r); (* 5 *)\n\n j.x := 3;\n\n INC(r, j.x);\n WriteInt(r); (* 8 *)\n INC(r, a0);\n WriteInt(r); (* 9 *)\n\n x := 0;\n\n INC(r, a1[x+1]);\n WriteInt(r); (* 12 *)\n INC(r, ig[0]);\n WriteInt(r); (* 14 *)\n INC(r, ig[x+1]);\n WriteInt(r); (* 17 *)\n\n xg := 0;\n\n INC(r, ig[xg+1]);\n WriteInt(r); (* 20 *)\n\n jg.x := 6;\n\n INC(r, jg.x);\n WriteInt(r); (* 26 *)\n INC(r, a1[xg+1]);\n WriteInt(r); (* 29 *)\n\n b[1] := 10;\n\n INC(r, b[x+1]);\n WriteInt(r); (* 39 *)\n INC(r, 1+b[x+1]);\n WriteInt(r); (* 50 *)\n INC(r, b[x+1]+1);\n WriteInt(r); (* 61 *)\n END P4;\nBEGIN\n xg := 1;\n yg := 0;\n P0(xg, yg);\n WriteLn;\n P2;\n WriteLn;\n xg := 1;\n ig[0] := 2; ig[1] := 3;\n P3(xg, ig);\n WriteLn;\n xg := 1;\n ig[0] := 2; ig[1] := 3;\n P4(xg, ig)\nEND TestINC0." }, { "path": "tests/base/TestINC0.txt", "content": " 2 132 4 255 125 129 1\n 2 132 4 255 125 129 1\n 3 4 4 2 4 3 5 6 7 7 11 9 10 5 99 100 4\n 2 5 8 9 12 14 17 20 26 29 39 50 61" }, { "path": "tests/base/TestINC1.Mod", "content": "MODULE TestINC1;\n VAR k: INTEGER;\n i: ARRAY 2 OF RECORD b : BYTE END;\n j: ARRAY 20 OF BYTE;\n x: BYTE;\n PROCEDURE Effect(VAR x : BYTE) : INTEGER;\n BEGIN \n WriteInt(x); (* 7 *)\n INC(k); \n RETURN 0\n END Effect;\n\n PROCEDURE CallMe(VAR x : BYTE) : INTEGER;\n BEGIN\n RETURN x\n END CallMe;\n\n PROCEDURE P;\n VAR i: ARRAY 2 OF RECORD b : BYTE END;\n j: ARRAY 20 OF BYTE;\n x: BYTE;\n BEGIN \n i[0].b := 6;\n x := 10;\n k := 0;\n j[x+5] := 7;\n INC(i[Effect(j[x+5])].b, 2);\n WriteInt(k); (* 1 *)\n WriteInt(i[0].b); (* 8 *)\n INC(i[0].b, j[x+5]);\n WriteInt(i[0].b); (* 15 *)\n INC(j[x+5], i[0].b);\n WriteInt(j[x+5]); (* 22 *)\n INC(x, CallMe(i[0].b));\n WriteInt(x); (* 25 *)\n END P; \n \nBEGIN\n P;\n WriteLn;\n i[0].b := 6;\n x := 10;\n k := 0;\n j[x+5] := 7;\n INC(i[Effect(j[x+5])].b, 2);\n WriteInt(k); (* 1 *)\n WriteInt(i[0].b); (* 8 *)\n INC(i[0].b, j[x+5]);\n WriteInt(i[0].b); (* 15 *)\n INC(j[x+5], i[0].b);\n WriteInt(j[x+5]); (* 22 *)\n INC(x, CallMe(i[0].b));\n WriteInt(x) (* 25 *)\nEND TestINC1." }, { "path": "tests/base/TestINC1.txt", "content": " 7 1 8 15 22 25\n 7 1 8 15 22 25" }, { "path": "tests/base/TestINCLAndEXCL.Mod", "content": "MODULE TestINCLAndEXCL;\n CONST K = {1, 2, 3};\n VAR y : SET;\n j,f : INTEGER;\n b : ARRAY 2 OF SET;\n r: RECORD a: ARRAY 2 OF RECORD b: INTEGER END END;\n \n PROCEDURE PrintSet(x : SET);\n VAR i : INTEGER;\n BEGIN\n FOR i:= 0 TO 31 DO\n IF i IN x THEN WriteInt(i) END\n END;\n WriteLn\n END PrintSet;\n\n PROCEDURE P0(a0 : SET; VAR a1 : ARRAY OF SET);\n VAR i : ARRAY 2 OF SET;\n z : RECORD x : SET END;\n x : BYTE;\n BEGIN \n x := 0;\n i[0] := K; \n i[1] := K + {8}; \n INCL(i[0], 8);\n PrintSet(i[0]); (* {1 2 3 8} *)\n EXCL(i[x+1], 1);\n PrintSet(i[x+1]); (* {2 3 8} *)\n \n z.x := K;\n EXCL(z.x, 2);\n PrintSet(z.x); (* {1 3} *)\n \n EXCL(a0, 2);\n PrintSet(a0); (* {1 3} *)\n \n EXCL(a1[x+1], 3);\n PrintSet(a1[x+1]); (* {1 2} *)\n \n j := 0;\n INCL(a1[j+1], 3);\n PrintSet(a1[j+1]); (* {1 2 3} *)\n INCL(a0, 8+x);\n PrintSet(a0); (* {1 3 8} *)\n END P0; \n \n PROCEDURE Effect(VAR x : BYTE) : INTEGER;\n BEGIN \n WriteInt(x); (* 7 *)\n INC(f); \n RETURN 0\n END Effect;\n \n PROCEDURE P1;\n VAR i : ARRAY 2 OF RECORD b : SET END;\n j : ARRAY 20 OF BYTE;\n z : ARRAY 20 OF BYTE;\n x : BYTE;\n BEGIN \n i[0].b := K;\n x := 10;\n f := 0;\n j[x+5] := 7;\n EXCL(i[Effect(j[x+5])].b, 2);\n WriteInt(f); (* 1 *)\n PrintSet(i[0].b); (* {1 3} *)\n z[x+1] := 8;\n INCL(i[Effect(j[x+5])].b, z[x+1]);\n WriteInt(f); (* 2 *)\n PrintSet(i[0].b); (* {1 3 8} *)\n z[2+x] := 10;\n INCL(i[Effect(j[x+5])].b, z[x+1] + z[2+x]);\n WriteInt(f); (* 3 *)\n PrintSet(i[0].b); (* {1 3 8 18} *)\n END P1; \n\n\n PROCEDURE P2(VAR a0 : SET);\n VAR x : BYTE;\n BEGIN\n x := 1;\n INCL(a0, 8+x);\n PrintSet(a0); (* {2 9} *)\n END P2;\n\nBEGIN\n y := K;\n EXCL(y, 2); (* {1 3} *)\n PrintSet(y);\n y := K;\n j := 1;\n r.a[-1+j].b := 2;\n EXCL(y, r.a[-1+j].b); (* {1 3} *)\n PrintSet(y);\n j := 2;\n y := K;\n EXCL(y, j);\n PrintSet(y); (* {1 3} *)\n b[j - 1] := K;\n EXCL(b[j - 1], j); (* {1 3} *)\n PrintSet(b[j - 1]);\n y := K;\n b[1] := K;\n P0(y, b);\n P1;\n y := {2};\n P2(y)\nEND TestINCLAndEXCL." }, { "path": "tests/base/TestINCLAndEXCL.txt", "content": " 1 3\n 1 3\n 1 3\n 1 3\n 1 2 3 8\n 2 3 8\n 1 3\n 1 3\n 1 2\n 1 2 3\n 1 3 8\n 7 1 1 3\n 7 2 1 3 8\n 7 3 1 3 8 18\n 2 9\n" }, { "path": "tests/base/TestImport00.Mod", "content": "MODULE TestImport00;\nCONST N* = 100;\nTYPE\n Ptr* = POINTER TO Rec;\n Rec* = RECORD n*: INTEGER; p: Ptr END ;\n Rec2 = RECORD o*: INTEGER; p: Ptr END ;\nVAR\n k*: INTEGER;\n a*: ARRAY N OF INTEGER;\n b0*: ARRAY N OF RECORD t* : Rec2 END;\n b1*: ARRAY N OF Rec;\n PROCEDURE P*(x: INTEGER): INTEGER; RETURN 3 END P;\nBEGIN\n k := 1;\n a[2] := 2;\n b0[1].t.o := 10;\n b1[1].n := 20\nEND TestImport00." }, { "path": "tests/base/TestImport00.txt", "content": "" }, { "path": "tests/base/TestImport01.Mod", "content": "MODULE TestImport01;\nIMPORT TestImport00;\nVAR\n k1: INTEGER;\n a1: ARRAY TestImport00.N OF INTEGER;\n p: TestImport00.Ptr;\nBEGIN\n p := NIL;\n k1 := TestImport00.k;\n WriteInt(TestImport00.N);\n WriteInt(k1);\n a1 := TestImport00.a;\n WriteInt(a1[2]);\n k1 := TestImport00.P(TestImport00.k);\n WriteInt(k1);\n k1 := TestImport00.b0[1].t.o;\n WriteInt(k1);\n k1 := TestImport00.b1[1].n;\n WriteInt(k1);\nEND TestImport01." }, { "path": "tests/base/TestImport01.txt", "content": " 100 1 2 3 10 20" }, { "path": "tests/base/TestImport10.Mod", "content": "MODULE TestImport10;\n CONST\n Ten* = 10; Dollar* = \"$\";\n TYPE\n R* = RECORD u*: INTEGER; v*: SET END ;\n S* = RECORD w*: ARRAY 4 OF R END ;\n P* = POINTER TO R;\n A* = ARRAY 8 OF INTEGER;\n B* = ARRAY 4, 5 OF REAL;\n C* = ARRAY 10 OF S;\n D* = ARRAY 2 OF CHAR;\n VAR x*: INTEGER;\n \n PROCEDURE Q0*;\n BEGIN INC(x, 10) END Q0;\n \n PROCEDURE Q1*(x, y: INTEGER): INTEGER;\n BEGIN RETURN x+y END Q1;\nBEGIN x := 5\nEND TestImport10." }, { "path": "tests/base/TestImport10.txt", "content": "" }, { "path": "tests/base/TestImport100.Mod", "content": "MODULE TestImport100;\n IMPORT S := SYSTEM;\n VAR\n s: SET;\nBEGIN\n s := {1};\n WriteInt(S.VAL(INTEGER, s));\nEND TestImport100." }, { "path": "tests/base/TestImport100.txt", "content": " 2" }, { "path": "tests/base/TestImport11.Mod", "content": "MODULE TestImport11;\nIMPORT I := TestImport10;\n VAR\n r : I.R;\n s : I.S;\n p : I.P;\n a : I.A;\n b : I.B;\n c : I.C;\n d : I.D;\nBEGIN\n WriteInt(I.x); (* 5 *)\n r.v := {1..9};\n IF 6 IN r.v THEN WriteInt(6) END;\n s.w[2].u := 7;\n WriteInt(s.w[2].u); (* 7 *)\n NEW(p);\n p.u := 8;\n WriteInt(p.u); (* 8 *)\n a[4] := 9;\n WriteInt(a[4]); (* 9 *)\n b[1, 2] := 20.0-10.0;\n WriteReal(b[1][2]); (* 10.0 *)\n c[9].w[2].u := 11;\n WriteInt(c[9].w[2].u); (* 11 *)\n WriteLn;\n d[1] := \"A\";\n WriteChar(d[1]); (* A *)\n WriteChar(I.Dollar); (* $ *)\n WriteInt(I.Ten + 1); (* 11, compile time sum *)\n I.Q0;\n WriteInt(I.x); (* 15 *)\n WriteInt(I.Q1(8, 9)) (* 17 *)\nEND TestImport11." }, { "path": "tests/base/TestImport11.txt", "content": " 5 6 7 8 9 10.000000 11\nA$ 11 15 17" }, { "path": "tests/base/TestImport110.Mod", "content": "MODULE TestImport110;\n CONST TEN* = 10;\n TYPE X* = RECORD i*: INTEGER END;\nEND TestImport110." }, { "path": "tests/base/TestImport110.txt", "content": "" }, { "path": "tests/base/TestImport111.Mod", "content": "DEFINITION TestImport111;\n IMPORT TestImport110;\n CONST TWELVE = TestImport110.TEN + 2;\n TYPE Y* = BYTE;\nEND TestImport111.\n" }, { "path": "tests/base/TestImport112.Mod", "content": "MODULE TestImport112;\n IMPORT TestImport110, TestImport111;\n VAR\n x: TestImport110.X;\n y: TestImport111.Y;\n\nBEGIN\n y := TestImport111.TWELVE;\n x.i := y;\n WriteInt(x.i)\nEND TestImport112." }, { "path": "tests/base/TestImport112.txt", "content": " 12" }, { "path": "tests/base/TestImport120.Mod", "content": "MODULE TestImport120;\n TYPE\n TypeA* = INTEGER;\n TypeB* = RECORD b: CHAR END;\nEND TestImport120." }, { "path": "tests/base/TestImport120.txt", "content": "" }, { "path": "tests/base/TestImport121.Mod", "content": "MODULE TestImport121;\n IMPORT I := TestImport120;\n\n TYPE\n TypeC* = I.TypeA;\n TypeD* = I.TypeB;\nEND TestImport121." }, { "path": "tests/base/TestImport121.txt", "content": "" }, { "path": "tests/base/TestImport122.Mod", "content": "MODULE TestImport122;\n IMPORT TestImport121, X := TestImport120;\n\n VAR\n a: X.TypeA;\n b: X.TypeB;\n c: TestImport121.TypeC;\n d: TestImport121.TypeD;\n\nBEGIN\n c := a;\n b := d\nEND TestImport122.\n" }, { "path": "tests/base/TestImport122.txt", "content": "" }, { "path": "tests/base/TestImport130.Mod", "content": "MODULE TestImport130;\n TYPE TypeC* = RECORD a*: CHAR END;\n TypeD* = RECORD(TypeC) d*: BYTE END;\nEND TestImport130.\n" }, { "path": "tests/base/TestImport130.txt", "content": "" }, { "path": "tests/base/TestImport131.Mod", "content": "MODULE TestImport131;\n IMPORT I:=TestImport130, TestImport130;\n VAR\n x: I.TypeD;\n y: TestImport130.TypeD;\n\nBEGIN\n x.a := \"@\";\n x.d := 1;\n y := x;\n WriteChar(y.a); WriteInt(y.d)\nEND TestImport131.\n" }, { "path": "tests/base/TestImport131.txt", "content": "@ 1" }, { "path": "tests/base/TestImport140.Mod", "content": "MODULE TestImport140;\nTYPE\n Rec0* = RECORD\n a*: INTEGER;\n b*: CHAR;\n c*: REAL;\n END ;\n\nEND TestImport140.\n" }, { "path": "tests/base/TestImport140.txt", "content": "" }, { "path": "tests/base/TestImport141.Mod", "content": "MODULE TestImport141;\nIMPORT TestImport140;\nTYPE\n Rec1* = RECORD(TestImport140.Rec0)\n d*: ARRAY 2 OF INTEGER;\n e*: BOOLEAN;\n f*: BYTE;\n END ;\n\nEND TestImport141.\n" }, { "path": "tests/base/TestImport141.txt", "content": "" }, { "path": "tests/base/TestImport142.Mod", "content": "MODULE TestImport142;\nIMPORT I0 := TestImport140, I1 := TestImport141;\n\nTYPE PtrRec1 = POINTER TO I1.Rec1;\n\nVAR\n r0: POINTER TO I0.Rec0;\n r1: PtrRec1;\n\nBEGIN\n NEW(r1);\n r0 := r1;\n IF r0 IS PtrRec1 THEN WriteInt(1) END;\n r1.a := 2;\n r1.b := \"3\";\n r1.c := 4.0;\n r1.d[1] := 5;\n r1.e := TRUE;\n r1.f := 6;\n WriteInt(r1.a);\n WriteChar(r1.b);\n WriteReal(r1.c);\n WriteInt(r1.d[1]);\n WriteInt(ORD(r1.e));\n WriteInt(r1.f)\nEND TestImport142.\n" }, { "path": "tests/base/TestImport142.txt", "content": " 1 23 4.000000 5 1 6" }, { "path": "tests/base/TestImport150.Mod", "content": "MODULE TestImport150;\n TYPE\n Rec150* = RECORD\n a*: INTEGER;\n END ;\n\n PROCEDURE Two*;\n BEGIN\n WriteInt(2); WriteLn\n END Two;\nEND TestImport150." }, { "path": "tests/base/TestImport150.txt", "content": "" }, { "path": "tests/base/TestImport151.Mod", "content": "MODULE TestImport151;\n IMPORT X := TestImport150, Y:= TestImport150, TestImport150;\n TYPE J = TestImport150.Rec150;\n K = Y.Rec150;\n VAR a: Y.Rec150;\n b: X.Rec150;\n c: J;\n d: K;\n\nBEGIN\n a := b;\n c := d;\n X.Two;\n Y.Two;\n TestImport150.Two\nEND TestImport151." }, { "path": "tests/base/TestImport151.txt", "content": " 2\n 2\n 2\n" }, { "path": "tests/base/TestImport20.Mod", "content": "MODULE TestImport20;\n TYPE\n R* = RECORD u*: INTEGER END;\nEND TestImport20." }, { "path": "tests/base/TestImport20.txt", "content": "" }, { "path": "tests/base/TestImport21.Mod", "content": "MODULE TestImport21;\nIMPORT I := TestImport20;\n TYPE\n X* = I.R;\nEND TestImport21." }, { "path": "tests/base/TestImport21.txt", "content": "" }, { "path": "tests/base/TestImport22.Mod", "content": "MODULE TestImport22;\nIMPORT TestImport20, TestImport21;\n VAR\n x : TestImport20.R;\n y : TestImport21.X;\nBEGIN\n x.u := 8;\n y := x;\n WriteInt(y.u);\nEND TestImport22." }, { "path": "tests/base/TestImport22.txt", "content": " 8" }, { "path": "tests/base/TestImport30.Mod", "content": "MODULE TestImport30;\n TYPE T* = RECORD c* : CHAR END;\n VAR x* : T;\nBEGIN x.c := \"A\"\nEND TestImport30." }, { "path": "tests/base/TestImport30.txt", "content": "" }, { "path": "tests/base/TestImport31.Mod", "content": "MODULE TestImport31;\nIMPORT TestImport30;\n VAR y : TestImport30.T;\nBEGIN\n y := TestImport30.x;\n WriteChar(y.c)\nEND TestImport31." }, { "path": "tests/base/TestImport31.txt", "content": "A" }, { "path": "tests/base/TestImport40.Mod", "content": "MODULE TestImport40;\n TYPE T* = RECORD x*: INTEGER END ;\nEND TestImport40." }, { "path": "tests/base/TestImport40.txt", "content": "" }, { "path": "tests/base/TestImport41.Mod", "content": "MODULE TestImport41;\nIMPORT TestImport40;\n PROCEDURE P*(VAR t: TestImport40.T);\n BEGIN WriteInt(t.x)\n END P;\nEND TestImport41." }, { "path": "tests/base/TestImport41.txt", "content": "" }, { "path": "tests/base/TestImport42.Mod", "content": "MODULE TestImport42;\nIMPORT TestImport40, TestImport41;\n VAR r: TestImport40.T;\nBEGIN\n r.x := 8;\n TestImport41.P(r)\nEND TestImport42." }, { "path": "tests/base/TestImport42.txt", "content": " 8" }, { "path": "tests/base/TestImport50.Mod", "content": "MODULE TestImport50;\n TYPE T* = RECORD x*: INTEGER END ;\nEND TestImport50." }, { "path": "tests/base/TestImport50.txt", "content": "" }, { "path": "tests/base/TestImport51.Mod", "content": "MODULE TestImport51;\nIMPORT TestImport50;\n TYPE T* = PROCEDURE (VAR u: TestImport50.T);\n T1* = PROCEDURE (u: TestImport50.T);\nEND TestImport51." }, { "path": "tests/base/TestImport51.txt", "content": "" }, { "path": "tests/base/TestImport52.Mod", "content": "MODULE TestImport52;\nIMPORT TestImport50;\n TYPE T* = PROCEDURE (VAR u: TestImport50.T);\n T1* = PROCEDURE (u: TestImport50.T);\nEND TestImport52." }, { "path": "tests/base/TestImport52.txt", "content": "" }, { "path": "tests/base/TestImport53.Mod", "content": "MODULE TestImport53;\nIMPORT TestImport51, TestImport52; (*twice hidden import of TestImport50.T*)\n VAR\n p0: TestImport51.T;\n p1: TestImport52.T;\n p2: TestImport51.T1;\n p3: TestImport52.T1;\nBEGIN\n p0 := p1;\n p2 := p3;\nEND TestImport53." }, { "path": "tests/base/TestImport53.txt", "content": "" }, { "path": "tests/base/TestImport60.Mod", "content": "MODULE TestImport60;\n CONST\n PI* = 3.14;\n N* = -999999999;\n TYPE\n R0* = RECORD x: INTEGER END ;\n P0* = POINTER TO R0;\nEND TestImport60." }, { "path": "tests/base/TestImport60.txt", "content": "" }, { "path": "tests/base/TestImport61.Mod", "content": "MODULE TestImport61;\nIMPORT TestImport60;\n TYPE\n P1* = POINTER TO R1;\n R1* = RECORD(TestImport60.R0) y* : CHAR END;\nEND TestImport61." }, { "path": "tests/base/TestImport61.txt", "content": "" }, { "path": "tests/base/TestImport62.Mod", "content": "MODULE TestImport62;\nIMPORT TestImport60, TestImport61;\n VAR p1* : TestImport61.P1;\nBEGIN\n NEW(p1);\n p1.y := \"A\";\n WriteChar(p1.y);\n IF p1 IS TestImport61.P1 THEN WriteChar(\"Y\") END;\n WriteReal(TestImport60.PI);\n WriteInt(TestImport60.N)\nEND TestImport62." }, { "path": "tests/base/TestImport62.txt", "content": "AY 3.140000 -999999999" }, { "path": "tests/base/TestImport70.Mod", "content": "MODULE TestImport70;\nTYPE\n Key = BYTE;\n ItemDesc* = RECORD\n key*: Key;\n END;\nEND TestImport70." }, { "path": "tests/base/TestImport70.txt", "content": "" }, { "path": "tests/base/TestImport71.Mod", "content": "MODULE TestImport71;\nIMPORT Qs := TestImport70;\nTYPE\n ActorDesc* = RECORD (Qs.ItemDesc) END;\nVAR a: POINTER TO ActorDesc;\nBEGIN NEW(a); a.key := 1; WriteInt(a.key)\nEND TestImport71." }, { "path": "tests/base/TestImport71.txt", "content": " 1" }, { "path": "tests/base/TestImport80.Mod", "content": "MODULE TestImport80;\n IMPORT I := TestImport81, TestImport82;\n\n VAR\n b: I.TypeB;\n c: TestImport82.TypeC;\n\nBEGIN\n c := b\nEND TestImport80.\n" }, { "path": "tests/base/TestImport80.txt", "content": "" }, { "path": "tests/base/TestImport81.Mod", "content": "MODULE TestImport81;\n TYPE TypeB* = RECORD END;\nEND TestImport81.\n" }, { "path": "tests/base/TestImport81.txt", "content": "" }, { "path": "tests/base/TestImport82.Mod", "content": "MODULE TestImport82;\n IMPORT I := TestImport81;\n\n TYPE TypeC* = I.TypeB;\nEND TestImport82.\n" }, { "path": "tests/base/TestImport82.txt", "content": "" }, { "path": "tests/base/TestImport90.Mod", "content": "MODULE TestImport90;\n CONST h* = \"Hello\";\n x* = \"!\";\nEND TestImport90.\n" }, { "path": "tests/base/TestImport90.txt", "content": "" }, { "path": "tests/base/TestImport91.Mod", "content": "MODULE TestImport91;\n IMPORT imp := TestImport90;\n VAR i: INTEGER;\n str: ARRAY 10 OF CHAR;\nBEGIN\n str := imp.h;\n i := 0;\n WHILE str[i] # 0X DO\n WriteChar(str[i]);\n INC(i)\n END ;\n WriteChar(imp.x);\n WriteLn\nEND TestImport91." }, { "path": "tests/base/TestImport91.txt", "content": "Hello!\n" }, { "path": "tests/base/TestMath.Mod", "content": "MODULE TestMath;\n IMPORT Math;\n VAR x: REAL;\n\nBEGIN\n x := Math.pi;\n x := Math.e;\n x := 0.7;\n WriteReal(Math.sqrt(x)); WriteLn;\n WriteReal(Math.power(2.0, x)); WriteLn;\n WriteReal(Math.exp(x)); WriteLn;\n WriteReal(Math.ln(x)); WriteLn;\n WriteReal(Math.log(x, 2.0)); WriteLn;\n WriteReal(Math.round(x)); WriteLn;\n WriteReal(Math.sin(x)); WriteLn;\n WriteReal(Math.cos(x)); WriteLn;\n WriteReal(Math.tan(x)); WriteLn;\n WriteReal(Math.arcsin(x)); WriteLn;\n WriteReal(Math.arccos(x)); WriteLn;\n WriteReal(Math.arctan(x)); WriteLn;\n WriteReal(Math.arctan2(x, 0.3)); WriteLn;\n WriteReal(Math.sinh(x)); WriteLn;\n WriteReal(Math.cosh(x)); WriteLn;\n WriteReal(Math.tanh(x)); WriteLn;\n WriteReal(Math.arcsinh(x)); WriteLn;\n WriteReal(Math.arccosh(1.0 + x)); WriteLn;\n WriteReal(Math.arctanh(x)); WriteLn\nEND TestMath." }, { "path": "tests/base/TestMath.txt", "content": " 0.836660\n 0.490000\n 2.013753\n -0.356675\n -0.514573\n 1.000000\n 0.644218\n 0.764842\n 0.842288\n 0.775397\n 0.795399\n 0.610726\n 1.165905\n 0.758584\n 1.255169\n 0.604368\n 0.652667\n 1.123231\n 0.867301\n" }, { "path": "tests/base/TestNestedProcs.Mod", "content": "MODULE TestNestedProcs;\n PROCEDURE Outer(n: INTEGER);\n PROCEDURE Inner(n: CHAR);\n BEGIN\n Outer(ORD(n)-1)\n END Inner;\n BEGIN\n IF n > 0 THEN Inner(CHR(n)) END;\n WriteInt(n)\n END Outer;\nBEGIN\n Outer(3)\nEND TestNestedProcs." }, { "path": "tests/base/TestNestedProcs.txt", "content": " 0 1 2 3" }, { "path": "tests/base/TestODD.Mod", "content": "MODULE TestODD;\n VAR x: INTEGER;\n y: SET;\n \nBEGIN\n x := 14;\n y := {1..20};\n IF ODD(8) THEN WriteInt(1) END;\n IF ODD(9) THEN WriteInt(2) END;\n IF ~ODD(8) THEN WriteInt(3) END;\n IF ODD(x) OR (x IN y) & (x > 8) THEN WriteInt(4) END\nEND TestODD." }, { "path": "tests/base/TestODD.txt", "content": " 2 3 4" }, { "path": "tests/base/TestOOP.Mod", "content": "MODULE TestOOP;\n CONST PI = 3.13;\n\n PROCEDURE oopType0;\n TYPE\n Shape = POINTER TO ShapeDesc;\n Rectangle = POINTER TO RectangleDesc;\n Circle = POINTER TO CircleDesc;\n ShapeDesc = RECORD\n name : CHAR;\n area : PROCEDURE (s : Shape) : REAL;\n END;\n RectangleDesc = RECORD (ShapeDesc) l, w : REAL END;\n CircleDesc = RECORD (ShapeDesc) r : REAL END; \n VAR\n shape : Shape;\n \n PROCEDURE RectArea(s : Shape) : REAL;\n VAR area : REAL;\n BEGIN\n CASE s OF Rectangle:\n area := s.l * s.w;\n END;\n RETURN area\n END RectArea;\n\n PROCEDURE CircleArea(s : Shape) : REAL;\n RETURN s(Circle).r * s(Circle).r * PI\n END CircleArea;\n\n PROCEDURE newRect() : Rectangle;\n VAR rect : Rectangle;\n BEGIN\n NEW(rect); rect.name := \"R\";\n rect.l := 10.0; rect.w := 2.2;\n rect.area := RectArea;\n RETURN rect\n END newRect;\n\n PROCEDURE newCircle() : Circle;\n VAR circ : Circle;\n BEGIN\n NEW(circ); circ.name := \"C\";\n circ.r := 8.4; circ.area := CircleArea;\n RETURN circ\n END newCircle;\n BEGIN\n shape := newRect();\n WriteChar(shape.name);\n WriteChar(\" \");\n WriteReal(shape.area(shape));\n WriteLn;\n shape := newCircle();\n WriteChar(shape.name);\n WriteChar(\" \");\n WriteReal(shape.area(shape))\n END oopType0; \n\n PROCEDURE oopType1;\n TYPE\n Shape1 = POINTER TO ShapeDesc1;\n Rectangle1 = POINTER TO RectangleDesc1;\n Circle1 = POINTER TO CircleDesc1;\n Message = RECORD END;\n Handler = PROCEDURE (s: Shape1; VAR msg: Message);\n AreaMsg = RECORD (Message) area : REAL END ;\n ShapeDesc1 = RECORD\n name : CHAR;\n handle : Handler;\n END;\n RectangleDesc1 = RECORD (ShapeDesc1) l, w : REAL END;\n CircleDesc1 = RECORD (ShapeDesc1) r : REAL END;\n VAR\n shape : Shape1;\n area : AreaMsg;\n \n PROCEDURE RectHandler(s : Shape1; VAR msg: Message);\n VAR r : Rectangle1;\n BEGIN\n r := s(Rectangle1);\n CASE msg OF AreaMsg:\n msg.area := r.l * r.w;\n END\n END RectHandler;\n \n PROCEDURE CircleHandler(s : Shape1; VAR msg: Message);\n VAR c : Circle1;\n BEGIN\n c := s(Circle1);\n IF msg IS AreaMsg THEN msg(AreaMsg).area := c.r * c.r * PI END\n END CircleHandler;\n \n PROCEDURE newRect1() : Rectangle1;\n VAR rect : Rectangle1;\n BEGIN\n NEW(rect); rect.name := \"R\";\n rect.l := 10.0; rect.w := 2.2;\n rect.handle := RectHandler;\n RETURN rect\n END newRect1;\n\n PROCEDURE newCircle1() : Circle1;\n VAR circ : Circle1;\n BEGIN\n NEW(circ); circ.name := \"C\";\n circ.r := 8.4; circ.handle := CircleHandler;\n RETURN circ\n END newCircle1;\n \n BEGIN\n shape := newRect1();\n WriteChar(shape.name);\n WriteChar(\" \");\n shape.handle(shape, area);\n WriteReal(area.area);\n WriteLn;\n shape := newCircle1();\n WriteChar(shape.name);\n WriteChar(\" \");\n shape.handle(shape, area);\n WriteReal(area.area)\n END oopType1;\n\n PROCEDURE oopType2;\n TYPE\n Shape2 = POINTER TO ShapeDesc2;\n Rectangle2 = POINTER TO RectangleDesc2;\n Circle2 = POINTER TO CircleDesc2;\n Method = POINTER TO MethodDesc;\n MethodDesc = RECORD\n area: PROCEDURE (s : Shape2) : REAL;\n END;\n ShapeDesc2 = RECORD\n name : CHAR;\n do : Method;\n END;\n RectangleDesc2 = RECORD (ShapeDesc2) l, w : REAL END;\n CircleDesc2 = RECORD (ShapeDesc2) r : REAL END;\n VAR\n shape : Shape2;\n \n PROCEDURE RectArea2(s : Shape2) : REAL;\n VAR r : Rectangle2;\n BEGIN\n r := s(Rectangle2);\n RETURN r.l * r.w\n END RectArea2;\n \n PROCEDURE CircleArea2(s : Shape2) : REAL;\n VAR c : Circle2;\n BEGIN\n c := s(Circle2);\n RETURN c.r * c.r * PI\n END CircleArea2;\n \n PROCEDURE newRect2() : Rectangle2;\n VAR rect : Rectangle2;\n BEGIN\n NEW(rect); rect.name := \"R\";\n rect.l := 10.0; rect.w := 2.2;\n (* This should be initialized in the module body\n so the below 2 statements would be just\n rect.do := RectMethod, where RectMethod is the\n initialized global *)\n NEW(rect.do);\n rect.do.area := RectArea2;\n RETURN rect\n END newRect2;\n\n PROCEDURE newCircle2() : Circle2;\n VAR circ : Circle2;\n BEGIN\n NEW(circ); circ.name := \"C\";\n circ.r := 8.4;\n (* This should be initialized in the module body\n so the below 2 statements would be just\n circ.do := CircleMethod, where CircleMethod is the\n initialized global *)\n NEW(circ.do);\n circ.do.area := CircleArea2;\n RETURN circ\n END newCircle2;\n \n BEGIN\n shape := newRect2();\n WriteChar(shape.name);\n WriteChar(\" \");\n WriteReal(shape.do.area(shape));\n WriteLn;\n shape := newCircle2();\n WriteChar(shape.name);\n WriteChar(\" \");\n WriteReal(shape.do.area(shape));\n END oopType2;\n \nBEGIN\n oopType0;\n WriteLn;\n oopType1;\n WriteLn;\n oopType2\nEND TestOOP." }, { "path": "tests/base/TestOOP.txt", "content": "R 22.000000\nC 220.852783\nR 22.000000\nC 220.852783\nR 22.000000\nC 220.852783" }, { "path": "tests/base/TestReadOnlyPar.Mod", "content": "MODULE TestReadOnlyPar;\n TYPE ARR = ARRAY 3 OF INTEGER;\n\n PROCEDURE P2(VAR e : ARRAY OF INTEGER);\n END P2;\n \n PROCEDURE P3(VAR e : ARR);\n END P3;\n \n PROCEDURE P1(k : ARR);\n BEGIN\n P2(k); (*read-only*)\n P3(k) (*read-only*)\n END P1;\n \nEND TestReadOnlyPar." }, { "path": "tests/base/TestReturn0.Mod", "content": "MODULE TestReturn0;\n VAR x: INTEGER;\n \n PROCEDURE P1(): INTEGER;\n BEGIN RETURN x\n END P1;\n\n PROCEDURE P2(): INTEGER;\n RETURN x\n END P2;\n\n PROCEDURE P3(): INTEGER;\n VAR dummy: INTEGER;\n RETURN x+dummy\n END P3;\nBEGIN\n x := 1;\n WriteInt(P1());\n WriteInt(P2());\n WriteInt(P3());\nEND TestReturn0.\n" }, { "path": "tests/base/TestReturn0.txt", "content": " 1 1 1" }, { "path": "tests/base/TestShift.Mod", "content": "MODULE TestShift;\n VAR x : INTEGER;\n \nBEGIN\n x := 8;\n WriteInt(LSL(x, x DIV 4));\n WriteInt(ASR(x, 1));\n WriteInt(ROR(65280, x))\nEND TestShift." }, { "path": "tests/base/TestShift.txt", "content": " 32 4 255" }, { "path": "tests/base/TestStringsMod.Mod", "content": "MODULE TestStringsMod;\nIMPORT Strings;\n\n VAR l: INTEGER; \n buf, tmp: ARRAY 30 OF CHAR;\n buf0, tmp0: ARRAY 0 OF CHAR;\n buf2: ARRAY 2 OF CHAR;\n buf3: ARRAY 3 OF CHAR;\n buf8: ARRAY 8 OF CHAR;\n\n PROCEDURE Print(x : ARRAY OF CHAR);\n VAR i,j : INTEGER;\n BEGIN\n i := 0;\n j := LEN(x);\n WriteChar(\"'\");\n WHILE (i < j) & (x[i] # 0X) DO\n WriteChar(x[i]);\n INC(i)\n END;\n WriteChar(\"'\");\n WriteLn\n END Print;\n \nBEGIN\n Strings.Append(\"Hello...\", buf);\n Strings.Append(\" World!\", buf);\n Print(buf);\n Strings.Insert(\"cruel\", 8, buf);\n Print(buf);\n Strings.Delete(buf, 8, Strings.Length(\"cruel\"));\n l := Strings.Pos(\"Worl\", buf, 0);\n Strings.Extract(buf, l, 5, tmp);\n Strings.Cap(tmp);\n Print(tmp);\n Strings.Replace(tmp, l, buf);\n Print(buf);\n buf[0] := 0X;\n tmp[0] := 0X;\n Strings.Append(\"Hello...\", buf0);\n Strings.Append(\" World!\", buf0);\n Print(buf0);\n Strings.Insert(\"cruel\", 8, buf0);\n Print(buf0);\n Strings.Delete(buf0, 8, Strings.Length(\"cruel\"));\n l := Strings.Pos(\"Worl\", buf0, 0);\n Strings.Extract(buf0, l, 5, tmp);\n Strings.Cap(tmp);\n Print(tmp);\n Strings.Replace(tmp, l, buf0);\n Print(buf0);\n Strings.Append(\"Hello...\", buf);\n Strings.Append(\" World!\", buf);\n Print(buf);\n Strings.Insert(\"cruel\", 8, buf);\n Print(buf);\n Strings.Delete(buf, 8, Strings.Length(\"cruel\"));\n l := Strings.Pos(\"Worl\", buf, 0);\n Strings.Extract(buf, l, 5, tmp0);\n Strings.Cap(tmp0);\n Print(tmp0);\n Strings.Replace(tmp0, l, buf);\n Print(buf);\n Strings.Append(\"Hello...\", buf0);\n Strings.Append(\" World!\", buf0);\n Print(buf0);\n Strings.Insert(\"cruel\", 8, buf0);\n Print(buf0);\n Strings.Delete(buf0, 8, Strings.Length(\"cruel\"));\n l := Strings.Pos(\"Worl\", buf0, 0);\n Strings.Extract(buf0, l, 5, tmp0);\n Strings.Cap(tmp0);\n Print(tmp0);\n Strings.Replace(tmp0, l, buf0);\n Print(buf0);\n Strings.Copy(\"House\", buf0);\n Print(buf0);\n Strings.Copy(\"House\", buf);\n Print(buf);\n buf2[0] := \"A\";\n buf2[1] := \"B\";\n Print(buf2);\n Strings.Copy(\"House\", buf2);\n Print(buf2);\n Strings.AppendChar(\"$\", buf0);\n Print(buf0);\n Strings.AppendChar(\"$\", buf2);\n Print(buf2);\n Strings.AppendChar(\"$\", buf);\n Print(buf);\n\n buf3[0] := 0X;\n Strings.AppendInt(-2, -1, buf3);\n Print(buf3); (* '-2' *)\n buf3[0] := 0X;\n Strings.AppendInt(-2, 0, buf3);\n Print(buf3); (* '-2' *)\n buf3[0] := 0X;\n Strings.AppendInt(-2, 1, buf3);\n Print(buf3); (* '-2' *)\n buf3[0] := 0X;\n Strings.AppendInt(-2, 2, buf3);\n Print(buf3); (* '-2' *)\n\n buf3[0] := 0X;\n Strings.AppendInt(2, -1, buf3);\n Print(buf3); (* '2' *)\n buf3[0] := 0X;\n Strings.AppendInt(2, 0, buf3);\n Print(buf3); (* '2' *)\n buf3[0] := 0X;\n Strings.AppendInt(2, 1, buf3);\n Print(buf3); (* '2' *)\n buf3[0] := 0X;\n Strings.AppendInt(2, 2, buf3);\n Print(buf3); (* ' 2' *)\n\n buf3[0] := 0X;\n Strings.AppendInt(20, -1, buf3);\n Print(buf3); (* '20' *)\n buf3[0] := 0X;\n Strings.AppendInt(20, 0, buf3);\n Print(buf3); (* '20' *)\n buf3[0] := 0X;\n Strings.AppendInt(20, 1, buf3);\n Print(buf3); (* '20' *)\n buf3[0] := 0X;\n Strings.AppendInt(20, 2, buf3);\n Print(buf3); (* '20' *)\n\n buf3[0] := 0X;\n Strings.AppendInt(-20, -1, buf3);\n Print(buf3); (* '' *)\n buf3[0] := 0X;\n Strings.AppendInt(-20, 0, buf3);\n Print(buf3); (* '' *)\n buf3[0] := 0X;\n Strings.AppendInt(-20, 1, buf3);\n Print(buf3); (* '' *)\n buf3[0] := 0X;\n Strings.AppendInt(-20, 2, buf3);\n Print(buf3); (* '' *)\n \n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-2, -1, buf8);\n Print(buf8); (* 'XXXXX-2' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-2, 0, buf8);\n Print(buf8); (* 'XXXXX-2' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-2, 1, buf8);\n Print(buf8); (* 'XXXXX-2' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-2, 2, buf8);\n Print(buf8); (* 'XXXXX-2' *)\n \n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(2, -1, buf8);\n Print(buf8); (* 'XXXXX2' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(2, 0, buf8);\n Print(buf8); (* 'XXXXX2' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(2, 1, buf8);\n Print(buf8); (* 'XXXXX2' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(2, 2, buf8);\n Print(buf8); (* 'XXXXX 2' *)\n \n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(20, -1, buf8);\n Print(buf8); (* 'XXXXX20' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(20, 0, buf8);\n Print(buf8); (* 'XXXXX20' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(20, 1, buf8);\n Print(buf8); (* 'XXXXX20' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(20, 2, buf8);\n Print(buf8); (* 'XXXXX20' *)\n \n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-20, -1, buf8);\n Print(buf8); (* 'XXXXX' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-20, 0, buf8);\n Print(buf8); (* 'XXXXX' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-20, 1, buf8);\n Print(buf8); (* 'XXXXX' *)\n Strings.Copy(\"XXXXX\", buf8);\n Strings.AppendInt(-20, 2, buf8);\n Print(buf8); (* 'XXXXX' *)\n\n Strings.AppendInt(80000000H, 1, buf);\n Print(buf);\n\n l := Strings.Write(\"Hello\", buf, 0);\n l := Strings.Write(\"... World!\", buf, l);\n l := Strings.WriteInt(2, 2, buf, l);\n l := Strings.WriteChar(\"$\", buf, l);\n Print(buf); (* 'Hello... World! 2$'*)\n WriteInt(l);\n WriteLn;\n\n l := Strings.WriteInt(2, 2, buf2, 0);\n WriteInt(l); (* -1 *)\n l := Strings.WriteChar(\"$\", buf2, 1);\n WriteInt(l); (* -1 *)\n\n WriteLn;\n l := Strings.Write(\"Hello\", buf2, 0);\n Print(buf2);\n WriteInt(l);\n WriteLn;\n l := Strings.Write(\"World\", buf2, 2);\n Print(buf2);\n WriteInt(l)\nEND TestStringsMod." }, { "path": "tests/base/TestStringsMod.txt", "content": "'Hello... World!'\n'Hello...cruel World!'\n'WORLD'\n'Hello... WORLD!'\n''\n''\n''\n''\n'Hello... World!'\n'Hello...cruel World!'\n''\n'Hello... World!'\n''\n''\n''\n''\n''\n'House'\n'AB'\n'H'\n''\n'H'\n'House$'\n'-2'\n'-2'\n'-2'\n'-2'\n'2'\n'2'\n'2'\n' 2'\n'20'\n'20'\n'20'\n'20'\n''\n''\n''\n''\n'XXXXX-2'\n'XXXXX-2'\n'XXXXX-2'\n'XXXXX-2'\n'XXXXX2'\n'XXXXX2'\n'XXXXX2'\n'XXXXX 2'\n'XXXXX20'\n'XXXXX20'\n'XXXXX20'\n'XXXXX20'\n'XXXXX'\n'XXXXX'\n'XXXXX'\n'XXXXX'\n'House$ -2147483648'\n'Hello... World! 2$'\n 18\n -1 -1\n'H'\n -1\n'H'\n -1" }, { "path": "tests/base/TestSystemVal.Mod", "content": "MODULE TestSystemVal;\n\nIMPORT SYSTEM;\n\n TYPE\n\n pR0 = POINTER TO R0;\n pR1 = POINTER TO R1;\n R0 = RECORD x: INTEGER END;\n R1 = RECORD(R0) y: INTEGER END;\n\n VAR\n\n a, b, c, i: INTEGER;\n r: REAL;\n p0: pR0;\n p1, p: pR1;\n byte, byte1: BYTE;\n\nBEGIN\n\n (* converting INTEGER to BYTE and vice versa *)\n c := 257;\n byte := SYSTEM.VAL(BYTE, c);\n WriteInt(byte); (* 1 *)\n byte := 8;\n c := SYSTEM.VAL(INTEGER, byte);\n WriteInt(c); (* 8 *)\n\n c := 257;\n i := SYSTEM.VAL(INTEGER, c);\n WriteInt(i); (* 257 *)\n byte := 8;\n byte1 := SYSTEM.VAL(BYTE, byte);\n WriteInt(byte1); (* 8 *)\n WriteLn;\n\n (* converting SET to INTEGER and vice versa *)\n\n b := SYSTEM.VAL(INTEGER, {0, 5});\n c := SYSTEM.VAL(INTEGER, {1..4});\n a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(SET, b) + SYSTEM.VAL(SET, c));\n IF 2 IN SYSTEM.VAL(SET, a) THEN\n WriteInt(a); (* 63 *)\n WriteChar(CHR(a)); (* ? *)\n END;\n\n (* converting REAL to INTEGER and back *)\n\n i := 8;\n r := SYSTEM.VAL(REAL, i);\n WriteReal(r);\n i := SYSTEM.VAL(INTEGER, r);\n WriteInt(i); WriteLn;\n\n (* converting extension types *)\n\n NEW(p1);\n p1.y := 25;\n p0 := p1;\n p := SYSTEM.VAL(pR1, p0);\n WriteInt(p.y); (* 25 *)\n\n NEW(p1);\n p1.y := 26;\n p := SYSTEM.VAL(pR1, p1);\n WriteInt(p.y) (* 26 *)\n\nEND TestSystemVal.\n" }, { "path": "tests/base/TestSystemVal.txt", "content": " 1 8 257 8\n 63? 0.000000 8\n 25 26" }, { "path": "tests/base/TestTypeConvFun.Mod", "content": "MODULE TestTypeConvFun;\n CONST c2 = \"A\";\n VAR x : REAL;\n y : INTEGER;\n c : CHAR;\n b : BOOLEAN;\n s : SET;\n\n PROCEDURE stackSize(r: REAL);\n VAR i: INTEGER;\n BEGIN\n i := FLOOR(r)\n END stackSize;\n\nBEGIN\n x := 8.9;\n y := 6;\n c := \"A\";\n b := TRUE;\n s := {1};\n WriteInt(FLOOR(8.9));\n WriteInt(FLOOR(x));\n WriteReal(FLT(6));\n WriteReal(FLT(y));\n WriteInt(ORD(c));\n WriteInt(ORD(c2));\n WriteInt(ORD(\"A\"));\n WriteInt(ORD(b));\n WriteInt(ORD(s));\n WriteInt(ORD(\"A\") + 1);\n WriteChar(CHR(ORD(c) + 1));\n c := CHR(ORD(c) + 2);\n WriteChar(c);\nEND TestTypeConvFun." }, { "path": "tests/base/TestTypeConvFun.txt", "content": " 8 8 6.000000 6.000000 65 65 65 1 2 66BC" }, { "path": "tests/base/TestTypeGuardExt.Mod", "content": "MODULE TestTypeGuardExt;\nIMPORT ExtTypes;\n VAR\n p0: ExtTypes.pR0;\n p1, p: ExtTypes.pR1;\nBEGIN\n NEW(p1);\n p1.y := 25;\n p0 := p1;\n p := p0(ExtTypes.pR1);\n WriteInt(p.y); (* 25 *)\n\n NEW(p1);\n p1.y := 26;\n p := p1(ExtTypes.pR1);\n WriteInt(p.y) (* 26 *)\nEND TestTypeGuardExt.\n" }, { "path": "tests/base/TestTypeGuardExt.txt", "content": " 25 26" }, { "path": "tests/base/TestTypeTest.Mod", "content": "MODULE TestTypeTest;\n TYPE\n G1 = POINTER TO G1Desc;\n G1Desc = RECORD next: G1; next2: ARRAY 1 OF G1 END;\n G2 = POINTER TO G2Desc;\n G2Desc = RECORD(G1Desc) x: CHAR END;\n VAR\n g2: G2;\n g2Desc: G2Desc;\n\n PROCEDURE L(g: G1): G1;\n RETURN g\n END L;\n\n PROCEDURE P1(g: G1);\n VAR b: BOOLEAN; i: INTEGER;\n BEGIN\n i := 0;\n b := g IS G1;\n WriteInt(ORD(b));\n b := g IS G2;\n WriteInt(ORD(b));\n b := g.next IS G1;\n WriteInt(ORD(b));\n b := g.next IS G2;\n WriteInt(ORD(b));\n b := g.next.next.next IS G1;\n WriteInt(ORD(b));\n b := g.next.next.next IS G2;\n WriteInt(ORD(b));\n b := g.next2[i*3].next.next.next IS G1;\n WriteInt(ORD(b));\n b := g.next2[i*3].next.next.next IS G2;\n WriteInt(ORD(b));\n b := g.next.next.next2[i*3].next IS G1;\n WriteInt(ORD(b));\n b := g.next.next.next2[i*3].next IS G2;\n WriteInt(ORD(b));\n b := g.next.next.next.next2[i*3] IS G1;\n WriteInt(ORD(b));\n b := g.next.next.next.next2[i*3] IS G2;\n WriteInt(ORD(b));\n b := L(g) IS G1;\n WriteInt(ORD(b));\n b := L(g) IS G2;\n WriteInt(ORD(b))\n END P1;\n\n PROCEDURE P2(VAR g: G1Desc);\n VAR b: BOOLEAN;\n BEGIN\n b := g IS G1Desc;\n WriteInt(ORD(b));\n b := g IS G2Desc;\n WriteInt(ORD(b))\n END P2;\n\nBEGIN\n NEW(g2);\n g2.next := g2;\n g2.next.next2[0] := g2;\n P1(g2);\n g2Desc.next := g2;\n g2Desc.next.next2[0] := g2;\n P2(g2Desc)\nEND TestTypeTest.\n" }, { "path": "tests/base/TestTypeTest.txt", "content": " 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1" }, { "path": "tests/base/UTF8String.Mod", "content": "MODULE UTF8String;\n VAR x : ARRAY 15 OF CHAR;\n i: INTEGER;\n\n(*\n Comments can contain UTF8 chars: 世 界,\n and (* can be (* nested *) *)\n *)\n\nBEGIN\n x := \"Hello, 世 界 - Ʉ\";\n i := 0;\n WHILE (i < LEN(x)) & (x[i] # 0X) DO\n WriteChar(x[i]); INC(i)\n END\nEND UTF8String." }, { "path": "tests/base/UTF8String.txt", "content": "Hello, 世 界 - Ʉ" }, { "path": "tests/base/UniqueTypeAndProcNames.Mod", "content": "MODULE UniqueTypeAndProcNames;\n TYPE T = RECORD a: INTEGER END;\n\n PROCEDURE P1(i: INTEGER);\n TYPE T = RECORD b: CHAR END;\n PROCEDURE P2(j: INTEGER);\n TYPE T2 = RECORD b: ARRAY 2, 2 OF CHAR END;\n PROCEDURE P3(j: INTEGER);\n VAR x: T2;\n BEGIN\n x.b[1][1] := \"F\";\n WriteChar(x.b[1][1])\n END P3;\n BEGIN\n WriteChar(\"E\");\n P3(3)\n END P2;\n BEGIN\n WriteChar(\"D\");\n P2(2)\n END P1;\n\n PROCEDURE P0(i: INTEGER);\n TYPE T = RECORD b: REAL END;\n PROCEDURE P2(j: INTEGER);\n TYPE T2 = RECORD b: ARRAY 3, 3 OF CHAR END;\n PROCEDURE P3(j: INTEGER);\n VAR x: T2;\n BEGIN\n x.b[2][2] := \"C\";\n WriteChar(x.b[2][2])\n END P3;\n BEGIN\n WriteChar(\"B\");\n P3(3)\n END P2;\n BEGIN\n WriteChar(\"A\");\n P2(2)\n END P0;\n\nBEGIN\n P0(1); WriteLn; P1(1)\nEND UniqueTypeAndProcNames." }, { "path": "tests/base/UniqueTypeAndProcNames.txt", "content": "ABC\nDEF" }, { "path": "tests/base/VarInit.Mod", "content": "MODULE VarInit;\nIMPORT SYSTEM;\n TYPE R = RECORD x : INTEGER END;\n VAR \n x0 : INTEGER;\n x1 : BOOLEAN;\n x2 : SET;\n x3 : BYTE;\n x4 : REAL;\n x5 : CHAR;\n x6 : R;\n y0 : ARRAY 1 OF INTEGER;\n y1 : ARRAY 1 OF BOOLEAN;\n y2 : ARRAY 1 OF SET;\n y3 : ARRAY 1 OF BYTE;\n y4 : ARRAY 1 OF REAL;\n y5 : ARRAY 1 OF CHAR; \n y6 : ARRAY 1 OF R; \n \n PROCEDURE P;\n VAR \n x0 : INTEGER;\n x1 : BOOLEAN;\n x2 : SET;\n x3 : BYTE;\n x4 : REAL;\n x5 : CHAR;\n x6 : R;\n y0 : ARRAY 1 OF INTEGER;\n y1 : ARRAY 1 OF BOOLEAN;\n y2 : ARRAY 1 OF SET;\n y3 : ARRAY 1 OF BYTE;\n y4 : ARRAY 1 OF REAL;\n y5 : ARRAY 1 OF CHAR; \n y6 : ARRAY 1 OF R; \n BEGIN\n WriteInt(x0);\n IF ~x1 THEN WriteInt(0) END;\n WriteInt(SYSTEM.VAL(INTEGER, x2));\n WriteInt(x3);\n WriteReal(x4);\n WriteInt(ORD(x5));\n WriteInt(x6.x);\n WriteLn;\n WriteInt(y0[0]);\n IF ~y1[0] THEN WriteInt(0) END;\n WriteInt(SYSTEM.VAL(INTEGER, y2[0]));\n WriteInt(y3[0]);\n WriteReal(y4[0]);\n WriteInt(ORD(y5[0]));\n WriteInt(y6[0].x);\n WriteLn;\n x0 := 8;\n WriteInt(x0);\n x1 := TRUE;\n IF x1 THEN WriteInt(1) END;\n x2 := {8};\n WriteInt(SYSTEM.VAL(INTEGER, x2));\n x3 := 8;\n WriteInt(x3);\n x4 := 8.0;\n WriteReal(x4);\n x5 := 8X;\n WriteInt(ORD(x5));\n x6.x := 8;\n WriteInt(x6.x);\n WriteLn;\n y0[0] := 8;\n WriteInt(y0[0]);\n y1[0] := TRUE;\n IF y1[0] THEN WriteInt(1) END;\n y2[0] := {8};\n WriteInt(SYSTEM.VAL(INTEGER, y2[0]));\n y3[0] := 8;\n WriteInt(y3[0]);\n y4[0] := 8.0;\n WriteReal(y4[0]);\n y5[0] := 8X;\n WriteInt(ORD(y5[0]));\n y6[0].x := 8;\n WriteInt(y6[0].x);\n END P;\nBEGIN\n x0 := 0;\n WriteInt(x0);\n x1 := FALSE;\n IF ~x1 THEN WriteInt(0) END;\n x2 := {};\n WriteInt(SYSTEM.VAL(INTEGER, x2));\n x3 := 0;\n WriteInt(x3);\n x4 := 0.0;\n WriteReal(x4);\n x5 := 0X;\n WriteInt(ORD(x5));\n x6.x := 0;\n WriteInt(x6.x);\n WriteLn;\n y0[0] := 0;\n WriteInt(y0[0]);\n y1[0] := FALSE;\n IF ~y1[0] THEN WriteInt(0) END;\n y2[0] := {};\n WriteInt(SYSTEM.VAL(INTEGER, y2[0]));\n y3[0] := 0;\n WriteInt(y3[0]);\n y4[0] := 0.0;\n WriteReal(y4[0]);\n y5[0] := 0X;\n WriteInt(ORD(y5[0]));\n y6[0].x := 0;\n WriteInt(y6[0].x);\n WriteLn;\n P;\nEND VarInit." }, { "path": "tests/base/VarInit.txt", "content": " 0 0 0 0 0.000000 0 0\n 0 0 0 0 0.000000 0 0\n 0 0 0 0 0.000000 0 0\n 0 0 0 0 0.000000 0 0\n 8 1 256 8 8.000000 8 8\n 8 1 256 8 8.000000 8 8" }, { "path": "tests/base/VarParGuard.Mod", "content": "MODULE VarParGuard;\n TYPE\n P0 = POINTER TO R0;\n P1 = POINTER TO R1;\n R0 = RECORD x: INTEGER END;\n R1 = RECORD(R0)\n y: ARRAY 10 OF R0;\n z: INTEGER;\n END;\n\n VAR\n p0: P0;\n p1: P1;\n\n PROCEDURE Proc(VAR p1: P1);\n BEGIN\n p1.x := p1.x + p1.z\n END Proc;\n\n PROCEDURE ProcInt(VAR c: INTEGER);\n BEGIN c := 6\n END ProcInt;\n\n PROCEDURE Proc1(VAR p0: P0);\n BEGIN\n Proc(p0(P1))\n END Proc1;\n\n PROCEDURE Proc2;\n VAR\n p0: P0;\n p1: P1;\n BEGIN\n NEW(p1);\n p0 := p1;\n p0.x := 1;\n p0(P1).z := 4;\n Proc(p0(P1));\n WriteInt(p0.x)\n END Proc2;\n\n PROCEDURE Proc3;\n VAR\n p0: P0;\n p1: P1;\n i: BYTE;\n BEGIN\n i := 2;\n NEW(p1);\n p0 := p1;\n p0(P1).y[1+i].x := 1;\n ProcInt(p0(P1).y[1+i].x);\n WriteInt(p0(P1).y[1+i].x);\n END Proc3;\n\n PROCEDURE Proc4;\n VAR\n p0: ARRAY 5 OF P0;\n p1: P1;\n i: BYTE;\n BEGIN\n i := 2;\n NEW(p1);\n p0[1+i] := p1;\n p0[1+i].x := 1;\n p0[1+i](P1).z := 6;\n Proc(p0[1+i](P1));\n WriteInt(p0[1+i].x)\n END Proc4;\n\n PROCEDURE Proc5;\n VAR\n r: RECORD a: P0 END;\n p1: P1;\n BEGIN\n NEW(p1);\n r.a := p1;\n r.a.x := 1;\n r.a(P1).z := 7;\n Proc(r.a(P1));\n WriteInt(r.a.x)\n END Proc5;\n\n PROCEDURE Proc6;\n VAR\n r: RECORD a: ARRAY 5 OF P0 END;\n p1: P1;\n i: BYTE;\n BEGIN\n i := 2;\n NEW(p1);\n r.a[1+i] := p1;\n r.a[1+i].x := 1;\n r.a[1+i](P1).z := 8;\n Proc(r.a[1+i](P1));\n WriteInt(r.a[1+i].x)\n END Proc6;\n\nBEGIN\n NEW(p1);\n p0 := p1;\n\n p0.x := 1;\n p0(P1).z := 2;\n Proc(p0(P1));\n WriteInt(p0.x);\n\n p0.x := 1;\n p0(P1).z := 3;\n Proc1(p0);\n WriteInt(p0.x);\n\n Proc2;\n Proc3;\n Proc4;\n Proc5;\n Proc6\nEND VarParGuard." }, { "path": "tests/base/VarParGuard.txt", "content": " 3 4 5 6 7 8 9" } ]