Repository: lboasso/oberonc Branch: master Commit: 46647de07d45 Files: 322 Total size: 386.4 KB Directory structure: gitextract_k_kcp7o4/ ├── LICENSE.txt ├── Makefile ├── README.md ├── bin/ │ ├── ClassFormat.smb │ ├── CpCache.smb │ ├── Files.smb │ ├── In.smb │ ├── Math.smb │ ├── OJB.smb │ ├── OJG.smb │ ├── OJP.smb │ ├── OJS.smb │ ├── Opcodes.smb │ ├── Os.smb │ ├── Out.smb │ ├── Strings.smb │ └── oberonc.smb ├── doc/ │ ├── TypeRules.md │ └── oberon07.g ├── examples/ │ ├── GuessNumber.Mod │ ├── Hello.Mod │ ├── Powers.Mod │ ├── PrimeNumbers.Mod │ ├── Util.Mod │ └── fern/ │ ├── IFS.Mod │ ├── RandomNumbers.Mod │ ├── XYplane.Mod │ └── java/ │ └── XYplane.java ├── make.bat ├── src/ │ ├── ClassFormat.Mod │ ├── CpCache.Mod │ ├── Files.Mod │ ├── In.Mod │ ├── Math.Mod │ ├── OJB.Mod │ ├── OJG.Mod │ ├── OJP.Mod │ ├── OJS.Mod │ ├── Opcodes.Mod │ ├── Os.Mod │ ├── Out.Mod │ ├── Strings.Mod │ ├── java/ │ │ ├── Files.java │ │ ├── Files_FileDesc.java │ │ ├── In.java │ │ ├── Math.java │ │ ├── OberonRuntime.java │ │ ├── Os.java │ │ └── Out.java │ └── oberonc.Mod └── tests/ ├── TestRunner.java └── base/ ├── ArrayAssignment.Mod ├── ArrayAssignment.txt ├── ArrayConstantSize.Mod ├── Arrays2.Mod ├── Arrays2.txt ├── Arrays3.Mod ├── Arrays3.txt ├── BitFunc.Mod ├── BitFunc.txt ├── CaseChar0.Mod ├── CaseChar0.txt ├── CaseNum0.Mod ├── CaseNum0.txt ├── CaseNum1.Mod ├── CaseNum1.txt ├── CaseRecord0.Mod ├── CaseRecord0.txt ├── CaseRecord1.Mod ├── CaseRecord1.txt ├── CaseRecord2.Mod ├── CaseRecord2.txt ├── CaseRecord3.Mod ├── CaseRecord3.txt ├── CaseRecord4.Mod ├── CaseRecord4.txt ├── CommutativeSwap.Mod ├── CommutativeSwap.txt ├── ConstantFoldingAndLoadOp.Mod ├── ConstantFoldingAndLoadOp.txt ├── DivMul.Mod ├── DivMul.txt ├── EmptyArrayAndRecord.Mod ├── EmptyArrayAndRecord.txt ├── ExtTypes.Mod ├── ForwardPointerRef.Mod ├── ForwardPointerRef.txt ├── Fractions.Mod ├── Fractions.txt ├── FragileBaseClass.Mod ├── FragileBaseClass.txt ├── MagicSquares.Mod ├── MagicSquares.txt ├── OpenArrays.Mod ├── OpenArrays.txt ├── OpenArrays2.Mod ├── OpenArrays2.txt ├── OpenArrays3.Mod ├── OpenArrays3.txt ├── Out0.Mod ├── Out0.txt ├── Out1.Mod ├── Out1.txt ├── Out2.Mod ├── Out2.txt ├── Out3.Mod ├── Out3.txt ├── Out4.Mod ├── Out4.txt ├── Out5.Mod ├── Out5.txt ├── Out6.Mod ├── Out6.txt ├── OutTest.Mod ├── OutTest.txt ├── Pattern1.Mod ├── Pattern1.txt ├── Pattern2a.Mod ├── Pattern2a.txt ├── Pattern2b.Mod ├── Pattern2b.txt ├── Pattern2c.Mod ├── Pattern2c.txt ├── Permutations.Mod ├── Permutations.txt ├── Powers.Mod ├── Powers.txt ├── PrimeNumbers.Mod ├── PrimeNumbers.txt ├── ProcComparisons.Mod ├── ProcComparisons.txt ├── ProcType.Mod ├── ProcType.txt ├── ProcVariables0.Mod ├── ProcVariables0.txt ├── ProcVariables1.Mod ├── ProcVariables1.txt ├── ProcVariables2.Mod ├── ProcVariables2.txt ├── ProcVariables3.Mod ├── ProcVariables3.txt ├── ProcVariables4.Mod ├── ProcVariables4.txt ├── ProcVariables5.Mod ├── ProcVariables5.txt ├── ProcVariables6.Mod ├── ProcVariables6.txt ├── ProcVariables7.Mod ├── ProcVariables7.txt ├── RealExpressions.Mod ├── RealExpressions.txt ├── RecordAndTypeExtension.Mod ├── RecordAndTypeExtension.txt ├── RecordAssignment.Mod ├── RecordAssignment.txt ├── RecordAssignment2.Mod ├── RecordAssignment2.txt ├── RecordParam.Mod ├── RecordParam.txt ├── Samples0.Mod ├── Samples0.txt ├── Samples1.Mod ├── Samples1.txt ├── Samples2.Mod ├── Samples2.txt ├── SetTest.Mod ├── SetTest.txt ├── Strings0.Mod ├── Strings0.txt ├── Strings1.Mod ├── Strings1.txt ├── Strings2.Mod ├── Strings2.txt ├── TestABS.Mod ├── TestABS.txt ├── TestAnonymousName.Mod ├── TestAnonymousName.txt ├── TestAssert.Mod ├── TestAssert.txt ├── TestAssignmentMix.Mod ├── TestAssignmentMix.txt ├── TestByteType.Mod ├── TestByteType.txt ├── TestCPS.Mod ├── TestCPS.txt ├── TestCmdLineArgs.Mod ├── TestCmdLineArgs.txt ├── TestConstFunc.Mod ├── TestConstFunc.txt ├── TestCyclicImport00A.Mod ├── TestCyclicImport00B.Mod ├── TestCyclicImport01A.Mod ├── TestCyclicImport01B.Mod ├── TestCyclicImport10A.Mod ├── TestCyclicImport10B.Mod ├── TestCyclicImport11.Mod ├── TestCyclicImport12.Mod ├── TestEqualSignature00.Mod ├── TestEqualSignature00.txt ├── TestExprVarPar.Mod ├── TestFor.Mod ├── TestFor.txt ├── TestFor1.Mod ├── TestFor1.txt ├── TestFunction0.Mod ├── TestFunction0.txt ├── TestINC0.Mod ├── TestINC0.txt ├── TestINC1.Mod ├── TestINC1.txt ├── TestINCLAndEXCL.Mod ├── TestINCLAndEXCL.txt ├── TestImport00.Mod ├── TestImport00.txt ├── TestImport01.Mod ├── TestImport01.txt ├── TestImport10.Mod ├── TestImport10.txt ├── TestImport100.Mod ├── TestImport100.txt ├── TestImport11.Mod ├── TestImport11.txt ├── TestImport110.Mod ├── TestImport110.txt ├── TestImport111.Mod ├── TestImport112.Mod ├── TestImport112.txt ├── TestImport120.Mod ├── TestImport120.txt ├── TestImport121.Mod ├── TestImport121.txt ├── TestImport122.Mod ├── TestImport122.txt ├── TestImport130.Mod ├── TestImport130.txt ├── TestImport131.Mod ├── TestImport131.txt ├── TestImport140.Mod ├── TestImport140.txt ├── TestImport141.Mod ├── TestImport141.txt ├── TestImport142.Mod ├── TestImport142.txt ├── TestImport150.Mod ├── TestImport150.txt ├── TestImport151.Mod ├── TestImport151.txt ├── TestImport20.Mod ├── TestImport20.txt ├── TestImport21.Mod ├── TestImport21.txt ├── TestImport22.Mod ├── TestImport22.txt ├── TestImport30.Mod ├── TestImport30.txt ├── TestImport31.Mod ├── TestImport31.txt ├── TestImport40.Mod ├── TestImport40.txt ├── TestImport41.Mod ├── TestImport41.txt ├── TestImport42.Mod ├── TestImport42.txt ├── TestImport50.Mod ├── TestImport50.txt ├── TestImport51.Mod ├── TestImport51.txt ├── TestImport52.Mod ├── TestImport52.txt ├── TestImport53.Mod ├── TestImport53.txt ├── TestImport60.Mod ├── TestImport60.txt ├── TestImport61.Mod ├── TestImport61.txt ├── TestImport62.Mod ├── TestImport62.txt ├── TestImport70.Mod ├── TestImport70.txt ├── TestImport71.Mod ├── TestImport71.txt ├── TestImport80.Mod ├── TestImport80.txt ├── TestImport81.Mod ├── TestImport81.txt ├── TestImport82.Mod ├── TestImport82.txt ├── TestImport90.Mod ├── TestImport90.txt ├── TestImport91.Mod ├── TestImport91.txt ├── TestMath.Mod ├── TestMath.txt ├── TestNestedProcs.Mod ├── TestNestedProcs.txt ├── TestODD.Mod ├── TestODD.txt ├── TestOOP.Mod ├── TestOOP.txt ├── TestReadOnlyPar.Mod ├── TestReturn0.Mod ├── TestReturn0.txt ├── TestShift.Mod ├── TestShift.txt ├── TestStringsMod.Mod ├── TestStringsMod.txt ├── TestSystemVal.Mod ├── TestSystemVal.txt ├── TestTypeConvFun.Mod ├── TestTypeConvFun.txt ├── TestTypeGuardExt.Mod ├── TestTypeGuardExt.txt ├── TestTypeTest.Mod ├── TestTypeTest.txt ├── UTF8String.Mod ├── UTF8String.txt ├── UniqueTypeAndProcNames.Mod ├── UniqueTypeAndProcNames.txt ├── VarInit.Mod ├── VarInit.txt ├── VarParGuard.Mod └── VarParGuard.txt ================================================ FILE CONTENTS ================================================ ================================================ FILE: LICENSE.txt ================================================ MIT License Copyright (c) 2017 Luca Boasso Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: Makefile ================================================ .POSIX: .SUFFIXES: 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 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 OBERON_BIN = ./bin build: mkdir -p out/ javac -d out $(JAVA_SOURCES) OBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc out $(MOD_SOURCES) bootstrap: javac -d bin $(JAVA_SOURCES) OBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc bin $(MOD_SOURCES) bootstrapTest: rm -rf bootstrapOut/ mkdir -p bootstrapOut/ OBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc bootstrapOut $(MOD_SOURCES) sha1sum -b bootstrapOut/* > sha1sums0.txt sed s/bootstrapOut/bin/ sha1sums0.txt > sha1sums1.txt sha1sum -c --quiet sha1sums1.txt rm sha1sums0.txt sha1sums1.txt runFern: rm -rf examples/fern/out/ mkdir -p examples/fern/out/ javac -cp $(OBERON_BIN) -d examples/fern/out examples/fern/java/*.java OBERON_BIN=${OBERON_BIN} java -cp $(OBERON_BIN) oberonc examples/fern/out \ examples/fern/RandomNumbers.Mod \ examples/fern/XYplane.Mod examples/fern/IFS.Mod java -cp $(OBERON_BIN):examples/fern/out IFS test: rm -rf tests/out/ mkdir -p tests/out/ javac -cp $(OBERON_BIN) -d tests/out tests/TestRunner.java OBERON_BIN=${OBERON_BIN} java -Dfile.encoding=UTF-8 -cp $(OBERON_BIN):tests/out TestRunner clean: rm -rf out/ tests/out/ bootstrapOut/ examples/fern/out/ ================================================ FILE: README.md ================================================ # Oberon-07 compiler `oberonc` is a single pass, self-hosting compiler for the [Oberon-07](https://en.wikipedia.org/wiki/Oberon_(programming_language)) programming language. It targets the Java Virtual Machine (version >= 1.8). This project was started to showcase Niklaus Wirth's approach to writing compilers (see ["Compiler Construction - The Art of Niklaus Wirth"](https://github.com/lboasso/oberonc/blob/master/doc/Moe00b.pdf) by Hanspeter Mössenböck for more details). `oberonc` is inspired by Niklaus Wirth's compiler for a RISC processor available [here](http://www.inf.ethz.ch/personal/wirth/). The compiler is compact and does not depend on any third party libraries. It produces Java bytecode in one pass while parsing the source file. Although generating code for a stack machine is straightforward, this task is exacerbated by a complex class file format and the fact that the JVM was designed with the Java language in mind. In fact the JVM lacks many of the primitives required to support Oberon's features, specifically: * value types * pass by reference evaluation strategy * procedure variables (pointer to functions) and relative structural compatibility of types Implementing those features with workarounds increased significantly the size of the compiler, totaling roughly 6000 lines of Oberon. The source code is written following as much as possible Niklaus Wirth's coding style. `oberonc` compile itself in less than 300 ms on an old Intel i5 @ 2.80GHz (~ 100 ms with a hot VM). ## How to build You can build the compiler on Linux or Windows, you need a JDK >= 1.8 installed, with java and javac in the environment path. Because you need an Oberon compiler to compile the sources in `src`, I have added to the repository the binaries of the compiler to perform the bootstrapping. By typing `make build` on the shell, the compiler will compile itself and write the files in the `out` folder. The `make bootstrap` command is equivalent to `make build`, but it overwrites the files in the `bin` folder. To run the compiler, you need to have the OBERON_BIN environmental variable set to the `bin` folder of the repository. This is taken care for you when using `make`. ## How to run the tests One typical test is to make sure that, by compiling the compiler, we get the same (bit by bit) class files originally included in the `bin` folder. To run this test simply type `make bootstrapTest` (available only on Linux). This will compile the sources into the `bootstrapOut` folder and compare these resulting class files with the ones in `bin`. If something goes wrong `sha1sums` will complain. To run the tests included in the `tests` folder, type `make test`. The output should look like this: ... TOTAL: 101 SUCCESSFUL: 101 FAILED: 0 ## Using the compiler To use the compiler, you need to have the OBERON_BIN environmental variable set to the `bin` folder of the repository, for example on Linux `export OBERON_BIN=~/oberonc/bin` or `set OBERON_BIN=C:\oberonc\bin` on Windows. The command line syntax of `oberonc` is simple. Let's compile examples/Hello.Mod: MODULE Hello; IMPORT Out; (* Import Out to print on the console *) BEGIN Out.String("Hello 世界"); Out.Ln (* print a new line *) END Hello. Assuming you are at the root of the repository, the following command will compile the Hello.Mod example and place the generated classes in the current folder: Linux java -cp $OBERON_BIN oberonc . examples/Hello.Mod Windows java -cp %OBERON_BIN% oberonc . examples/Hello.Mod The first argument of oberonc is `.`, this is the existing folder where the generated class will be written, the next arguments specify module files to be compiled. This will generate Hello.class and Hello.smb. The second file is a symbol file, it is used only during compilation and enables `oberonc` to perform separate compilation of modules that import Hello. In this simple case Hello.Mod does not export anything, but the other modules in the `examples` folder do. To run Hello.class, you need the OberonRuntime.class and Out.class. These are present in the `bin` folder so they are already in the class path, we just need to include the current folder as well to locate Hello.class: Linux java -cp $OBERON_BIN:. Hello Windows java -cp %OBERON_BIN%;. Hello If you want to compile and run automatically a simple example called `fern`, type `make runFern`. It should open a window like this one: ![Fern](examples/fern/fern.png) Lastly, `make clean` will delete the output folders generated by `build`, `test`, `runFern` and `bootstrapTest`. ## License The compiler is distributed under the MIT license found in the LICENSE.txt file. ================================================ FILE: doc/TypeRules.md ================================================ # Type rules ## Same types [A] Two variables *a* and *b* with types *Ta* and *Tb* are of the *same* type if 1. *Ta* and *Tb* are both denoted by the same type identifier, or 2. *Ta* is declared in a type declaration of the form *Ta* = *Tb*, or 3. *a* and *b* appear in the same identifier list in a variable, record field, or formal parameter declaration. ## Equal types [B] Two types *Ta* and *Tb* are *equal* if 1. *Ta* and *Tb* are the *same* type, or 2. *Ta* and *Tb* are open array types with *equal* element types, or 3. *Ta* and *Tb* are array types with *equal* element types and length, or 4. *Ta* and *Tb* are procedure types whose formal parameter lists *match*, or 5. *Ta* and *Tb* are pointer types with *equal* base types. ## Matching formal parameter lists [C] Two formal parameter lists *match* if 1. they have the same number of parameters, and 2. they have either *equal* function result types or none, and 3. parameters at corresponding positions have *equal* types, and 4. parameters at corresponding positions are both either value or VAR parameters. ## Type extension (base type) [D] Given a type declaration *Tb* = RECORD (*Ta*) ... END, *Tb* is a *direct extension* of *Ta*, and *Ta* is a *direct base type* of *Tb*. A type *Tb* is an *extension* of a type *Ta* (*Ta* is a *base type* of *Tb*) if 1. *Ta* and *Tb* are the *same* types, or 2. *Tb* is a *direct extension* of an *extension* of *Ta*. If *Pa* = POINTER TO *Ta* and *Pb* = POINTER TO *Tb*, *Pb* is an *extension* of *Pa* (*Pa* is a *base type* of *Pb*) if *Tb* is an *extension* of *Ta*. ## Assignment compatible [E] An expression *e* of type *Te* is *assignment compatible* with a variable *v* of type *Tv* if one of the following conditions hold: 1. *Te* and *Tv* are *equal* and are not open array types; 2. *Te* and *Tv* are record types and *Te* is an *extension* of *Tv* and the dynamic type of *v* is *Tv*; 3. *Te* and *Tv* are pointer types and *Te* is an *extension* of *Tv*; 4. *Tv* is a pointer or a procedure type and *e* is NIL; 5. *Tv* is array of CHAR, *e* is a string constant with *n* characters, and *n* < *LEN(v)*; 6. *Tv* is ARRAY *n* OF *Ta*, *e* is ARRAY OF *Tb* where *Ta* and *Tb* are *equal* and *LEN(e) <= LEN(v)*; 7. *Tv* is a procedure type and *e* is the name of a procedure whose formal parameters *match* those of *Tv*. ## Parameters Let *f* be the formal parameter and *a* the corresponding actual parameter. If *f* is an open array, then *a* must be *array compatible* to *f* and the lengths of *f* are taken from *a*. Otherwise *a* must be *parameter compatible* to *f*. ### Array compatible [F] An actual parameter *a* of type *Ta* is *array compatible* with a formal parameter *f* of type *Tf* if 1. *Tf* and *Ta* are *equal* types, or 2. *Tf* is an open array, *Ta* is any array, and their element types are *array compatible*, or 3. *f* is a value parameter of type ARRAY OF CHAR and *a* is a string. ### Parameter compatible [G] An actual parameter *a* of type *Ta* is *parameter compatible* with a formal parameter *f* of type *Tf* if: 1. *Tf* and *Ta* are *equal* types, or 2. *f* is a value parameter and *Ta* is *assignment compatible* (except E.5 and E.6) with *Tf*, or 3. *f* is an VAR parameter and *Tf* and *Ta* are record types and *Ta* is an *extension* of *Tf*, or 4. *f* is a parameter of type ARRAY *m* OF BYTE and *Ta* is any type with size *n* = *m* bytes. ## RETURN expression [H] The type of the expression must be *assignment compatible* with the result type specified in the procedure heading and can be neither a record nor an array. ## BYTE and INTEGER [I] The type BYTE is compatible with the type INTEGER, and vice versa. ## String and CHAR [J] A string of length 1 can be used wherever a character constant is allowed and vice versa. ================================================ FILE: doc/oberon07.g ================================================ // ANTLR v3 grammar grammar oberon07; // LL(1) with few ambiguities resolved with the help of the symbol table options {k = 1;} module : 'MODULE' IDENT ';' (importList)? declarationSequence ('BEGIN' statementSequence)? 'END' IDENT '.' ; importList : 'IMPORT' import_ (',' import_)* ';'; import_ : IDENT (':=' IDENT)? ; qualident : (IDENT '.')? IDENT; identdef : IDENT ('*')?; constDeclaration : identdef '=' constExpression; constExpression : expression; typeDeclaration : identdef '=' type; type : qualident | arrayType | recordType | pointerType | procedureType; arrayType : 'ARRAY' length (',' length)* 'OF' type; length : constExpression; recordType : 'RECORD' ('(' baseType ')')? (fieldListSequence)? 'END'; baseType : qualident; fieldListSequence : fieldList (';' fieldList)*; fieldList : identList ':' type; identList : identdef (',' identdef)*; pointerType : 'POINTER' 'TO' type; procedureType : 'PROCEDURE' (formalParameters)?; variableDeclaration : identList ':' type; expression : simpleExpression (relation simpleExpression)?; relation : '=' | '#' | '<' | '<=' | '>' | '>=' | 'IN' | 'IS'; simpleExpression : ('+' | '-')? term (addOperator term)*; addOperator : '+' | '-' | 'OR'; term : factor (mulOperator factor)*; mulOperator : '*' | '/' | 'DIV' | 'MOD' | '&'; factor : number | STRING | 'NIL' | 'TRUE' | 'FALSE' | set | designator (actualParameters)? | '(' expression ')' | '~' factor; designator : qualident (selector)*; selector : '.' IDENT | '[' expList ']' | '^' | '(' qualident ')'; set : '{' (element (',' element)*)?'}'; element : expression ('..' expression)?; expList : expression (',' expression)*; actualParameters : '(' (expList)? ')' ; statement : (assignment | procedureCall | ifStatement | caseStatement | whileStatement | repeatStatement | forStatement)?; assignment : designator ':=' expression; procedureCall : designator (actualParameters)?; statementSequence : statement (';' statement)*; ifStatement : 'IF' expression 'THEN' statementSequence ('ELSIF' expression 'THEN' statementSequence)* ('ELSE' statementSequence)? 'END'; caseStatement : 'CASE' expression 'OF' case ('|' case)* 'END'; case : (caseLabelList ':' statementSequence)?; caseLabelList : labelRange (',' labelRange)*; labelRange : label ('..' label)?; label : INTEGER | STRING | qualident; whileStatement : 'WHILE' expression 'DO' statementSequence ('ELSIF' expression 'DO' statementSequence)* 'END'; repeatStatement : 'REPEAT' statementSequence 'UNTIL' expression; forStatement : 'FOR' IDENT ':=' expression 'TO' expression ('BY' constExpression)? 'DO' statementSequence 'END'; procedureDeclaration : procedureHeading ';' procedureBody IDENT; procedureHeading : 'PROCEDURE' identdef (formalParameters)?; procedureBody : declarationSequence ('BEGIN' statementSequence)? ('RETURN 'expression)? 'END'; declarationSequence : ('CONST' (constDeclaration ';')*)? ('TYPE' (typeDeclaration ';')*)? ('VAR' (variableDeclaration ';')*)? (procedureDeclaration ';')*; formalParameters : '(' (fpsection (';' fpsection)*)? ')' (':' qualident)?; fpsection : ('VAR')? IDENT (',' IDENT)* ':' formalType; formalType : ('ARRAY' 'OF')* qualident; number : INTEGER | REAL; INTEGER : DIGIT (DIGIT)* | DIGIT (HEX_DIGIT)* 'H'; fragment STR : '"' ( ~('"') )* '"' ; fragment DIGIT : ('0'..'9') ; fragment HEX_DIGIT : ('0'..'9'|'a'..'f'|'A'..'F') ; fragment REAL : DIGIT (DIGIT)* '.' (DIGIT)* (SCALE_FACTOR)?; fragment SCALE_FACTOR : 'E' ('+' | '-')? DIGIT (DIGIT)*; STRING : STR | DIGIT (HEX_DIGIT)* 'X'; IDENT : ('a'..'z'|'A'..'Z') ('a'..'z'|'A'..'Z'|'0'..'9')* ; COMMENT : '(*' ( options {greedy=false;} : . )* '*)' {$channel=HIDDEN;} ; WS : (' ' | '\t' | '\r' | '\n') {$channel=HIDDEN;} ; ================================================ FILE: examples/GuessNumber.Mod ================================================ MODULE GuessNumber; IMPORT In, Out; VAR name: ARRAY 20 OF CHAR; number, left, right, old: INTEGER; choice: CHAR; PROCEDURE CharLn(VAR ch: CHAR); VAR discard: CHAR; BEGIN In.Char(ch); REPEAT In.Char(discard) UNTIL In.Done & (discard = 0AX); END CharLn; BEGIN Out.String("What's your name? "); In.String(name); Out.String("Hi "); Out.String(name); Out.Char("!"); Out.Ln; Out.String("Please think of a number from 0 to 50 and I'll guess it."); Out.Ln; left := 0; right := 50; number := 27; REPEAT REPEAT Out.String("Is "); Out.Int(number, 3); Out.String(" the correct number? [(h)igher (l)ower (c)orrect] "); CharLn(choice) UNTIL In.Done & ((choice = "h") OR (choice = "l") OR (choice = "c")); IF choice = "h" THEN left := number + 1 ELSIF choice = "l" THEN right := number - 1 END ; old := number; number := left + (right - left) DIV 2; IF (choice # "c") & (number = old) THEN Out.Ln; Out.String("You lied :)"); choice := "c" END UNTIL choice = "c"; Out.Ln END GuessNumber. ================================================ FILE: examples/Hello.Mod ================================================ MODULE Hello; IMPORT Out; (* Import Out to print on the console *) BEGIN Out.String("Hello 世界"); Out.Ln (* print a new line *) END Hello. ================================================ FILE: examples/Powers.Mod ================================================ MODULE Powers; (*Tabulate positive and negative powers of 2*) IMPORT Out, Util; CONST N = 32; M = 11; (*M ~ N*log2*) PROCEDURE Power(n: INTEGER); VAR i, k, exp: INTEGER; c, r, t: INTEGER; d: ARRAY M OF INTEGER; f: ARRAY N OF INTEGER; BEGIN d[0] := 1; k := 1; exp := 1; WHILE exp < n DO (*compute d = 2^exp*) c := 0; (*carry*) i := 0; WHILE i < k DO t := 2*d[i] + c; IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ; i := i+1 END ; IF c = 1 THEN d[k] := 1; k := k+1 END ; (*write d*) i := M; WHILE i > k DO i := i-1; Out.Char(" ") END ; WHILE i > 0 DO i := i-1; Out.Char(CHR(d[i] + ORD("0"))) END ; Out.Int(exp, 5); (*compute f = 2^-exp*) Out.String(" "); Out.Char("0"); Out.Char("."); r := 0; i := 1; WHILE i < exp DO r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2; Out.Char(CHR(f[i] + ORD("0"))); i := i+1 END ; f[exp] := 5; Out.Char("5"); Out.Ln; exp := exp + 1 END END Power; PROCEDURE Main; VAR n, i: INTEGER; arg: ARRAY 3 OF CHAR; BEGIN n := ARGNUM(); IF n # 1 THEN Out.String("usage: Powers number in [0..32]"); Out.Ln ELSE ARGS(0, arg); i := Util.strToInt(arg); IF i <= 32 THEN Power(i) END END END Main; END Powers. ================================================ FILE: examples/PrimeNumbers.Mod ================================================ MODULE PrimeNumbers; (*Tabulate prime numbers*) IMPORT Out, Util; PROCEDURE Primes(n: INTEGER); VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN; p: ARRAY 400 OF INTEGER; v: ARRAY 20 OF INTEGER; BEGIN x := 1; inc := 4; lim := 1; sqr := 4; m := 0; i := 3; WHILE i <= n DO REPEAT x := x + inc; inc := 6 - inc; IF sqr <= x THEN (*sqr = p[lim]^2*) v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim] END ; k := 2; prim := TRUE; WHILE prim & (k < lim) DO k := k+1; IF v[k] < x THEN v[k] := v[k] + p[k] END ; prim := x # v[k] END UNTIL prim; p[i] := x; Out.Int(x, 5); IF m = 10 THEN Out.Ln; m := 0 ELSE m := m+1 END ; i := i+1 END ; IF m > 0 THEN Out.Ln END END Primes; PROCEDURE Main; VAR n: INTEGER; arg: ARRAY 3 OF CHAR; BEGIN n := ARGNUM(); IF n # 1 THEN Out.String("usage: PrimeNumbers number in [0..99]"); Out.Ln ELSE ARGS(0, arg); Primes(Util.strToInt(arg)) END END Main; END PrimeNumbers. ================================================ FILE: examples/Util.Mod ================================================ MODULE Util; PROCEDURE strToInt*(str: ARRAY OF CHAR): INTEGER; VAR res, i, x: INTEGER; BEGIN res := 0; FOR i := 0 TO LEN(str)-1 DO x := ORD(str[i]) - ORD("0"); IF (x >= 0) & (x <= 9) THEN res := res * 10 + x END END RETURN res END strToInt; END Util. ================================================ FILE: examples/fern/IFS.Mod ================================================ MODULE IFS; IMPORT RandomNumbers, XYplane; VAR a1, b1, c1, d1, e1, f1, p1: REAL; (* IFS parameters *) a2, b2, c2, d2, e2, f2, p2: REAL; (* IFS parameters *) a3, b3, c3, d3, e3, f3, p3: REAL; (* IFS parameters *) a4, b4, c4, d4, e4, f4, p4: REAL; (* IFS parameters *) X, Y: REAL; (* the position of the pen *) x0: INTEGER; (* Distance of origin fm left edge[pixels] *) y0: INTEGER; (* Distance of origin from bottom edge[pixels] *) e: INTEGER; (* Size of unit interval [pixels] *) PROCEDURE Draw; VAR x, y: REAL; (* new position *) xi, eta: INTEGER; (* pixel coordinates of pen *) rn: REAL; i : INTEGER; BEGIN i := 0; REPEAT rn := RandomNumbers.Uniform(); IF rn < p1 THEN x := a1 * X + b1 * Y + e1; y := c1 * X + d1 * Y + f1 ELSIF rn < (p1 + p2) THEN x := a2 * X + b2 * Y + e2; y := c2 * X + d2 * Y + f2 ELSIF rn < (p1 + p2 + p3) THEN x := a3 * X + b3 * Y + e3; y := c3 * X + d3 * Y + f3 ELSE x := a4 * X + b4 * Y + e4; y := c4 * X + d4 * Y + f4 END; X := x; xi := x0 + FLOOR(X*FLT(e)); Y := y; eta := y0 + FLOOR(Y*FLT(e)); XYplane.Dot(xi, eta, XYplane.draw); INC(i) UNTIL i = 100000 END Draw; PROCEDURE Init; BEGIN X := 0.0; Y := 0.0; (* Initial position of pen *) RandomNumbers.InitSeed(1); x0 := 320; y0 := 75; e := 64; a1 := 0.0; a2 := 0.85; a3 := 0.2; a4 := -0.15; b1 := 0.0; b2 := 0.04; b3 := -0.26; b4 := 0.28; c1 := 0.0; c2 := -0.04; c3 := 0.23; c4 := 0.26; d1 := 0.16; d2 := 0.85; d3 := 0.22; d4 := 0.24; e1 := 0.0; e2 := 0.0; e3 := 0.0; e4 := 0.0; f1 := 0.0; f2 := 1.6; f3 := 1.6; f4 := 0.44; p1 := 0.01; p2 := 0.85; p3 := 0.07; p4 := 0.07; END Init; BEGIN XYplane.Open; Init; Draw END IFS. ================================================ FILE: examples/fern/RandomNumbers.Mod ================================================ MODULE RandomNumbers; IMPORT Math; VAR Z: INTEGER; PROCEDURE Uniform*(): REAL; CONST a = 16807; m = 2147483647; q = m DIV a; r = m MOD a; VAR g: INTEGER; BEGIN g := a*(Z MOD q) - r*(Z DIV q); IF g > 0 THEN Z := g ELSE Z := g + m END; RETURN FLT(Z)*(1.0/FLT(m)) END Uniform; PROCEDURE Exp*(mu: REAL): REAL; BEGIN RETURN -Math.ln(Uniform())/mu END Exp; PROCEDURE InitSeed*(seed: INTEGER); BEGIN Z := seed END InitSeed; BEGIN Z := 1; END RandomNumbers. ================================================ FILE: examples/fern/XYplane.Mod ================================================ DEFINITION XYplane; CONST erase = 0; draw = 1; VAR X, Y, W, H: INTEGER; PROCEDURE Open; PROCEDURE Dot(x, y, mode: INTEGER); PROCEDURE IsDot(x, y: INTEGER): BOOLEAN; PROCEDURE Key(): CHAR; PROCEDURE Clear; END XYplane. ================================================ FILE: examples/fern/java/XYplane.java ================================================ import java.awt.Color; import java.awt.Dimension; import java.awt.Graphics; import java.awt.Graphics2D; import java.awt.image.BufferedImage; import javax.swing.JFrame; import javax.swing.JPanel; import javax.swing.WindowConstants; public final class XYplane { public static final int erase = 0; public static final int draw = 1; public static int X, Y, W, H; private static char key; private static Viewer viewer; private static final int white = Color.WHITE.getRGB(); private static final int black = Color.BLACK.getRGB(); // Ensure non-instantiability private XYplane() {} public static void Open() { W = 800; H = 800; JFrame frame = new JFrame("XYPlane"); viewer = new Viewer(W, H); frame.add(viewer); frame.pack(); frame.setVisible(true); frame.setResizable(false); frame.setDefaultCloseOperation(WindowConstants.EXIT_ON_CLOSE); } public static void Dot(int x, int y, int mode) { y = H - y - 1; if(mode == erase) { viewer.canvas.setRGB(x, y, black); } else { viewer.canvas.setRGB(x, y, white); } viewer.updateUI(); } public static boolean isDot(int x, int y) { y = H - y - 1; return viewer.canvas.getRGB(x, y) == white; } public static char Key() { return key; } public static void Clear() { viewer.fillCanvas(black); } private static class Viewer extends JPanel { private BufferedImage canvas; public Viewer(int width, int height) { canvas = new BufferedImage(width, height, BufferedImage.TYPE_INT_ARGB); fillCanvas(black); setFocusable(true); requestFocus(true); } public Dimension getPreferredSize() { return new Dimension(canvas.getWidth(), canvas.getHeight()); } public void paintComponent(Graphics g) { super.paintComponent(g); Graphics2D g2 = (Graphics2D) g; g2.drawImage(canvas, null, null); } public void fillCanvas(int color) { for(int x = 0; x < canvas.getWidth(); x++) { for(int y = 0; y < canvas.getHeight(); y++) { canvas.setRGB(x, y, color); } } repaint(); } } } ================================================ FILE: make.bat ================================================ @echo off set 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 set 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 set OBERON_BIN=./bin if "%~1"=="" goto build if "%~1"=="build" goto build if "%~1"=="bootstrap" goto bootstrap if "%~1"=="runFern" goto runFern if "%~1"=="test" goto test if "%~1"=="clean" goto clean echo "%~1": invalid target goto end :build mkdir "out/" javac -d out %JAVA_SOURCES% java -cp %OBERON_BIN% oberonc out %MOD_SOURCES% echo build done goto end :bootstrap javac -d bin %JAVA_SOURCES% java -cp %OBERON_BIN% oberonc bin %MOD_SOURCES% echo bootstrap done goto end :runFern mkdir "examples/fern/out/" javac -cp %OBERON_BIN% -d examples/fern/out examples/fern/java/*.java java -cp %OBERON_BIN% oberonc examples/fern/out examples/fern/RandomNumbers.Mod examples/fern/XYplane.Mod examples/fern/IFS.Mod java -cp %OBERON_BIN%;examples/fern/out IFS goto end :test mkdir "tests/out/" javac -cp %OBERON_BIN% -d tests/out tests/TestRunner.java java -Dfile.encoding=UTF-8 -cp %OBERON_BIN%;tests/out TestRunner goto end :clean rmdir out /s /q rmdir tests\out /s /q rmdir examples\fern\out /s /q :end ================================================ FILE: src/ClassFormat.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* This module deals with the low level generation of a class file according to the Java Virtual Machine Specification. It uses CpCache to keep track of the constant pool entries written so far in the CFDesc record. *) MODULE ClassFormat; IMPORT Strings, Files, CpCache, Opcodes, OJS; CONST nestedIdLen* = 5; CpMax = 10000H; DescLenMax = 500; FieldsMax = CpMax; LineNumTabMax = CpMax; CodeMax = CpMax; MethodsMax = 34 + LineNumTabMax + CodeMax; ClassMax = 32 + CpMax + MethodsMax + FieldsMax; ShortMaxValue = 32767; UTF8 = 1; CLASS = 7; NAMExTYPE = 12; METH = 10; FIELD = 9; STR = 8; INT* = 3; FLOAT* = 4; TYPE Descriptor* = ARRAY DescLenMax OF CHAR; CF* = POINTER TO CFDesc; CFDesc = RECORD constantPool: ARRAY CpMax OF BYTE; cpCount, cpIndex: INTEGER; access: INTEGER; thisIndex, superIndex, sourceFileIndex: INTEGER; methods: ARRAY MethodsMax OF BYTE; methIndex, methCount: INTEGER; fields: ARRAY FieldsMax OF BYTE; fieldsIndex, fieldsCount: INTEGER; cpCache, procMap: CpCache.Cache; END; MethodInfo* = POINTER TO MethodInfoDesc; MethodInfoDesc = RECORD cf: CF; access: INTEGER; name: ARRAY OJS.IdLen + nestedIdLen OF CHAR; descriptor: ARRAY DescLenMax OF CHAR; code: ARRAY CodeMax OF BYTE; i*: INTEGER; maxStack, curStack*, maxLocals: INTEGER; lineNumTab: ARRAY LineNumTabMax OF BYTE; lineIndex: INTEGER; END; VAR classMap: CpCache.Cache; PROCEDURE Init*; BEGIN NEW(classMap) END Init; PROCEDURE lengthUTF8(s: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER; VAR i,j, length: INTEGER; c: CHAR; BEGIN length := LEN(s); i := 0; j := 0; WHILE (j < length) & (s[j] # 0X) DO c := s[j]; IF (c >= 1X) & (c <= 7FX) THEN INC(i) ELSIF c > 7FFX THEN INC(i,3) ELSE INC(i, 2) END; INC(j); END; IF add0X THEN INC(i, 2) END RETURN i END lengthUTF8; PROCEDURE putUTF8(VAR buf: ARRAY OF BYTE; i: INTEGER; s: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER; VAR j, c, slen, buflen: INTEGER; BEGIN slen := LEN(s); buflen := LEN(buf); j := 0; WHILE (j < slen) & (ORD(s[j]) # 0H) DO c := ORD(s[j]); IF (c >= 1H) & (c <= 7FH) & (i < buflen) THEN buf[i] := c; INC(i) ELSIF (c > 7FFH) & (i+2 < buflen) THEN buf[i] := BOR(0E0H, AND(ASR(c, 12), 0FH)); buf[i+1] := BOR(80H, AND(ASR(c, 6), 3FH)); buf[i+2] := BOR(80H, AND(c, 3FH)); INC(i, 3) ELSIF (c >= 80H) & (c <= 7FFH) & (i+1 < buflen) THEN buf[i] := BOR(0C0H, AND(ASR(c, 6), 1FH)); buf[i+1] := BOR(80H, AND(c, 3FH)); INC(i, 2) ELSE OJS.Mark("Class file buffer limit reached"); j := slen END; INC(j); END; IF add0X & (i+1 < buflen) THEN buf[i] := 0C0H; buf[i+1] := 80H; INC(i, 2) END RETURN i END putUTF8; PROCEDURE putByte(VAR buf: ARRAY OF BYTE; i, x: INTEGER): INTEGER; BEGIN IF i < LEN(buf) THEN buf[i] := x; INC(i) ELSE OJS.Mark("Class file buffer limit reached") END RETURN i END putByte; PROCEDURE putNBytes(VAR buf: ARRAY OF BYTE; i: INTEGER; x: BYTE; n: INTEGER): INTEGER; BEGIN n := n + i; IF n-1 < LEN(buf) THEN WHILE(i < n) DO buf[i] := x; INC(i) END ELSE OJS.Mark("Class file buffer limit reached") END RETURN i END putNBytes; PROCEDURE putInt(VAR buf: ARRAY OF BYTE; i, x: INTEGER): INTEGER; BEGIN IF i+3 < LEN(buf) THEN buf[i] := ASR(x, 24); buf[i+1] := ASR(x, 16); buf[i+2] := ASR(x, 8); buf[i+3] := x; INC(i, 4) ELSE OJS.Mark("Class file buffer limit reached") END RETURN i END putInt; PROCEDURE putShort(VAR buf: ARRAY OF BYTE; i, x: INTEGER): INTEGER; BEGIN IF i+1 < LEN(buf) THEN buf[i] := ASR(x, 8); buf[i+1] := x; INC(i, 2) ELSE OJS.Mark("Class file buffer limit reached") END RETURN i END putShort; PROCEDURE putArray(VAR buf: ARRAY OF BYTE; i: INTEGER; x: ARRAY OF BYTE; len: INTEGER): INTEGER; VAR j: INTEGER; BEGIN j := 0; IF i+len-1 < LEN(buf) THEN WHILE j < len DO buf[i+j] := x[j]; INC(j) END; INC(i, j) ELSE OJS.Mark("Class file buffer limit reached") END RETURN i END putArray; PROCEDURE cpWriteUTF8(cf: CF; s: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER; VAR i, z: INTEGER; key: CpCache.Key; BEGIN z := Strings.Write(s, key, 0); IF add0X THEN z := Strings.WriteChar("$", key, z) END; z := Strings.WriteInt(UTF8, 0, key, z); IF z = -1 THEN OJS.Mark("internal cache buffer limit reached") END; i := CpCache.get(cf.cpCache, key); IF i = -1 THEN i := cf.cpCount; cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, UTF8); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, lengthUTF8(s, add0X)); cf.cpIndex := putUTF8(cf.constantPool, cf.cpIndex, s, add0X); INC(cf.cpCount); CpCache.put(cf.cpCache, key, i); END RETURN i END cpWriteUTF8; PROCEDURE cpWriteClass(cf: CF; s: ARRAY OF CHAR): INTEGER; VAR i, j, z: INTEGER; key: CpCache.Key; BEGIN z := Strings.Write(s, key, 0); z := Strings.WriteInt(CLASS, 0, key, z); IF z = -1 THEN OJS.Mark("internal cache buffer limit reached") END; j := CpCache.get(cf.cpCache, key); IF j = -1 THEN i := cpWriteUTF8(cf, s, FALSE); j := cf.cpCount; cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, CLASS); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i); INC(cf.cpCount); CpCache.put(cf.cpCache, key, j) END RETURN j END cpWriteClass; PROCEDURE cpWriteNameAndType(cf: CF; name, desc: ARRAY OF CHAR): INTEGER; VAR i, j, k, z: INTEGER; key: CpCache.Key; BEGIN z := Strings.Write(name, key, 0); z := Strings.Write(desc, key, z); z := Strings.WriteInt(NAMExTYPE, 0, key, z); IF z = -1 THEN OJS.Mark("internal cache buffer limit reached") END; k := CpCache.get(cf.cpCache, key); IF k = -1 THEN i := cpWriteUTF8(cf, name, FALSE); j := cpWriteUTF8(cf, desc, FALSE); k := cf.cpCount; cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, NAMExTYPE); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, j); INC(cf.cpCount); CpCache.put(cf.cpCache, key, k) END RETURN k END cpWriteNameAndType; PROCEDURE cpWriteString(cf: CF; val: ARRAY OF CHAR; add0X: BOOLEAN): INTEGER; VAR i, j, z: INTEGER; key: CpCache.Key; BEGIN z := Strings.Write(val, key, 0); IF add0X THEN z := Strings.WriteChar("$", key, z) END; z := Strings.WriteInt(STR, 0, key, z); IF z = -1 THEN OJS.Mark("internal cache buffer limit reached") END; j := CpCache.get(cf.cpCache, key); IF j = -1 THEN i := cpWriteUTF8(cf, val, add0X); j := cf.cpCount; cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, STR); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i); INC(cf.cpCount); CpCache.put(cf.cpCache, key, j) END RETURN j END cpWriteString; PROCEDURE cpWriteConst(cf: CF; tag, val: INTEGER): INTEGER; VAR i, z: INTEGER; key: CpCache.Key; BEGIN z := Strings.WriteInt(tag, 0, key, 0); z := Strings.WriteInt(val, 0, key, z); IF z = -1 THEN OJS.Mark("internal cache buffer limit reached") END; i := CpCache.get(cf.cpCache, key); IF i = -1 THEN i := cf.cpCount; cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, tag); cf.cpIndex := putInt(cf.constantPool, cf.cpIndex, val); INC(cf.cpCount); CpCache.put(cf.cpCache, key, i) END RETURN i END cpWriteConst; PROCEDURE cpWriteRef(cf: CF; tag: INTEGER; owner, name, desc: ARRAY OF CHAR): INTEGER; VAR i, j, k, z: INTEGER; key: CpCache.Key; BEGIN z := Strings.Write(owner, key, 0); z := Strings.Write(name, key, z); z := Strings.Write(desc, key, z); z := Strings.WriteInt(tag, 0, key, z); IF z = -1 THEN OJS.Mark("internal cache buffer limit reached") END; k := CpCache.get(cf.cpCache, key); IF k = -1 THEN i := cpWriteClass(cf, owner); j := cpWriteNameAndType(cf, name, desc); k := cf.cpCount; cf.cpIndex := putByte(cf.constantPool, cf.cpIndex, tag); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, i); cf.cpIndex := putShort(cf.constantPool, cf.cpIndex, j); INC(cf.cpCount); CpCache.put(cf.cpCache, key, k) END RETURN k END cpWriteRef; PROCEDURE cpWriteFiledRef(cf: CF; owner, name, desc: ARRAY OF CHAR): INTEGER; RETURN cpWriteRef(cf, FIELD, owner, name, desc) END cpWriteFiledRef; PROCEDURE cpWriteMethodRef(cf: CF; owner, name, desc: ARRAY OF CHAR): INTEGER; RETURN cpWriteRef(cf, METH, owner, name, desc) END cpWriteMethodRef; PROCEDURE addField*(cf: CF; access: INTEGER; name, desc: ARRAY OF CHAR); BEGIN cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, access); cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, cpWriteUTF8(cf, name, FALSE)); cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, cpWriteUTF8(cf, desc, FALSE)); (* attribute_count *) cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, 0); INC(cf.fieldsCount) END addField; PROCEDURE addConstField*(cf: CF; name, desc: ARRAY OF CHAR; val: INTEGER); VAR i: INTEGER; BEGIN cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL + Opcodes.ACCxSTATIC); cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, cpWriteUTF8(cf, name, FALSE)); cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, cpWriteUTF8(cf, desc, FALSE)); (* attribute_count: ConstantValue *) cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, 1); cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, cpWriteUTF8(cf, "ConstantValue", FALSE)); cf.fieldsIndex := putInt(cf.fields, cf.fieldsIndex, 2); IF desc[0] = "F" THEN i := cpWriteConst(cf, FLOAT, val) ELSE i := cpWriteConst(cf, INT, val) END; cf.fieldsIndex := putShort(cf.fields, cf.fieldsIndex, i); INC(cf.fieldsCount) END addConstField; PROCEDURE finalizeMethod*(cf: CF; mi: MethodInfo); BEGIN cf.methIndex := putShort(cf.methods, cf.methIndex, mi.access); cf.methIndex := putShort(cf.methods, cf.methIndex, cpWriteUTF8(cf, mi.name, FALSE)); cf.methIndex := putShort(cf.methods, cf.methIndex, cpWriteUTF8(cf, mi.descriptor, FALSE)); IF AND(mi.access, Opcodes.ACCxABSTRACT) = 0 THEN (* is abstract? *) (* attribute_count: code *) cf.methIndex := putShort(cf.methods, cf.methIndex, 1); cf.methIndex := putShort(cf.methods, cf.methIndex, cpWriteUTF8(cf, "Code", FALSE)); (* attribute_length *) cf.methIndex := putInt(cf.methods, cf.methIndex, 20 + mi.i + mi.lineIndex); cf.methIndex := putShort(cf.methods, cf.methIndex, mi.maxStack); cf.methIndex := putShort(cf.methods, cf.methIndex, mi.maxLocals); cf.methIndex := putInt(cf.methods, cf.methIndex, mi.i); cf.methIndex := putArray(cf.methods, cf.methIndex, mi.code, mi.i); (* exception_table_length *) cf.methIndex := putShort(cf.methods, cf.methIndex, 0); (* attribute_count: LineNumberTable *) cf.methIndex := putShort(cf.methods, cf.methIndex, 1); cf.methIndex := putShort(cf.methods, cf.methIndex, cpWriteUTF8(cf, "LineNumberTable", FALSE)); (* attribute_length *) cf.methIndex := putInt(cf.methods, cf.methIndex, 2 + mi.lineIndex); (* line_number_table_length *) cf.methIndex := putShort(cf.methods, cf.methIndex, mi.lineIndex DIV 4); cf.methIndex := putArray(cf.methods, cf.methIndex, mi.lineNumTab, mi.lineIndex) ELSE (* attribute_count: code *) cf.methIndex := putShort(cf.methods, cf.methIndex, 0) END; INC(cf.methCount) END finalizeMethod; PROCEDURE toFile*(cf: CF; path: ARRAY OF CHAR); VAR out: ARRAY ClassMax OF BYTE; i, err, sourceFile: INTEGER; f: Files.File; BEGIN (* CpCache.debug(cf.cpCache); *) sourceFile := cpWriteUTF8(cf, "SourceFile", FALSE); i := putInt(out, 0, 0CAFEBABEH); (* magic *) i := putInt(out, i, 49); (* Java 1.5 *) i := putShort(out, i, cf.cpCount); i := putArray(out, i, cf.constantPool, cf.cpIndex); i := putShort(out, i, cf.access); i := putShort(out, i, cf.thisIndex); i := putShort(out, i, cf.superIndex); i := putShort(out, i, 0); (* interfaces_count *) i := putShort(out, i, cf.fieldsCount); i := putArray(out, i, cf.fields, cf.fieldsIndex); i := putShort(out, i, cf.methCount); i := putArray(out, i, cf.methods, cf.methIndex); i := putShort(out, i, 1); (* attributes_count: SourceFile *) i := putShort(out, i, sourceFile); i := putInt(out, i, 2); (* attribute_length *) i := putShort(out, i, cf.sourceFileIndex); err := Files.IOERROR; IF OJS.errcnt = 0 THEN f := Files.Create(path); IF f # NIL THEN Files.WriteNBytes(f, out, i); Files.Close(f); err := Files.Status(f) END END; IF (err # Files.OK) & (OJS.errcnt = 0) THEN OJS.MarkAppend("Failed to write ", path) END END toFile; PROCEDURE NewCF*(acc: INTEGER; n, sn: ARRAY OF CHAR): CF; VAR cf: CF; className: Descriptor; BEGIN NEW(cf); Strings.Append(n, className); Strings.Append(".Mod", className); cf.access := acc; cf.cpCount := 1; cf.cpCache := CpCache.New(); cf.procMap := CpCache.New(); cf.methCount := 0; cf.fieldsCount := 0; cf.thisIndex := cpWriteClass(cf, n); cf.sourceFileIndex := cpWriteUTF8(cf, className, FALSE); cf.superIndex := cpWriteClass(cf, sn); IF CpCache.get(classMap, n) = 1 THEN OJS.Mark("type names must be unique") ELSE CpCache.put(classMap, n, 1) END RETURN cf END NewCF; PROCEDURE NewMI*(classFormat: CF; acc: INTEGER; n, desc: ARRAY OF CHAR): MethodInfo; VAR mi: MethodInfo; BEGIN NEW(mi); mi.cf := classFormat; mi.access := acc; mi.name := n; mi.descriptor := desc; mi.maxStack := 0; mi.maxLocals := 0; mi.curStack := 0; mi.lineIndex := 0; mi.i := 0; IF CpCache.get(mi.cf.procMap, mi.name) = 1 THEN OJS.Mark("procedure names must be unique") ELSE CpCache.put(mi.cf.procMap, mi.name, 1) END RETURN mi END NewMI; PROCEDURE setMaxStack(mi: MethodInfo); BEGIN IF mi.curStack > mi.maxStack THEN mi.maxStack := mi.curStack END END setMaxStack; PROCEDURE fix(mi: MethodInfo; at, with: INTEGER); VAR x: INTEGER; BEGIN x := putShort(mi.code, at+1, with) END fix; PROCEDURE FixLink*(mi: MethodInfo; L: INTEGER); VAR L1: INTEGER; BEGIN WHILE (L # 0) & (OJS.errcnt = 0) DO L1 := BOR(LSL(mi.code[L + 1], 8), mi.code[L + 2]); fix(mi, L, mi.i-L); L := L1 END END FixLink; PROCEDURE FixLinkWith*(mi: MethodInfo; L0, dst: INTEGER); VAR L1: INTEGER; BEGIN WHILE (L0 # 0) & (OJS.errcnt = 0) DO L1 := BOR(LSL(mi.code[L0 + 1], 8), mi.code[L0 + 2]); fix(mi, L0, dst-L0); L0 := L1 END END FixLinkWith; PROCEDURE merged*(mi: MethodInfo; L0, L1: INTEGER): INTEGER; VAR L2, L3: INTEGER; BEGIN IF L0 # 0 THEN L3 := L0; REPEAT L2 := L3; L3 := BOR(LSL(mi.code[L2 + 1], 8), mi.code[L2 + 2]); UNTIL L3 = 0; fix(mi, L2, L1); L1 := L0 END RETURN L1 END merged; PROCEDURE putMethodInsn*(mi: MethodInfo; opcode: INTEGER; owner, name, desc: ARRAY OF CHAR; args: INTEGER); BEGIN IF (opcode = Opcodes.INVOKEVIRTUAL) OR (opcode = Opcodes.INVOKESPECIAL) OR (opcode = Opcodes.INVOKEINTERFACE) THEN mi.curStack := mi.curStack - (args + 1) ELSE mi.curStack := mi.curStack - args; END; IF desc[Strings.Length(desc)-1] # "V" THEN INC(mi.curStack) END; setMaxStack(mi); mi.i := putByte(mi.code, mi.i, opcode); mi.i := putShort(mi.code, mi.i, cpWriteMethodRef(mi.cf, owner, name, desc)); END putMethodInsn; PROCEDURE addLineNumber*(mi: MethodInfo; line: INTEGER); BEGIN mi.lineIndex := putShort(mi.lineNumTab, mi.lineIndex, mi.i); mi.lineIndex := putShort(mi.lineNumTab, mi.lineIndex, line) END addLineNumber; PROCEDURE incStack(mi: MethodInfo; opcode: INTEGER); BEGIN CASE opcode OF Opcodes.AALOAD, Opcodes.ASTORE, Opcodes.ATHROW, Opcodes.BALOAD, Opcodes.CALOAD, Opcodes.D2I, Opcodes.FADD, Opcodes.FALOAD, Opcodes.FCMPG, Opcodes.FCMPL, Opcodes.FDIV, Opcodes.FMUL, Opcodes.FSTORE, Opcodes.FSUB, Opcodes.IADD, Opcodes.IALOAD, Opcodes.IAND, Opcodes.IFEQ, Opcodes.IFGE, Opcodes.IFGT, Opcodes.IFLE, Opcodes.IFLT, Opcodes.IFNE, Opcodes.IFNONNULL, Opcodes.IFNULL, Opcodes.IMUL, Opcodes.IOR, Opcodes.ISHL, Opcodes.ISHR, Opcodes.ISTORE, Opcodes.ISUB, Opcodes.IXOR, Opcodes.POP, Opcodes.PUTSTATIC, Opcodes.TABLESWITCH: INC(mi.curStack, -1) | Opcodes.IFACMPEQ, Opcodes.IFACMPNE, Opcodes.IFICMPEQ, Opcodes.IFICMPGE, Opcodes.IFICMPGT, Opcodes.IFICMPLE, Opcodes.IFICMPLT, Opcodes.IFICMPNE, Opcodes.POP2, Opcodes.PUTFIELD: INC(mi.curStack, -2) | Opcodes.AASTORE, Opcodes.BASTORE, Opcodes.CASTORE, Opcodes.FASTORE, Opcodes.IASTORE: INC(mi.curStack, -3) | Opcodes.DUP2: INC(mi.curStack, 2) | Opcodes.ACONSTNULL, Opcodes.ALOAD, Opcodes.BIPUSH, Opcodes.DUP, Opcodes.F2D, Opcodes.FCONST0, Opcodes.FCONST1, Opcodes.FCONST2, Opcodes.FLOAD, Opcodes.GETSTATIC, Opcodes.ICONSTM1, Opcodes.ICONST0, Opcodes.ICONST1, Opcodes.ICONST2, Opcodes.ICONST3, Opcodes.ICONST4, Opcodes.ICONST5, Opcodes.ILOAD, Opcodes.LDC, Opcodes.NEW, Opcodes.SIPUSH: INC(mi.curStack, 1) | Opcodes.ANEWARRAY, Opcodes.ARETURN, Opcodes.ARRAYLENGTH, Opcodes.CHECKCAST, Opcodes.FNEG, Opcodes.FRETURN, Opcodes.GETFIELD, Opcodes.GOTO, Opcodes.I2F, Opcodes.IINC, Opcodes.INEG, Opcodes.INSTANCEOF, Opcodes.IRETURN, Opcodes.NEWARRAY, Opcodes.RETURNx, Opcodes.SWAP: (* nothing to do *) END; setMaxStack(mi) END incStack; PROCEDURE putTypeInsn*(mi: MethodInfo; opcode: INTEGER; type: ARRAY OF CHAR); BEGIN incStack(mi, opcode); mi.i := putByte(mi.code, mi.i, opcode); mi.i := putShort(mi.code, mi.i, cpWriteClass(mi.cf, type)) END putTypeInsn; PROCEDURE putMultiANewArrayInsn*(mi: MethodInfo; desc: ARRAY OF CHAR; dims: INTEGER); BEGIN mi.curStack := mi.curStack - (dims - 1); setMaxStack(mi); mi.i := putByte(mi.code, mi.i, Opcodes.MULTIANEWARRAY); mi.i := putShort(mi.code, mi.i, cpWriteClass(mi.cf, desc)); mi.i := putByte(mi.code, mi.i, dims) END putMultiANewArrayInsn; PROCEDURE putTableSwitchInsn*(mi: MethodInfo; min, max, dflt, nLables: INTEGER; labels: ARRAY OF INTEGER); VAR j: INTEGER; BEGIN incStack(mi, Opcodes.TABLESWITCH); mi.i := putByte(mi.code, mi.i, Opcodes.TABLESWITCH); mi.i := putNBytes(mi.code, mi.i, 0, (4 - mi.i MOD 4) MOD 4); mi.i := putInt(mi.code, mi.i, dflt); mi.i := putInt(mi.code, mi.i, min); mi.i := putInt(mi.code, mi.i, max); FOR j := 0 TO nLables-1 DO mi.i := putInt(mi.code, mi.i, labels[j]) END END putTableSwitchInsn; PROCEDURE putIincInsn*(mi: MethodInfo; var, increment: INTEGER); BEGIN incStack(mi, Opcodes.IINC); mi.i := putByte(mi.code, mi.i, Opcodes.IINC); mi.i := putByte(mi.code, mi.i, var); mi.i := putByte(mi.code, mi.i, increment) END putIincInsn; PROCEDURE putLdcInsnInt*(mi: MethodInfo; type, c: INTEGER); VAR x: INTEGER; BEGIN incStack(mi, Opcodes.LDC); x := cpWriteConst(mi.cf, type, c); IF x <= 255 THEN mi.i := putByte(mi.code, mi.i, Opcodes.LDC); mi.i := putByte(mi.code, mi.i, x) ELSE mi.i := putByte(mi.code, mi.i, Opcodes.LDCW); mi.i := putShort(mi.code, mi.i, x) END END putLdcInsnInt; PROCEDURE putLdcInsnStr*(mi: MethodInfo; c: ARRAY OF CHAR; add0X: BOOLEAN); VAR x: INTEGER; BEGIN incStack(mi, Opcodes.LDC); x := cpWriteString(mi.cf, c, add0X); IF x <= 255 THEN mi.i := putByte(mi.code, mi.i, Opcodes.LDC); mi.i := putByte(mi.code, mi.i, x) ELSE mi.i := putByte(mi.code, mi.i, Opcodes.LDCW); mi.i := putShort(mi.code, mi.i, x) END END putLdcInsnStr; PROCEDURE putVarInsn*(mi: MethodInfo; opcode, var: INTEGER); VAR opt: INTEGER; BEGIN incStack(mi, opcode); IF var < 4 THEN IF opcode < Opcodes.ISTORE THEN (* ILOAD_0 *) opt := 26 + LSL((opcode - Opcodes.ILOAD), 2) + var ELSE (* ISTORE_0 *) opt := 59 + LSL((opcode - Opcodes.ISTORE), 2) + var END; mi.i := putByte(mi.code, mi.i, opt) ELSE mi.i := putByte(mi.code, mi.i, opcode); mi.i := putByte(mi.code, mi.i, var) END END putVarInsn; PROCEDURE putFieldInsn*(mi: MethodInfo; opcode: INTEGER; owner, name, desc: ARRAY OF CHAR); BEGIN incStack(mi, opcode); mi.i := putByte(mi.code, mi.i, opcode); mi.i := putShort(mi.code, mi.i, cpWriteFiledRef(mi.cf, owner, name, desc)) END putFieldInsn; PROCEDURE putIntInsn*(mi: MethodInfo; opcode, operand: INTEGER); BEGIN incStack(mi, opcode); mi.i := putByte(mi.code, mi.i, opcode); IF opcode = Opcodes.SIPUSH THEN mi.i := putByte(mi.code, mi.i, ASR(operand, 8)); mi.i := putByte(mi.code, mi.i, operand) ELSE (* BIPUSH or NEWARRAY *) mi.i := putByte(mi.code, mi.i, operand) END END putIntInsn; PROCEDURE putJumpInsn*(mi: MethodInfo; opcode, to: INTEGER); BEGIN incStack(mi, opcode); mi.i := putByte(mi.code, mi.i, opcode); mi.i := putShort(mi.code, mi.i, to) END putJumpInsn; PROCEDURE putGotoInsn*(mi: MethodInfo; to, incr: INTEGER); BEGIN INC(mi.curStack, incr); IF to <= ShortMaxValue THEN mi.i := putByte(mi.code, mi.i, Opcodes.GOTO); mi.i := putShort(mi.code, mi.i, to) ELSE mi.i := putByte(mi.code, mi.i, Opcodes.GOTOW); mi.i := putInt(mi.code, mi.i, to) END END putGotoInsn; PROCEDURE putInsn*(mi: MethodInfo; opcode: INTEGER); BEGIN incStack(mi, opcode); mi.i := putByte(mi.code, mi.i, opcode) END putInsn; PROCEDURE setMaxVars*(mi: MethodInfo; locals: INTEGER); BEGIN mi.maxLocals := locals END setMaxVars; END ClassFormat. ================================================ FILE: src/CpCache.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* A string to integer map used by ClassFormat *) MODULE CpCache; IMPORT Strings, OJS; CONST N = 997; (* prime number *) R = 31; (* prime number *) MaxKey* = OJS.stringBufSize; TYPE Node = POINTER TO NodeDesc; Key* = ARRAY MaxKey OF CHAR; NodeDesc = RECORD key: Key; val: INTEGER; next: Node END; Cache* = POINTER TO CacheDesc; CacheDesc* = RECORD map: ARRAY N OF Node; END; PROCEDURE hash(s: ARRAY OF CHAR): INTEGER; VAR h, i, len: INTEGER; BEGIN h := 0; i := 0; len := LEN(s); WHILE (i < len) & (s[i] # 0X) DO h := R * h + ORD(s[i]); INC(i) END (* MOD is >= 0 when N > 0 *) RETURN h MOD N END hash; PROCEDURE get*(m: Cache; k: ARRAY OF CHAR): INTEGER; VAR h, ret: INTEGER; c: Node; BEGIN h := hash(k); c := m.map[h]; WHILE (c # NIL) & (c.key # k) DO c := c.next END; IF c = NIL THEN ret := -1 ELSE ret := c.val END; RETURN ret END get; PROCEDURE put*(m: Cache; k: ARRAY OF CHAR; v: INTEGER); VAR h: INTEGER; r, c, tmp: Node; BEGIN h := hash(k); r := m.map[h]; c := r; WHILE (c # NIL) & (c.key # k) DO c := c.next END; IF c = NIL THEN NEW(tmp); Strings.Copy(k, tmp.key); tmp.val := v; tmp.next := r; m.map[h] := tmp ELSE c.val := v END END put; PROCEDURE New*(): Cache; VAR c: Cache; BEGIN NEW(c); RETURN c END New; END CpCache. ================================================ FILE: src/Files.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) DEFINITION Files; CONST OK = 0; EOF = -1; IOERROR = -2; UTF8ERROR = -3; TYPE File = POINTER TO FileDesc; FileDesc = RECORD END; VAR SEPARATOR: ARRAY 2 OF CHAR; PROCEDURE Create(name: ARRAY OF CHAR): File; PROCEDURE Open(name: ARRAY OF CHAR): File; PROCEDURE Close(file: File); PROCEDURE WriteAsciiStr(file: File; str: ARRAY OF CHAR); PROCEDURE WriteStr(file: File; str: ARRAY OF CHAR); PROCEDURE Write(file: File; b: BYTE); PROCEDURE WriteChar(file: File; c: CHAR); PROCEDURE WriteBytes(file: File; b: ARRAY OF BYTE); PROCEDURE WriteNBytes(file: File; b: ARRAY OF BYTE; len: INTEGER); PROCEDURE WriteInt(file: File; x: INTEGER); PROCEDURE WriteNum(file: File; x: INTEGER); PROCEDURE ReadNum(file: File): INTEGER; PROCEDURE Read(file: File): BYTE; PROCEDURE ReadChar(file: File): CHAR; PROCEDURE ReadInt(file: File): INTEGER; PROCEDURE ReadBytes(file: File; VAR b: ARRAY OF BYTE; VAR n: INTEGER); PROCEDURE ReadAsciiStr(file: File; VAR str: ARRAY OF CHAR); PROCEDURE ReadStr(file: File; VAR str: ARRAY OF CHAR): INTEGER; PROCEDURE Status(file: File): INTEGER; PROCEDURE Rename(from, to: ARRAY OF CHAR): INTEGER; PROCEDURE Exists(name: ARRAY OF CHAR): BOOLEAN; PROCEDURE Delete(name: ARRAY OF CHAR): INTEGER; PROCEDURE Seek(file: File; pos: INTEGER): INTEGER; PROCEDURE Size(file: File): INTEGER; END Files. ================================================ FILE: src/In.Mod ================================================ (* Copyright 2019 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Simple procedures to read from standard input in an interactive fashion. Done. Indicates the success of an input operation. If Done is TRUE after an input operation, the operation was successful and its result is valid. An unsuccessful input operation sets Done to FALSE; it remains FALSE until the next successful input operation. Each procedure reads the input stream and fills its parameter with input data when successful. String reads an entire line of input. *) DEFINITION In; VAR Done: BOOLEAN; PROCEDURE Char(VAR ch: CHAR); PROCEDURE String(VAR str: ARRAY OF CHAR); PROCEDURE Real(VAR x: REAL); PROCEDURE Int(VAR x: INTEGER); END In. ================================================ FILE: src/Math.Mod ================================================ (* Copyright 2020 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Math provides a basic set of general purpose mathematical functions using REAL arithmetic. It implements the interface described in "The Oakwood Guidelines for Oberon-2 Compiler Developers". *) DEFINITION Math; CONST pi = 3.14159265358979323846; e = 2.71828182845904523536; (* sqrt returns the square root of x, where x must be positive *) PROCEDURE sqrt(x: REAL): REAL; (* power returns base raised to the power of x. *) PROCEDURE power(x, base: REAL): REAL; (* exp returns Math.e raised to the power of x: power(x, e)*) PROCEDURE exp(x: REAL): REAL; (* ln returns the natural logarithm (base e) of x. *) PROCEDURE ln(x: REAL): REAL; (* log returns the logarithm of x base b. All positive arguments are allowed. The base b must be positive.*) PROCEDURE log(x, b: REAL): REAL; (* If the fraction part of x is in range 0.0 to 0.5 (excluded) then the result of round is the largest integer not greater than x, otherwise the result is x rounded up to the next highest whole number. Note that integer values cannot always be exactly represented in REAL format. *) PROCEDURE round(x: REAL): REAL; (* sin returns the sine value of x, where x is in radians. *) PROCEDURE sin(x: REAL): REAL; (* cos returns the cosine value of x, where x is in radians. *) PROCEDURE cos(x: REAL): REAL; (* tan returns the tangent value of x, where x is in radians. *) PROCEDURE tan(x: REAL): REAL; (* arcsin returns the arcsine value in radians of x, where x is in the sine value. *) PROCEDURE arcsin(x: REAL): REAL; (* arcos returns the arcos value in radians of x, where x is in the cosine value. *) PROCEDURE arccos(x: REAL): REAL; (* arctan returns the arctan value in radians of x, where x is in the tangent value. *) PROCEDURE arctan(x: REAL): REAL; (* arctan2 returns the quadrant-correct arc tangent atan(x/y). If the denominator y is zero, then the numerator x must not be zero. All arguments are legal except x = y = 0. *) PROCEDURE arctan2(x, y: REAL): REAL; (* sinh returns the hyperbolic sine of x. *) PROCEDURE sinh(x: REAL): REAL; (* cosh returns the hyperbolic cosine of x. *) PROCEDURE cosh(x: REAL): REAL; (* tanh returns the hyperbolic tangent of x. *) PROCEDURE tanh(x: REAL): REAL; (* arcsinh returns the arc hyperbolic sine of x. *) PROCEDURE arcsinh(x: REAL): REAL; (* arccosh returns the arc hyperbolic cosine of x. All arguments greater than or equal to 1 are legal. *) PROCEDURE arccosh(x: REAL): REAL; (* arctanh returns the arc hyperbolic tangent of x. *) PROCEDURE arctanh(x: REAL): REAL; END Math. ================================================ FILE: src/OJB.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Definition of data types Object, Type, and Module which together form the data structure called "symbol table". Contains procedures for creation of Objects, and for search. Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures Import and Export. This module contains the list of standard identifiers, with which the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *) MODULE OJB; IMPORT Files, OJS, ClassFormat, Strings, Os; CONST versionkey = 1; keypos = 2; MaxTyptab = 500; MaxLModtab = 100; MaxGModtab = 200; (* class values *) Head = 0; Const* = 1; Var* = 2; Par* = 3; ParStruct* = 4; Fld* = 5; Typ* = 6; SProc* = 7; SFunc* = 8; Mod* = 9; (* form values *) Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6; Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10; String* = 11; Array* = 12; Record* = 13; TYPE Object* = POINTER TO ObjDesc; Type* = POINTER TO TypeDesc; ObjDesc* = RECORD class*, modref: INTEGER; (* when class = Typ, lev <= 0 -> mno = -lev, 0 is the compiling module otherwise lev >= 0 -> scope level, 0 is the global scope *) lev*: INTEGER; expo*, rdo*: BOOLEAN; (*exported / read-only*) used: BOOLEAN; next*, dsc*: Object; type*: Type; recordType*, caseOrgType*: Type; (* computed, not serialized *) name*: OJS.Ident; (* Nested procedures and types (lev > 1, expo = FALSE) must have an unique bytecode name, as the nesting is flattened during code generation. nestedId is an unique integer that is appended to name in the bytecode. A valid nestedId is >= 1. *) nestedId*: INTEGER; val*, len*: INTEGER END ; TypeDesc* = RECORD form*, ref*: INTEGER; (*ref is only used for import/export*) nofpar*: INTEGER; (*for procedures, extension level for records*) len*: INTEGER; (*for arrays, len < 0 -> open array*) dsc*, typobj*: Object; base*: Type; (*for arrays, records, pointers*) signature*: ClassFormat.Descriptor; END; VAR topScope*, universe, system*: Object; byteType*, boolType*, charType*: Type; intType*, realType*, setType*, nilType*, noType*, strType*: Type; nofGMods, nofLMods, nofLTypes, anonRecIdx: INTEGER; GModtab: ARRAY MaxGModtab OF Object; (* GModtab[0] = compiling module *) LModtab: ARRAY MaxLModtab OF Object; LTyptab: ARRAY MaxTyptab OF Type; (* LTyptab[0] = NIL *) outFolder, homeFolder: ARRAY OJS.maxPath OF CHAR; PROCEDURE getOutputFolder*(VAR folder: ARRAY OF CHAR): INTEGER; VAR i: INTEGER; BEGIN i := Strings.Write(outFolder, folder, 0) RETURN i END getOutputFolder; PROCEDURE GetModFrom*(obj: Object): Object; VAR modIdx: INTEGER; BEGIN modIdx := 0; IF (obj # NIL) & (obj.lev < 0) THEN (* external type *) modIdx := -obj.lev; END RETURN GModtab[modIdx] END GetModFrom; (*insert new Object with name id*) PROCEDURE InsertObj*(id: OJS.Ident; class: INTEGER): Object; VAR new, x, obj: Object; BEGIN x := topScope; WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ; IF x.next = NIL THEN NEW(new); new.name := id; new.nestedId := 0; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL; new.modref := -1; (*un-marked*); new.lev := 0; new.len := 0; new.val := 0; new.expo := FALSE; new.type := noType; new.recordType := NIL; new.caseOrgType := NIL; new.used := FALSE; x.next := new; obj := new ELSE obj := x.next; OJS.Mark("mult def") END ; RETURN obj END InsertObj; PROCEDURE generateAnonymousTypeObj*(type: Type): Object; VAR anon: Object; BEGIN NEW(anon); Strings.Append("$Anonymous", anon.name); Strings.AppendInt(anonRecIdx, 0, anon.name); anon.class := Typ; anon.type := type; anon.lev := 0; anon.expo := FALSE; type.typobj := anon; INC(anonRecIdx) RETURN anon END generateAnonymousTypeObj; PROCEDURE thisObj*(name: ARRAY OF CHAR): Object; VAR s, x: Object; BEGIN s := topScope; REPEAT x := s.next; WHILE (x # NIL) & (x.name # name) DO x := x.next END ; IF (x # NIL) & (s # topScope) & (x.lev > 0) & (* no local or global *) (x.class IN {Var, Par, ParStruct}) THEN OJS.Mark("not accessible"); x := NIL END ; s := s.dsc UNTIL (x # NIL) OR (s = NIL); IF x # NIL THEN x.used := TRUE END RETURN x END thisObj; PROCEDURE thisimport*(mod: Object; name: ARRAY OF CHAR): Object; VAR obj: Object; BEGIN obj := NIL; IF (mod # NIL) & (mod.class = Mod) THEN obj := mod.dsc; WHILE (obj # NIL) & (~obj.expo OR (obj.name # name)) DO obj := obj.next END END RETURN obj END thisimport; PROCEDURE thisfield*(rec: Type): Object; VAR fld: Object; BEGIN fld := rec.dsc; WHILE (fld # NIL) & (fld.name # OJS.id) DO fld := fld.next END ; RETURN fld END thisfield; PROCEDURE FindObj*(modid, modName, name: ARRAY OF CHAR): Object; VAR obj: Object; BEGIN IF modid # modName THEN obj := thisObj(modName); obj := thisimport(obj, name) ELSE obj := thisObj(name) END RETURN obj END FindObj; PROCEDURE OpenScope*; VAR s: Object; BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s END OpenScope; PROCEDURE CheckUnused*(parsNum: INTEGER); VAR err: ARRAY OJS.IdLen*30 OF CHAR; i: INTEGER; x: Object; BEGIN x := topScope.next; i := 0; (* skip parameters *) WHILE i < parsNum DO x := x.next; INC(i) END; i := 0; WHILE x # NIL DO IF ~x.expo & ~x.used & ((x.class = Var) OR (x.class = Mod)) THEN i := Strings.Write(x.name, err, i); i := Strings.WriteChar(" ", err, i) END ; x := x.next END ; IF i # 0 THEN OJS.MarkAppend("Unused: ", err) END END CheckUnused; PROCEDURE CloseScope*; BEGIN topScope := topScope.dsc END CloseScope; (*------------------------------- Import ---------------------------------*) PROCEDURE MakeFileName*(useHome: BOOLEAN; VAR FName: ARRAY OF CHAR; name, ext: ARRAY OF CHAR); VAR i: INTEGER; BEGIN IF useHome THEN i := Strings.Write(homeFolder, FName, 0) ELSE i := getOutputFolder(FName) END ; i := Strings.Write(Files.SEPARATOR, FName, i); i := Strings.Write(name, FName, i); i := Strings.Write(ext, FName, i); IF i = -1 THEN OJS.Mark("Maximum file path length reached") END END MakeFileName; PROCEDURE findSymFile(VAR fname: ARRAY OF CHAR; modName: ARRAY OF CHAR): Files.File; VAR f: Files.File; BEGIN MakeFileName(FALSE, fname, modName, ".smb"); f := Files.Open(fname); IF f = NIL THEN MakeFileName(TRUE, fname, modName, ".smb"); f := Files.Open(fname) END RETURN f END findSymFile; PROCEDURE InsertImport(obj, mod: Object): Object; VAR prev, cur: Object; BEGIN IF mod.dsc = NIL THEN mod.dsc := obj ELSE prev := NIL; cur := mod.dsc; WHILE (cur # NIL) & (cur.name # obj.name) DO prev := cur; cur := cur.next END ; IF cur = NIL THEN prev.next := obj ELSE obj := cur END END ; obj.lev := mod.lev RETURN obj END InsertImport; PROCEDURE InsertMod(name: OJS.Ident; key: INTEGER): Object; VAR mod: Object; i: INTEGER; BEGIN i := 0; WHILE (i < nofGMods) & (name # GModtab[i].name) DO INC(i) END; IF i < nofGMods THEN (* module already imported *) mod := GModtab[i]; IF mod.val # key THEN OJS.Mark("key inconsistency of imported module") END ELSE NEW(mod); mod.class := Mod; mod.rdo := TRUE; mod.expo := FALSE; Strings.Copy(name, mod.name); mod.val := key; mod.lev := -nofGMods; mod.type := noType; mod.dsc := NIL; mod.next := NIL; mod.modref := -1; IF nofGMods < MaxGModtab THEN GModtab[nofGMods] := mod; INC(nofGMods) ELSE OJS.Mark("too many imported modules") END END RETURN mod END InsertMod; PROCEDURE InMod(f: Files.File; selfName: OJS.Ident): Object; VAR ref, key: INTEGER; name: OJS.Ident; mod: Object; BEGIN ref := Files.ReadNum(f); IF ref > 0 THEN (* first occurrence *) key := Files.ReadInt(f); Files.ReadAsciiStr(f, name); IF name = selfName THEN OJS.Mark("recursive import not allowed") END; mod := InsertMod(name, key); IF nofLMods < MaxLModtab THEN LModtab[nofLMods] := mod; INC(nofLMods) ELSE OJS.Mark("too many imported modules") END ELSE mod := LModtab[-ref] END RETURN mod END InMod; PROCEDURE InType(f: Files.File; selfName: OJS.Ident): Type; VAR class, form, np: INTEGER; fld, par, obj, last, mod: Object; typ, htyp: Type; name: OJS.Ident; BEGIN typ := NIL; IF Files.Status(f) = Files.OK THEN form := Files.ReadNum(f); IF form <= 0 THEN typ := LTyptab[-form] (* already read or NIL *) ELSE NEW(htyp); htyp.form := form; Files.ReadAsciiStr(f, name); IF name[0] # 0X THEN (* named type *) NEW(obj); Strings.Copy(name, obj.name); obj.expo := Files.ReadNum(f) = 1; obj.class := Typ; obj.type := htyp; htyp.typobj := obj; mod := InMod(f, selfName); obj := InsertImport(obj, mod); typ := obj.type ELSE typ := htyp END ; IF nofLTypes < MaxTyptab THEN LTyptab[nofLTypes] := typ; INC(nofLTypes) ELSE OJS.Mark("too many imported types") END; IF form = Pointer THEN htyp.base := InType(f, selfName) ELSIF form = Array THEN htyp.base := InType(f, selfName); htyp.len := Files.ReadNum(f) ELSIF form = Record THEN htyp.base := InType(f, selfName); IF htyp.base = NIL THEN obj := NIL ELSE obj := htyp.base.dsc END; class := Files.ReadNum(f); last := NIL; WHILE class # 0 DO (* fields *) NEW(fld); fld.class := class; Files.ReadAsciiStr(f, fld.name); fld.expo := TRUE; fld.type := InType(f, selfName); fld.recordType := htyp; fld.val := 0; class := Files.ReadNum(f); IF last = NIL THEN htyp.dsc := fld ELSE last.next := fld END ; last := fld END ; (* append base type fields *) IF last = NIL THEN htyp.dsc := obj ELSE last.next := obj END ELSIF form = Proc THEN htyp.base := InType(f, selfName); Files.ReadAsciiStr(f, htyp.signature); np := Files.ReadNum(f); htyp.nofpar := np; par := NIL; last := NIL; WHILE np > 0 DO (* parameters *) NEW(obj); obj.class := Files.ReadNum(f); obj.rdo := Files.ReadNum(f) = 1; obj.type := InType(f, selfName); IF par = NIL THEN par := obj ELSE last.next := obj END; last := obj; DEC(np) END ; htyp.dsc := par END END END RETURN typ END InType; PROCEDURE Import*(VAR aliasName, impName, selfName: OJS.Ident); VAR class, version, i: INTEGER; obj, mod, mod0, dummyMod: Object; dummyType: Type; name: OJS.Ident; fname: ARRAY OJS.maxPath OF CHAR; str: ARRAY OJS.stringBufSize OF CHAR; f: Files.File; BEGIN IF impName = "SYSTEM" THEN mod := InsertObj(aliasName, Mod); mod.dsc := system; mod.rdo := TRUE ELSE f := findSymFile(fname, impName); IF f # NIL THEN nofLMods := 0; nofLTypes := Record + 1; version := Files.ReadNum(f); IF version # versionkey THEN OJS.Mark("wrong symbol version key") END; mod0 := InMod(f, selfName); IF mod0.name # impName THEN OJS.Mark("inconsistent module name") END; (* Read imported modules *) i := Files.ReadNum(f); WHILE i > 0 DO dummyMod := InMod(f, selfName); DEC(i) END; class := Files.ReadNum(f); WHILE (class # 0) & (Files.Status(f) = Files.OK) DO IF class = Typ THEN Files.ReadAsciiStr(f, name); IF name[0] # 0X THEN (* alias type *) NEW(obj); Strings.Copy(name, obj.name); obj.class := class; obj.expo := TRUE; obj.type := InType(f, selfName); obj := InsertImport(obj, mod0) ELSE (* other types *) dummyType := InType(f, selfName) END ELSE Files.ReadAsciiStr(f, name); NEW(obj); Strings.Copy(name, obj.name); obj.class := class; obj.expo := TRUE; obj.type := InType(f, selfName); IF class = Const THEN IF obj.type.form = Real THEN obj.val := Files.ReadInt(f) ELSIF obj.type.form = String THEN obj.len := Files.ReadStr(f, str) + 1; (* length + 0X *) obj.val := OJS.InsertStr(str, obj.len) ELSE obj.val := Files.ReadNum(f) END ELSIF class = Var THEN obj.rdo := TRUE END ; obj := InsertImport(obj, mod0) END ; class := Files.ReadNum(f) END ; mod := InsertObj(aliasName, Mod); mod.rdo := TRUE; mod.val := mod0.val; mod.lev := mod0.lev; mod.dsc := mod0.dsc; Files.Close(f); IF Files.Status(f) = Files.IOERROR THEN OJS.MarkAppend("error importing ", fname) END ELSE OJS.MarkAppend("import not available: ", fname) END END END Import; (*-------------------------------- Export ---------------------------------*) PROCEDURE OutMod(f: Files.File; mod: Object); BEGIN IF mod.modref < 0 THEN (* first occurrence *) mod.modref := nofLMods; INC(nofLMods); Files.WriteNum(f, Mod); Files.WriteInt(f, mod.val); Files.WriteAsciiStr(f, mod.name) ELSE Files.WriteNum(f, -mod.modref) END END OutMod; PROCEDURE OutType(f: Files.File; t: Type); VAR fld, par, bot: Object; np: INTEGER; BEGIN IF Files.Status(f) = Files.OK THEN IF t = NIL THEN Files.WriteNum(f, 0) ELSIF t.ref > 0 THEN (*type was already output*) Files.WriteNum(f, -t.ref) ELSE Files.WriteNum(f, t.form); t.ref := nofLTypes; INC(nofLTypes); IF t.typobj # NIL THEN (* named type *) Files.WriteAsciiStr(f, t.typobj.name); IF ~t.typobj.expo THEN (* invisible type *) Files.WriteNum(f, 0) ELSE Files.WriteNum(f, 1) END ; OutMod(f, GModtab[-t.typobj.lev]) ELSE Files.WriteNum(f, 0) END ; IF t.form = Pointer THEN OutType(f, t.base) ELSIF t.form = Array THEN OutType(f, t.base); Files.WriteNum(f, t.len) ELSIF t.form = Record THEN OutType(f, t.base); IF t.base # NIL THEN bot := t.base.dsc ELSE bot := NIL END ; fld := t.dsc; WHILE fld # bot DO (*fields*) IF fld.expo THEN Files.WriteNum(f, Fld); Files.WriteAsciiStr(f, fld.name); OutType(f, fld.type) END ; fld := fld.next END ; Files.WriteNum(f, 0) ELSIF t.form = Proc THEN OutType(f, t.base); Files.WriteAsciiStr(f, t.signature); par := t.dsc; np := t.nofpar; Files.WriteNum(f, np); WHILE np > 0 DO Files.WriteNum(f, par.class); IF par.rdo THEN Files.WriteNum(f, 1) ELSE Files.WriteNum(f, 0) END; OutType(f, par.type); par := par.next; DEC(np) END END END END END OutType; PROCEDURE readOldKey(filename: ARRAY OF CHAR; VAR oldkey: INTEGER): BOOLEAN; VAR f: Files.File; ok: BOOLEAN; BEGIN ok := FALSE; f := Files.Open(filename); IF (f # NIL) & (Files.Seek(f, keypos) = Files.OK) THEN oldkey := Files.ReadInt(f); Files.Close(f); ok := Files.Status(f) = Files.OK END RETURN ok END readOldKey; PROCEDURE Export*(VAR modid: OJS.Ident; newSF: BOOLEAN); VAR x, sum, i, r, len, rename, oldkey: INTEGER; obj: Object; filename, tmpFile: ARRAY OJS.maxPath OF CHAR; str: ARRAY OJS.stringBufSize OF CHAR; f: Files.File; found: BOOLEAN; BEGIN rename := Files.OK; nofLMods := 0; nofLTypes := Record + 1; MakeFileName(FALSE, filename, modid, ".smb"); MakeFileName(FALSE, tmpFile, modid, ".smb.tmp"); f := Files.Create(tmpFile); IF f # NIL THEN Files.WriteNum(f, versionkey); OutMod(f, GModtab[0]); (* Write imported modules *) Files.WriteNum(f, nofGMods - 1); i := 1; WHILE i < nofGMods DO OutMod(f, GModtab[i]); INC(i) END; obj := topScope.next; WHILE (obj # NIL) & (Files.Status(f) = Files.OK) DO IF obj.expo THEN Files.WriteNum(f, obj.class); IF (obj.class # Typ) OR (obj.type.typobj # obj) THEN (* no type or alias type *) Files.WriteAsciiStr(f, obj.name) ELSE (* other type, write name in OutType *) Files.WriteNum(f, 0) END ; OutType(f, obj.type); IF obj.class = Const THEN IF obj.type.form = Real THEN Files.WriteInt(f, obj.val) ELSIF obj.type.form = String THEN OJS.ExtractStr(obj.val, obj.len, str); Files.WriteStr(f, str) ELSE Files.WriteNum(f, obj.val) END END END ; obj := obj.next; END ; len := Files.Size(f); IF len # -1 THEN REPEAT Files.WriteNum(f, 0); INC(len) UNTIL len MOD 4 = 0; END ; (* reset local type table *) FOR nofLTypes := Record+1 TO MaxTyptab-1 DO LTyptab[nofLTypes] := NIL END ; (* compute key (checksum) *) r := Files.Seek(f, 0); sum := Files.ReadInt(f); i := 4; WHILE (i < len) & (Files.Status(f) = Files.OK) DO x := Files.ReadInt(f); sum := sum + x; INC(i, 4) END ; found := readOldKey(filename, oldkey); IF ~found OR (sum # oldkey) THEN IF newSF OR ~found THEN r := Files.Seek(f, keypos); Files.WriteInt(f, sum); (*insert checksum*) Files.Close(f); rename := Files.Rename(tmpFile, filename) ELSE Files.Close(f); OJS.Mark("new symbol file inhibited") END ELSE Files.Close(f); r := Files.Delete(tmpFile) END ; IF (Files.Status(f) = Files.IOERROR) OR (rename = Files.IOERROR) OR (r = Files.IOERROR) THEN OJS.MarkAppend("error exporting ", filename) END ELSE OJS.MarkAppend("error while creating symbol file ", filename) END END Export; PROCEDURE Init*(outputFolder: ARRAY OF CHAR; modid: OJS.Ident); VAR dummy: Object; BEGIN topScope := universe; nofGMods := 0; anonRecIdx := 0; Strings.Copy(outputFolder, outFolder); dummy := InsertMod(modid, 0) END Init; PROCEDURE type(ref, form: INTEGER): Type; VAR tp: Type; BEGIN NEW(tp); tp.form := form; tp.ref := ref; tp.base := NIL; LTyptab[ref] := tp RETURN tp END type; PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: INTEGER); VAR obj: Object; BEGIN NEW(obj); Strings.Copy(name, obj.name); obj.class := cl; obj.type := type; obj.val := n; obj.dsc := NIL; IF cl = Typ THEN type.typobj := obj END ; obj.next := system; system := obj END enter; BEGIN byteType := type(Byte, Int); boolType := type(Bool, Bool); charType := type(Char, Char); intType := type(Int, Int); realType := type(Real, Real); setType := type(Set, Set); nilType := type(NilTyp, NilTyp); noType := type(NoTyp, NoTyp); strType := type(String, String); (*initialize universe with data types and in-line procedures; LONGINT is synonym to INTEGER, LONGREAL to REAL. *) system := NIL; (*n = procno*10 + nofpar*) enter("BOR", SFunc, intType, 122); (*functions*) enter("AND", SFunc, intType, 112); enter("NOT", SFunc, intType, 151); enter("ROR", SFunc, intType, 92); enter("ASR", SFunc, intType, 82); enter("LSL", SFunc, intType, 72); enter("LEN", SFunc, intType, 61); enter("CHR", SFunc, charType, 51); enter("ORD", SFunc, intType, 41); enter("FLT", SFunc, realType, 31); enter("FLOOR", SFunc, intType, 21); enter("ODD", SFunc, boolType, 11); enter("ABS", SFunc, intType, 1); enter("NEW", SProc, noType, 51); enter("ASSERT", SProc, noType, 41); enter("EXCL", SProc, noType, 32); enter("INCL", SProc, noType, 22); enter("DEC", SProc, noType, 11); enter("INC", SProc, noType, 1); enter("SET", Typ, setType, 0); (*types*) enter("BOOLEAN", Typ, boolType, 0); enter("BYTE", Typ, byteType, 0); enter("CHAR", Typ, charType, 0); enter("LONGREAL", Typ, realType, 0); enter("REAL", Typ, realType, 0); enter("LONGINT", Typ, intType, 0); enter("INTEGER", Typ, intType, 0); enter("ARGNUM", SFunc, intType, 230); enter("ARGS", SProc, noType, 242); (* Useful during bootstrapping *) enter("eot", SFunc, boolType, 210); enter("ReadInt", SFunc, intType, 220); enter("WriteChar", SProc, noType, 151); enter("WriteInt", SProc, noType, 161); enter("WriteLn", SProc, noType, 170); enter("WriteReal", SProc, noType, 181); topScope := NIL; OpenScope; topScope.next := system; universe := topScope; system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*) enter("VAL", SFunc, intType, 162); system.expo := TRUE; (* export VAL *) Os.GetEnv(homeFolder, "OBERON_BIN"); IF homeFolder = "" THEN homeFolder := "." END END OJB. ================================================ FILE: src/OJG.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (*Code generator for Oberon compiler for the Java Virtual Machine.*) MODULE OJG; IMPORT SYSTEM, Files, Opcodes, Strings, ClassFormat, OJS, OJB; CONST NofCases* = 256; MaxSetElement* = 32; ParamsMax* = 20; Stack = 10; RegI = 11; Cond = 12; Field = 13; (*internal item modes*) TYPE Item* = RECORD mode*: INTEGER; type*, oldType*: OJB.Type; a*, b*, r: INTEGER; rdo*: BOOLEAN; (*read only*) name*: ARRAY OJS.IdLen + ClassFormat.nestedIdLen OF CHAR; modName*: OJS.Ident; recordName: ClassFormat.Descriptor END ; LabelRange* = RECORD low*, high*, L*: INTEGER END ; StoreStmt = POINTER TO StoreStmtDesc; StoreStmtDesc = RECORD x, y: Item; next: StoreStmt END ; ClassContext = POINTER TO ClassContextDesc; ClassContextDesc = RECORD c: ClassFormat.CF; m: ClassFormat.MethodInfo; className: ClassFormat.Descriptor; numTmpVars: INTEGER; storeStmt: StoreStmt; next: ClassContext END ; VAR check: BOOLEAN; (*emit run-time checks*) topCtx: ClassContext; relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*) relmap0: ARRAY 6 OF INTEGER; (*condition codes for relations with 0*) relmapNil: ARRAY 2 OF INTEGER; (*condition codes for relations with NIL*) relmapAdr: ARRAY 2 OF INTEGER; (*condition codes for relations with adr*) dummyMethod: ClassFormat.MethodInfo; PROCEDURE curStack*(): INTEGER; RETURN topCtx.m.curStack END curStack; PROCEDURE clearCtx(ctx: ClassContext); BEGIN ctx.numTmpVars := 0 END clearCtx; PROCEDURE closeContext; BEGIN ClassFormat.finalizeMethod(topCtx.c, topCtx.m); clearCtx(topCtx); topCtx.m := dummyMethod END closeContext; PROCEDURE SetCC(VAR x: Item; n: INTEGER); BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n; END SetCC; PROCEDURE negated(op: INTEGER): INTEGER; VAR ret: INTEGER; BEGIN ret := 0; CASE op OF Opcodes.IFACMPEQ: ret := Opcodes.IFACMPNE | Opcodes.IFACMPNE: ret := Opcodes.IFACMPEQ | Opcodes.IFEQ: ret := Opcodes.IFNE | Opcodes.IFNE: ret := Opcodes.IFEQ | Opcodes.IFLT: ret := Opcodes.IFGE | Opcodes.IFGE: ret := Opcodes.IFLT | Opcodes.IFGT: ret := Opcodes.IFLE | Opcodes.IFLE: ret := Opcodes.IFGT | Opcodes.IFICMPEQ: ret := Opcodes.IFICMPNE | Opcodes.IFICMPNE: ret := Opcodes.IFICMPEQ | Opcodes.IFNULL: ret := Opcodes.IFNONNULL | Opcodes.IFNONNULL: ret := Opcodes.IFNULL | Opcodes.IFICMPLT: ret := Opcodes.IFICMPGE | Opcodes.IFICMPGE: ret := Opcodes.IFICMPLT | Opcodes.IFICMPLE: ret := Opcodes.IFICMPGT | Opcodes.IFICMPGT: ret := Opcodes.IFICMPLE END RETURN ret END negated; PROCEDURE normalize(s: ARRAY OF CHAR; VAR out: ARRAY OF CHAR; i: INTEGER): INTEGER; VAR ch: CHAR; j, slen, olen: INTEGER; BEGIN IF i >= 0 THEN j := 0; slen := LEN(s); olen := LEN(out)-1; WHILE (j < slen) & (i < olen) & (s[j] # 0X) DO ch := s[j]; IF (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z") THEN ch := "x" END ; out[i] := ch; INC(i); INC(j) END ; out[i] := 0X END RETURN i END normalize; PROCEDURE internalNameAt(type: OJB.Type; VAR out: ARRAY OF CHAR; i: INTEGER): INTEGER; VAR mod: OJB.Object; BEGIN IF type.form = OJB.Record THEN mod := OJB.GetModFrom(type.typobj); i := Strings.Write(mod.name, out, i); i := Strings.WriteChar("_", out, i); i := Strings.Write(type.typobj.name, out, i); IF type.typobj.nestedId > 0 THEN i := Strings.WriteInt(type.typobj.nestedId, 0, out, i) END ELSIF type.form = OJB.Pointer THEN mod := OJB.GetModFrom(type.base.typobj); i := Strings.Write(mod.name, out, i); i := Strings.WriteChar("_", out, i); i := Strings.Write(type.base.typobj.name, out, i); IF type.base.typobj.nestedId > 0 THEN i := Strings.WriteInt(type.base.typobj.nestedId, 0, out, i) END ELSIF type.form = OJB.Proc THEN i := normalize(type.signature, out, i) END RETURN i END internalNameAt; PROCEDURE internalName(type: OJB.Type; VAR out: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := internalNameAt(type, out, 0); IF (i = -1) THEN OJS.Mark("Maximum descriptor length reached") END END internalName; PROCEDURE DescriptorR(type: OJB.Type; VAR out: ARRAY OF CHAR; i: INTEGER): INTEGER; BEGIN IF type = OJB.boolType THEN i := Strings.WriteChar("Z", out, i) ELSIF (type = OJB.intType) OR (type = OJB.setType) THEN i := Strings.WriteChar("I", out, i) ELSIF type = OJB.byteType THEN i := Strings.WriteChar("B", out, i) ELSIF type = OJB.charType THEN i := Strings.WriteChar("C", out, i) ELSIF type = OJB.realType THEN i := Strings.WriteChar("F", out, i) ELSIF type = OJB.noType THEN i := Strings.WriteChar("V", out, i) ELSIF (type.form = OJB.Record) OR (type.form = OJB.Pointer) THEN i := Strings.WriteChar("L", out, i); i := internalNameAt(type, out, i); i := Strings.WriteChar(";", out, i) ELSIF type.form = OJB.Array THEN i := Strings.WriteChar("[", out, i); i := DescriptorR(type.base, out, i) ELSIF type.form = OJB.Proc THEN i := Strings.WriteChar("L", out, i); i := normalize(type.signature, out, i); i := Strings.WriteChar(";", out, i) END RETURN i END DescriptorR; PROCEDURE DescriptorProc(type: OJB.Type; end: INTEGER; VAR desc: ARRAY OF CHAR); VAR args: OJB.Object; i, j: INTEGER; BEGIN i := 0; j := 0; j := Strings.WriteChar("(", desc, j); args := type.dsc; WHILE (args # NIL) & (i < end) DO IF args.class = OJB.Par THEN j := Strings.WriteChar("[", desc, j) END ; j := DescriptorR(args.type, desc, j); args := args.next; INC(i) END ; j := Strings.WriteChar(")", desc, j); j := DescriptorR(type.base, desc, j); IF j = -1 THEN OJS.Mark("Maximum descriptor length reached") END END DescriptorProc; PROCEDURE DescriptorAt(type: OJB.Type; VAR desc: ARRAY OF CHAR; i: INTEGER); VAR x: INTEGER; BEGIN x := DescriptorR(type, desc, i); IF x = -1 THEN OJS.Mark("Maximum descriptor length reached") END END DescriptorAt; PROCEDURE Descriptor(type: OJB.Type; VAR desc: ARRAY OF CHAR); BEGIN DescriptorAt(type, desc, 0) END Descriptor; PROCEDURE pushTypedLocal(VAR x: Item); BEGIN IF (x.type = OJB.intType) OR (x.type = OJB.boolType) OR (x.type = OJB.charType) OR (x.type = OJB.setType) OR (x.type = OJB.byteType ) THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, x.a) ELSIF x.type = OJB.realType THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.FLOAD, x.a) ELSE ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a) END END pushTypedLocal; PROCEDURE pushTypedArray(type: OJB.Type); BEGIN IF (type = OJB.intType) OR (type = OJB.setType) THEN ClassFormat.putInsn(topCtx.m, Opcodes.IALOAD) ELSIF type = OJB.realType THEN ClassFormat.putInsn(topCtx.m, Opcodes.FALOAD) ELSIF (type = OJB.boolType) OR (type = OJB.byteType) THEN ClassFormat.putInsn(topCtx.m, Opcodes.BALOAD) ELSIF type = OJB.charType THEN ClassFormat.putInsn(topCtx.m, Opcodes.CALOAD) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.AALOAD) END END pushTypedArray; PROCEDURE storeTypedLocal(VAR x: Item); BEGIN IF (x.type = OJB.intType) OR (x.type = OJB.boolType) OR (x.type = OJB.charType) OR (x.type = OJB.setType) OR (x.type = OJB.byteType) THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, x.a) ELSIF x.type = OJB.realType THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.FSTORE, x.a) ELSE ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, x.a) END END storeTypedLocal; PROCEDURE storeTypedArray(type: OJB.Type); BEGIN IF (type = OJB.intType) OR (type = OJB.setType) THEN ClassFormat.putInsn(topCtx.m, Opcodes.IASTORE) ELSIF (type = OJB.boolType) OR (type = OJB.byteType) THEN ClassFormat.putInsn(topCtx.m, Opcodes.BASTORE) ELSIF type = OJB.charType THEN ClassFormat.putInsn(topCtx.m, Opcodes.CASTORE) ELSIF type = OJB.realType THEN ClassFormat.putInsn(topCtx.m, Opcodes.FASTORE) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.AASTORE) END END storeTypedArray; PROCEDURE pushConst*(a: INTEGER); BEGIN IF (a = -1) OR (a >= 0) & (a <= 5) THEN CASE a OF -1: ClassFormat.putInsn(topCtx.m, Opcodes.ICONSTM1) | 0: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0) | 1: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST1) | 2: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST2) | 3: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST3) | 4: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST4) | 5: ClassFormat.putInsn(topCtx.m, Opcodes.ICONST5) END ELSIF (a >= -128) & (a <= 127) THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.BIPUSH, a) ELSIF (a >= -32768) & (a <= 32767) THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.SIPUSH, a) ELSE ClassFormat.putLdcInsnInt(topCtx.m, ClassFormat.INT, a) END END pushConst; PROCEDURE pushRealConst(a: INTEGER); VAR num: REAL; BEGIN num := SYSTEM.VAL(REAL, a); IF num = 0.0 THEN ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0) ELSIF num = 1.0 THEN ClassFormat.putInsn(topCtx.m, Opcodes.FCONST1) ELSIF num = 2.0 THEN ClassFormat.putInsn(topCtx.m, Opcodes.FCONST2) ELSE ClassFormat.putLdcInsnInt(topCtx.m, ClassFormat.FLOAT, a) END END pushRealConst; PROCEDURE isPrimitiveType(type: OJB.Type): BOOLEAN; RETURN (type = OJB.boolType) OR (type = OJB.charType) OR (type = OJB.realType) OR (type = OJB.setType) OR (type = OJB.byteType) OR (type = OJB.intType) END isPrimitiveType; PROCEDURE findMultiArrayDimension(type: OJB.Type; skipPrimitiveAndPtrArrays: BOOLEAN): INTEGER; VAR i: INTEGER; tmp: OJB.Type; BEGIN i := 1; tmp := type.base; WHILE tmp.form = OJB.Array DO tmp := tmp.base; INC(i) END ; IF skipPrimitiveAndPtrArrays & (isPrimitiveType(tmp) OR (tmp.form = OJB.Pointer) OR (tmp.form = OJB.Proc)) THEN i := 0 END RETURN i END findMultiArrayDimension; PROCEDURE NewTmpObj(i: INTEGER; root: OJB.Object; type: OJB.Type; size: INTEGER): OJB.Object; VAR new: OJB.Object; BEGIN NEW(new); Strings.Append("@tmp", new.name); Strings.AppendInt(i, 0, new.name); new.class := OJB.Var; new.type := type; new.val := size; new.next := root; RETURN new END NewTmpObj; PROCEDURE storeRef(x: OJB.Object); VAR desc, iname: ClassFormat.Descriptor; BEGIN IF x.lev = 0 THEN Descriptor(x.type, desc); IF x.class = OJB.Fld THEN internalName(x.recordType, iname); ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTFIELD, iname, x.name, desc) ELSE ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, topCtx.className, x.name, desc) END ELSE ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, x.val) END END storeRef; PROCEDURE loadRef(x: OJB.Object); VAR desc, iname: ClassFormat.Descriptor; BEGIN IF x.lev = 0 THEN Descriptor(x.type, desc); IF x.class = OJB.Fld THEN internalName(x.recordType, iname); ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETFIELD, iname, x.name, desc) ELSE ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, topCtx.className, x.name, desc) END ELSE ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.val) END END loadRef; PROCEDURE getLocalVars(obj: OJB.Object; end: INTEGER): OJB.Object; VAR i: INTEGER; BEGIN i := 0; WHILE (obj # NIL) & (i < end) DO obj := obj.next; INC(i) END RETURN obj END getLocalVars; PROCEDURE createArraysTempVars(topScope: OJB.Object; VAR size: INTEGER; skipPrimitiveAndPtrArrays: BOOLEAN): OJB.Object; VAR maxArrayDimension: INTEGER; tmp, vars: OJB.Object; dim, i: INTEGER; BEGIN maxArrayDimension := 0; tmp := topScope; vars := NIL; i := 0; WHILE tmp # NIL DO IF ((tmp.class = OJB.Var) OR (tmp.class = OJB.Fld)) & (tmp.type.form = OJB.Array) THEN dim := findMultiArrayDimension(tmp.type, skipPrimitiveAndPtrArrays); IF dim > maxArrayDimension THEN WHILE maxArrayDimension < dim DO vars := NewTmpObj(i, vars, OJB.intType, size); INC(maxArrayDimension); INC(i); INC(size) END END END ; tmp := tmp.next END RETURN vars END createArraysTempVars; PROCEDURE initializeLocalVar(x: OJB.Object); BEGIN IF (x.type = OJB.intType) OR (x.type = OJB.boolType) OR (x.type = OJB.setType) OR (x.type = OJB.byteType) OR (x.type = OJB.charType) THEN ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0); ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, x.val) ELSIF x.type = OJB.realType THEN ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0); ClassFormat.putVarInsn(topCtx.m, Opcodes.FSTORE, x.val) ELSE (* x.class = ORB.Pointer *) ClassFormat.putInsn(topCtx.m, Opcodes.ACONSTNULL); ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, x.val) END END initializeLocalVar; PROCEDURE emitPrimitiveNewArray(type: OJB.Type); BEGIN IF type = OJB.boolType THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TBOOLEAN) ELSIF type = OJB.charType THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TCHAR) ELSIF type = OJB.realType THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TFLOAT) ELSIF type = OJB.byteType THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TBYTE) ELSIF (type = OJB.intType) OR (type = OJB.setType) THEN ClassFormat.putIntInsn(topCtx.m, Opcodes.NEWARRAY, Opcodes.TINT) END END emitPrimitiveNewArray; PROCEDURE getLastArray(type: OJB.Type): OJB.Type; VAR last: OJB.Type; BEGIN last := NIL; WHILE type.form = OJB.Array DO last := type; type := type.base END RETURN last END getLastArray; PROCEDURE Fixup*(L: INTEGER); BEGIN ClassFormat.FixLink(topCtx.m, L) END Fixup; PROCEDURE pushIndexes(i: INTEGER; tmpVars: OJB.Object): OJB.Object; VAR k: INTEGER; BEGIN k := 0; WHILE k # i-1 DO ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, tmpVars.val); ClassFormat.putInsn(topCtx.m, Opcodes.AALOAD); tmpVars := tmpVars.next; INC(k) END RETURN tmpVars END pushIndexes; PROCEDURE pushIndexes2(i: INTEGER): INTEGER; VAR tmpVars, k: INTEGER; BEGIN tmpVars := topCtx.numTmpVars - i; k := 0; WHILE k < i-1 DO ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, tmpVars); ClassFormat.putInsn(topCtx.m, Opcodes.AALOAD); INC(tmpVars); INC(k) END RETURN tmpVars END pushIndexes2; PROCEDURE genNew(typeName: ARRAY OF CHAR); BEGIN ClassFormat.putTypeInsn(topCtx.m, Opcodes.NEW, typeName); ClassFormat.putInsn(topCtx.m, Opcodes.DUP); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, typeName, "", "()V", 0) END genNew; PROCEDURE initializeMultiDimArray(i: INTEGER; x: OJB.Object; type: OJB.Type; tmpVars, currTmpVar: OJB.Object); VAR iname: ClassFormat.Descriptor; cond, end: INTEGER; BEGIN IF type.form = OJB.Array THEN pushConst(type.len - 1); ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, currTmpVar.val); cond := topCtx.m.i; ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, currTmpVar.val); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFLT, 0); initializeMultiDimArray(i + 1, x, type.base, tmpVars, currTmpVar.next); ClassFormat.putIincInsn(topCtx.m, currTmpVar.val, -1); ClassFormat.putGotoInsn(topCtx.m, cond-topCtx.m.i, 0); Fixup(end) ELSE IF x.class = OJB.Fld THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0) END ; loadRef(x); tmpVars := pushIndexes(i, tmpVars); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, tmpVars.val); internalName(type, iname); genNew(iname); ClassFormat.putInsn(topCtx.m, Opcodes.AASTORE) END END initializeMultiDimArray; PROCEDURE initializeRecord(x: OJB.Object); VAR iname: ClassFormat.Descriptor; BEGIN IF x.class = OJB.Fld THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0) END ; internalName(x.type, iname); genNew(iname); storeRef(x) END initializeRecord; PROCEDURE initializeArray(x, tmpVars: OJB.Object); VAR desc, iname: ClassFormat.Descriptor; arrDim, i: INTEGER; type, tbase, base, t: OJB.Type; BEGIN type := x.type; arrDim := 1; tbase := type.base; IF x.class = OJB.Fld THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0) END ; i := Strings.WriteChar("[", desc, 0); pushConst(type.len); WHILE (tbase # NIL) & (tbase.form = OJB.Array) DO pushConst(tbase.len); INC(arrDim); i := Strings.WriteChar("[", desc, i); tbase := tbase.base END ; IF (arrDim = 1) & (tbase # NIL) THEN IF isPrimitiveType(tbase) THEN emitPrimitiveNewArray(tbase); storeRef(x) ELSE internalName(tbase, iname); ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, iname); storeRef(x); IF (tbase.form # OJB.Pointer) & (tbase.form # OJB.Proc) THEN initializeMultiDimArray(0, x, type, tmpVars, tmpVars) END END ELSE DescriptorAt(tbase, desc, i); ClassFormat.putMultiANewArrayInsn(topCtx.m, desc, arrDim); storeRef(x); t := getLastArray(x.type); base := t.base; IF ~isPrimitiveType(base) & (base.form # OJB.Pointer) & (base.form # OJB.Proc) THEN initializeMultiDimArray(0, x, type, tmpVars, tmpVars) END END END initializeArray; PROCEDURE initializeScope(x: OJB.Object; offset: INTEGER); VAR type, recordType: OJB.Type; num, numTmpVars: INTEGER; tempVars: OJB.Object; BEGIN num := offset; (* skipPrimitiveAndPtrArrays = TRUE, as we don't want to create local variables to index multi-dimensional primitive/reference arrays as by default they are already initialized by MULTIANEWARRAY *) tempVars := createArraysTempVars(x, num, TRUE); numTmpVars := num; IF x # NIL THEN recordType := x.recordType; WHILE (x # NIL) & (recordType = x.recordType) DO IF (x.class = OJB.Var) OR (x.class = OJB.Fld) THEN type := x.type; IF type.form = OJB.Record THEN initializeRecord(x) ELSIF type.form = OJB.Array THEN initializeArray(x, tempVars) ELSIF x.lev > 0 THEN initializeLocalVar(x) END END ; x := x.next END END ; topCtx.numTmpVars := numTmpVars END initializeScope; PROCEDURE Constructor(obj: OJB.Object); VAR baseName: ClassFormat.Descriptor; tmp: OJB.Object; BEGIN topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC, "", "()V"); clearCtx(topCtx); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); Strings.Append("java/lang/Object", baseName); tmp := NIL; IF obj # NIL THEN tmp := obj.type.dsc; IF obj.type.base # NIL THEN internalName(obj.type.base, baseName) END END ; ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, baseName, "", "()V", 0); initializeScope(tmp, 1); ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx); ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars); closeContext END Constructor; PROCEDURE emitTypedReturn(type: OJB.Type); BEGIN IF (type = OJB.intType) OR (type = OJB.boolType) OR (type = OJB.charType) OR (type = OJB.setType) OR (type = OJB.byteType) THEN ClassFormat.putInsn(topCtx.m, Opcodes.IRETURN) ELSIF type = OJB.realType THEN ClassFormat.putInsn(topCtx.m, Opcodes.FRETURN) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.ARETURN) END END emitTypedReturn; PROCEDURE InvokeMethod(signature: ARRAY OF CHAR; procType: OJB.Type; qualifierModName, procName: ARRAY OF CHAR; impl: BOOLEAN); VAR access, i: INTEGER; par: OJB.Object; tmp: Item; BEGIN access := Opcodes.ACCxPUBLIC; IF ~impl THEN INC(access, Opcodes.ACCxABSTRACT) END ; topCtx.m := ClassFormat.NewMI(topCtx.c, access, "invoke", signature); clearCtx(topCtx); IF impl THEN par := procType.dsc; FOR i := 1 TO procType.nofpar DO IF par.class = OJB.Par THEN (* it's a VAR parameter, force pushTypedLocal() to generate an ALOAD *) tmp.type := OJB.nilType ELSE tmp.type := par.type END ; tmp.a := i; pushTypedLocal(tmp); par := par.next END ; ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, qualifierModName, procName, signature, procType.nofpar); IF procType.base.form # OJB.NoTyp THEN emitTypedReturn(procType.base) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx) END ; ClassFormat.setMaxVars(topCtx.m, procType.nofpar+1) (* +1 is this *) END ; closeContext END InvokeMethod; PROCEDURE genClassFilePath(name: ARRAY OF CHAR; VAR path: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := OJB.getOutputFolder(path); i := Strings.Write(Files.SEPARATOR, path, i); i := Strings.Write(name, path, i); i := Strings.Write(".class", path, i); IF i = -1 THEN OJS.Mark("Maximum file path length reached") END END genClassFilePath; PROCEDURE MakeProcType*(type: OJB.Type); VAR typeName: ClassFormat.Descriptor; path: ARRAY OJS.maxPath OF CHAR; newCtx: ClassContext; BEGIN internalName(type, typeName); genClassFilePath(typeName, path); IF ~Files.Exists(path) THEN NEW(newCtx); Strings.Copy(typeName, newCtx.className); newCtx.next := topCtx; topCtx := newCtx; newCtx.c := ClassFormat.NewCF(Opcodes.ACCxPUBLIC + Opcodes.ACCxABSTRACT, topCtx.className, "java/lang/Object"); Constructor(NIL); InvokeMethod(type.signature, NIL, "", "", FALSE); genClassFilePath(topCtx.className, path); ClassFormat.toFile(topCtx.c, path); topCtx := topCtx.next END END MakeProcType; PROCEDURE joinNames(VAR s0, s1: ARRAY OF CHAR; VAR out: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := Strings.Write(s0, out, 0); i := Strings.WriteChar("_", out, i); i := Strings.Write(s1, out, i); IF i = -1 THEN OJS.Mark("Maximum descriptor length reached") END END joinNames; PROCEDURE makeRefDesc(VAR s, desc: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := Strings.WriteChar("L", desc, 0); i := Strings.Write(s, desc, i); i := Strings.WriteChar(";", desc, i); IF i = -1 THEN OJS.Mark("Maximum descriptor length reached") END END makeRefDesc; PROCEDURE ConstructorProcInstance(signature: OJB.Type); VAR iname: ClassFormat.Descriptor; BEGIN topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPRIVATE, "", "()V"); clearCtx(topCtx); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); internalName(signature, iname); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, iname, "", "()V", 0); ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx); ClassFormat.setMaxVars(topCtx.m, 1); closeContext END ConstructorProcInstance; PROCEDURE InitProcInstance(VAR typeName: ARRAY OF CHAR); VAR desc: ClassFormat.Descriptor; BEGIN topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxSTATIC, "", "()V"); clearCtx(topCtx); genNew(typeName); makeRefDesc(typeName, desc); ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, typeName, "INSTANCE", desc); ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx); ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars); closeContext END InitProcInstance; PROCEDURE MakeProcInstance(VAR x: Item); VAR path: ARRAY OJS.maxPath OF CHAR; iname, instanceName:ClassFormat.Descriptor; procType: OJB.Type; newCtx: ClassContext; access: INTEGER; BEGIN procType := x.type; MakeProcType(procType); joinNames(x.modName, x.name, instanceName); genClassFilePath(instanceName, path); IF ~Files.Exists(path) THEN NEW(newCtx); access := Opcodes.ACCxPUBLIC + Opcodes.ACCxSUPER + Opcodes.ACCxFINAL; joinNames(x.modName, x.name, newCtx.className); newCtx.next := topCtx; topCtx := newCtx; internalName(procType, iname); newCtx.c := ClassFormat.NewCF(access, topCtx.className, iname); makeRefDesc(topCtx.className, iname); ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC, "INSTANCE", iname); ConstructorProcInstance(procType); InvokeMethod(procType.signature, procType, x.modName, x.name, TRUE); InitProcInstance(topCtx.className); genClassFilePath(topCtx.className, path); ClassFormat.toFile(topCtx.c, path); topCtx := topCtx.next END END MakeProcInstance; PROCEDURE load(VAR x: Item); VAR L0, L1: INTEGER; xt: OJB.Type; desc, procType: ClassFormat.Descriptor; s: ARRAY OJS.stringBufSize OF CHAR; BEGIN IF x.mode # Stack THEN IF x.oldType # NIL THEN xt := x.oldType ELSE xt := x.type END ; IF (x.mode = OJB.Var) OR (x.mode = OJB.ParStruct) THEN IF x.r > 0 THEN (*local*) pushTypedLocal(x) ELSE Descriptor(xt, desc); ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, x.modName, x.name, desc) END ELSIF x.mode = OJB.Par THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); pushConst(0); pushTypedArray(xt) ELSIF x.mode = OJB.Const THEN IF xt = OJB.realType THEN pushRealConst(x.a) ELSIF xt = OJB.nilType THEN ClassFormat.putInsn(topCtx.m, Opcodes.ACONSTNULL); ELSIF xt = OJB.strType THEN OJS.ExtractStr(x.a, x.b, s); ClassFormat.putLdcInsnStr(topCtx.m, s, TRUE) ELSIF xt.form = OJB.Proc THEN MakeProcInstance(x); joinNames(x.modName, x.name, procType); makeRefDesc(procType, desc); ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, procType, "INSTANCE", desc) ELSE pushConst(x.a) END ELSIF x.mode = RegI THEN pushTypedArray(xt) ELSIF x.mode = Field THEN Descriptor(xt, desc); ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETFIELD, x.recordName, x.name, desc) ELSIF x.mode = Cond THEN L0 := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, negated(x.r), 0); ClassFormat.FixLink(topCtx.m, x.b); ClassFormat.putInsn(topCtx.m, Opcodes.ICONST1); L1 := topCtx.m.i; ClassFormat.putGotoInsn(topCtx.m, 0, -1); ClassFormat.FixLink(topCtx.m, x.a); Fixup(L0); ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0); Fixup(L1) END ; x.mode := Stack; IF x.oldType # NIL THEN x.oldType := NIL; internalName(x.type, desc); ClassFormat.putTypeInsn(topCtx.m, Opcodes.CHECKCAST, desc) END ; IF x.type = OJB.byteType THEN pushConst(255); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) END END END load; PROCEDURE TypeTest*(VAR x: Item; T: OJB.Type; isguard: BOOLEAN); VAR iname: ClassFormat.Descriptor; BEGIN IF isguard THEN IF x.oldType = NIL THEN x.oldType := x.type END ELSE load(x); internalName(T, iname); ClassFormat.putTypeInsn(topCtx.m, Opcodes.INSTANCEOF, iname) END END TypeTest; PROCEDURE loadCond(VAR x: Item); BEGIN IF x.type.form = OJB.Bool THEN load(x); x.r := Opcodes.IFNE; x.mode := Cond; x.a := 0; x.b := 0; ELSE OJS.Mark("not Boolean") END END loadCond; PROCEDURE getPC*(): INTEGER; RETURN topCtx.m.i END getPC; PROCEDURE CFJump*(VAR x: Item); (*conditional forward jump*) VAR L0: INTEGER; BEGIN IF x.mode # Cond THEN loadCond(x) END ; L0 := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, negated(x.r), x.a); ClassFormat.FixLink(topCtx.m, x.b); x.a := L0 END CFJump; PROCEDURE FJump*(L: INTEGER): INTEGER; (*unconditional forward jump*) VAR L0: INTEGER; BEGIN L0 := topCtx.m.i; ClassFormat.putGotoInsn(topCtx.m, L, 0); RETURN L0 END FJump; PROCEDURE CBJump*(VAR x: Item; L: INTEGER); (*conditional backward jump*) BEGIN IF x.mode # Cond THEN loadCond(x) END ; ClassFormat.putJumpInsn(topCtx.m, negated(x.r), L-topCtx.m.i); ClassFormat.FixLink(topCtx.m, x.b); ClassFormat.FixLinkWith(topCtx.m, x.a, L) END CBJump; PROCEDURE BJump*(L: INTEGER); (*unconditional backward jump*) BEGIN ClassFormat.putGotoInsn(topCtx.m, L-topCtx.m.i, 0) END BJump; PROCEDURE genSignature*(type: OJB.Type); BEGIN DescriptorProc(type, type.nofpar, type.signature) END genSignature; PROCEDURE MakeConstItem*(VAR x: Item; typ: OJB.Type; val: INTEGER); BEGIN x.mode := OJB.Const; x.type := typ; x.a := val; x.rdo := TRUE END MakeConstItem; PROCEDURE MakeRealItem*(VAR x: Item; val: REAL); BEGIN x.mode := OJB.Const; x.type := OJB.realType; x.a := SYSTEM.VAL(INTEGER, val); x.rdo := TRUE END MakeRealItem; PROCEDURE MakeStringItem*(VAR x: Item); BEGIN x.mode := OJB.Const; x.type := OJB.strType; x.a := OJS.strpos; x.b := OJS.slen; x.rdo := TRUE; END MakeStringItem; PROCEDURE MakeItem*(VAR x: Item; y: OJB.Object); BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo; Strings.Copy(y.name, x.name); IF y.nestedId > 0 THEN Strings.AppendInt(y.nestedId, 0, x.name) END ; x.oldType := y.caseOrgType; IF (y.class = OJB.Const) & (y.type.form = OJB.String) THEN x.b := y.len END ; x.r := y.lev END MakeItem; PROCEDURE Pop(x: Item); BEGIN IF x.mode IN {Stack, Field} THEN ClassFormat.putInsn(topCtx.m, Opcodes.POP) ELSIF x.mode = RegI THEN ClassFormat.putInsn(topCtx.m, Opcodes.POP2) END END Pop; PROCEDURE ConstTypeTest*(VAR x: Item); BEGIN IF x.mode IN {OJB.Var, OJB.Par, OJB.ParStruct, Field, Stack, RegI} THEN Pop(x); MakeConstItem(x, OJB.boolType, 1) ELSE OJS.Mark("Unexpected internal mode") END END ConstTypeTest; PROCEDURE FieldAccess*(VAR x: Item; y: OJB.Object); (* x := x.y *) BEGIN load(x); x.mode := Field; internalName(x.type, x.recordName); Strings.Copy(y.name, x.name) END FieldAccess; PROCEDURE Index0*(VAR x: Item); BEGIN load(x) END Index0; PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *) BEGIN IF (y.mode = OJB.Const) & (x.type.len >= 0) THEN IF (y.a < 0) OR (y.a >= x.type.len) THEN OJS.Mark("bad index") END END ; load(y); x.mode := RegI END Index; PROCEDURE Not*(VAR x: Item); (* x := ~x *) VAR t: INTEGER; BEGIN IF x.mode # Cond THEN loadCond(x) END ; x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t END Not; PROCEDURE And1*(VAR x: Item); (* x := x & *) VAR L0: INTEGER; BEGIN IF x.mode # Cond THEN loadCond(x) END ; L0 := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, negated(x.r), x.a); x.a := L0; ClassFormat.FixLink(topCtx.m, x.b); x.b := 0 END And1; PROCEDURE And2*(VAR x, y: Item); BEGIN IF y.mode # Cond THEN loadCond(y) END ; x.a := ClassFormat.merged(topCtx.m, y.a, x.a); x.b := y.b; x.r := y.r END And2; PROCEDURE Or1*(VAR x: Item); (* x := x OR *) VAR L0: INTEGER; BEGIN IF x.mode # Cond THEN loadCond(x) END ; L0 := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, x.r, x.b); x.b := L0; ClassFormat.FixLink(topCtx.m, x.a); x.a := 0 END Or1; PROCEDURE Or2*(VAR x, y: Item); BEGIN IF y.mode # Cond THEN loadCond(y) END ; x.a := y.a; x.b := ClassFormat.merged(topCtx.m, y.b, x.b); x.r := y.r END Or2; PROCEDURE loadAndMaybeSwap(VAR x, y: Item); BEGIN IF (x.mode = OJB.Const) & (y.mode # OJB.Const) THEN (*x loading has been delayed, so fully load y and restore the order (SWAP)*) load(y); load(x); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP) ELSE load(x); load(y) END END loadAndMaybeSwap; PROCEDURE Neg*(VAR x: Item); (* x := -x *) BEGIN IF x.type.form = OJB.Int THEN IF x.mode = OJB.Const THEN x.a := -x.a ELSE load(x); ClassFormat.putInsn(topCtx.m, Opcodes.INEG) END ELSIF x.type.form = OJB.Real THEN IF x.mode = OJB.Const THEN x.a := SYSTEM.VAL(INTEGER, -SYSTEM.VAL(REAL, x.a)); ELSE load(x); ClassFormat.putInsn(topCtx.m, Opcodes.FNEG) END ELSE (*form := Set*) (* The sign of a two’s complement number is reversed in a process called taking the two’s complement: Ex. 8 := 00001000 -> -8 := oneComplement(8) + 1 := 11110111 + 1 := 11111000 So if I only need the oneComplement I subtract 1 to the two's complement: Ex. -8 := oneComplement(8) + 1 -> -8 - 1 := oneComplement(8) *) IF x.mode = OJB.Const THEN x.a := -x.a-1 ELSE (* there is no Not instruction in JVM *) load(x); pushConst(-1); ClassFormat.putInsn(topCtx.m, Opcodes.IXOR) END END END Neg; PROCEDURE AddOp*(op: INTEGER; VAR x, y: Item); (* x := x +- y *) BEGIN IF op = OJS.plus THEN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := x.a + y.a ELSIF x.mode = OJB.Const THEN load(y); IF x.a # 0 THEN load(x); ClassFormat.putInsn(topCtx.m, Opcodes.IADD) ELSE x.mode := Stack END ELSIF y.mode = OJB.Const THEN load(x); IF y.a # 0 THEN load(y); ClassFormat.putInsn(topCtx.m, Opcodes.IADD) END ; ELSE load(x); load(y); ClassFormat.putInsn(topCtx.m, Opcodes.IADD) END ELSE (*op = ORS.minus*) IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := x.a - y.a ELSIF y.mode = OJB.Const THEN load(x); IF y.a # 0 THEN load(y); ClassFormat.putInsn(topCtx.m, Opcodes.ISUB) END ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.ISUB) END END END AddOp; (* The log2(x) is the number of bits needed to represent the value of a positive x. As The result is a real number we actually compute the ceiling(log2(x)). Ex. log2(5) = 2.32 -> ceiling(2.32) = 3 in fact 5 is 101 in binary This means that to implement log2(x) we count how many bits we have until we reach the Most Significant Bit. So we basically shift x by one in a loop until x = 1 i.e. the MSB ( while(x # 1) { x = x >> 1; res++;} ceiling(res);) Here however, we are interested in the log2(x) where x is a power of 2. ex. 2^3 = 1000 = 1 * 2^3 + 0 * 2^2 + 0 * 2^1 + 0 * 2^0 All the power of 2 have the MSB set to 1 and the rest of the bits set to 0. So we can stop the loop when we find the first 1 and check at the call site (log2(x) = 1) to know if x is indeed a power of 2. Also remember that log2(2^k) = k = ceiling(k) as there is no fractional part. *) PROCEDURE log2(m: INTEGER; VAR e: INTEGER): INTEGER; BEGIN e := 0; WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ; RETURN m END log2; PROCEDURE MulOp*(VAR x, y: Item); (* x := x * y *) VAR e: INTEGER; BEGIN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := x.a * y.a ELSIF (y.mode = OJB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); pushConst(e); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) ELSIF x.mode = OJB.Const THEN load(y); IF (x.a >= 2) & (log2(x.a, e) = 1) THEN pushConst(e); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL); ELSIF x.a # 0 THEN load(x); ClassFormat.putInsn(topCtx.m, Opcodes.IMUL) END ; x.mode := Stack ELSE load(x); load(y); ClassFormat.putInsn(topCtx.m, Opcodes.IMUL) END END MulOp; (* Delayed code generation is used to implement constant folding Given VAR i,j : INTEGER; a : ARRAY 10 OF INTEGER; i := 2 + a[1+3]; will be compiled as i := a[4] + 2: GETSTATIC A.a : [I ICONST_4 IALOAD ICONST_2 IADD PUTSTATIC A.i : I We delay the code generation for the first operands of both additions. In the first addition 2 will be emitted after the evaluation of a[1+3] as at that point is clear that no constant folding is possible between 2 and a. In the second addition we delay the emission of 1 as it could be folded as indeed happens as the second operand is the constant 3. The statement i := 2 - a[j+3]; Will be compiled as i = 2 - a[j + 3]; GETSTATIC A.a : [I GETSTATIC A.j : I ICONST_3 IADD IALOAD ICONST_2 SWAP ISUB PUTSTATIC A.i : I Notice the presence of an extra SWAP. Because 2 is emitted after evaluating a[j+3] and because - is not commutative we need to swap the argument of the ISUB instruction. *) PROCEDURE loadOp*(VAR x: Item); BEGIN IF x.mode # OJB.Const THEN load(x) END END loadOp; PROCEDURE SetLineNumber*(line: INTEGER); BEGIN ClassFormat.addLineNumber(topCtx.m, line) END SetLineNumber; PROCEDURE Trap(msg: ARRAY OF CHAR); BEGIN ClassFormat.putTypeInsn(topCtx.m, Opcodes.NEW, "java/lang/RuntimeException"); ClassFormat.putInsn(topCtx.m, Opcodes.DUP); ClassFormat.putLdcInsnStr(topCtx.m, msg, FALSE); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, "java/lang/RuntimeException", "", "(Ljava/lang/String;)V", 1); ClassFormat.putInsn(topCtx.m, Opcodes.ATHROW) END Trap; PROCEDURE TrapWithCond(cond: INTEGER; msg: ARRAY OF CHAR); VAR L: INTEGER; BEGIN ClassFormat.putInsn(topCtx.m, Opcodes.DUP); L := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, negated(cond), 0); Trap(msg); Fixup(L) END TrapWithCond; PROCEDURE DivOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) VAR e: INTEGER; skip: BOOLEAN; BEGIN skip := FALSE; IF op = OJS.div THEN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN (* Euclidean division, use y.a > 0 for Floored division *) IF y.a # 0 THEN x.a := x.a DIV y.a ELSE OJS.Mark("bad divisor") END ELSIF (y.mode = OJB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); pushConst(e); ClassFormat.putInsn(topCtx.m, Opcodes.ISHR) ELSE (* Euclidean division, use y.a <= 0 for Floored division *) IF y.mode = OJB.Const THEN IF y.a = 0 THEN OJS.Mark("bad divisor") ELSIF y.a > 0 THEN skip := TRUE END END ; loadAndMaybeSwap(x, y); (* Euclidean division, use Opcodes.IFLE for Floored division *) IF check & ~skip THEN TrapWithCond(Opcodes.IFEQ, "bad divisor") END ; ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "DIV", "(II)I", 2) END ELSE (*op := ORS.mod*) IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN (* Euclidean division, use y.a > 0 for Floored division *) IF y.a # 0 THEN x.a := x.a MOD y.a ELSE OJS.Mark("bad modulus") END ELSIF (y.mode = OJB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); pushConst(y.a-1); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) ELSE (* Euclidean division, use y.a <= 0 for Floored division *) IF (y.mode = OJB.Const) & (y.a = 0) THEN OJS.Mark("bad modulus") ELSE skip := TRUE END ; loadAndMaybeSwap(x, y); (* Euclidean division, use Opcodes.IFLE for Floored division *) IF check & ~skip THEN TrapWithCond(Opcodes.IFEQ, "bad modulus") END ; ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "MOD", "(II)I", 2) END END END DivOp; (* Code generation for REAL operators *) PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) BEGIN IF op = OJS.plus THEN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) +SYSTEM.VAL(REAL, y.a)) ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FADD) END ; ELSIF op = OJS.minus THEN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) -SYSTEM.VAL(REAL, y.a)) ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FSUB) END ; ELSIF op = OJS.times THEN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) *SYSTEM.VAL(REAL, y.a)) ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FMUL) END ; ELSE (* op = ORS.rdiv *) IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(REAL, x.a) /SYSTEM.VAL(REAL, y.a)) ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.FDIV) END ; END END RealOp; (* Code generation for set operators *) PROCEDURE Singleton*(VAR x: Item); (* x := {x} *) BEGIN IF x.mode = OJB.Const THEN x.a := LSL(1, x.a) ELSIF x.mode # OJB.Var THEN load(x); pushConst(1); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) ELSE pushConst(1); load(x); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) END END Singleton; (* Example s := {3..5} -1 = 11111111111111111111111111111111 -2 = 11111111111111111111111111111110 LSL(-1, 3) = 11111111111111111111111111111000 LSL(-2, 5) = 11111111111111111111111111000000 LSL(-1, 3) - LSL(-2, 5) = 11111111111111111111111111111000 - 11111111111111111111111111000000 = 11111111111111111111111111111000 + 00000000000000000000000000111111 + 1 (two's complement) = 11111111111111111111111111111001 + 00000000000000000000000000111111 = 00000000000000000000000000111000 = 56 LSL(2, 5) - LSL(1, 3) = 00000000000000000000000001000000 - 00000000000000000000000000001000 = 00000000000000000000000001000000 + 11111111111111111111111111110111 + 1 (two's complement) = 00000000000000000000000001000001 + 11111111111111111111111111110111 = 00000000000000000000000000111000 = 56 = LSL(-1, 3) & ~LSL(-2, 5) = 11111111111111111111111111111000 & 00000000000000000000000000111111 = (LSL(-2, 5) xor -1) & LSL(-1, 3) // where LSL(-1, 3) is computed // at compile time = ~LSL(-2, 5) & LSL(-1, 3) // there is no Not institution in RISC *) PROCEDURE Set0*(VAR x: Item); (* x := {x .. y} *) BEGIN (* delay generation if x is constant, handle it in Set1 *) IF x.mode # OJB.Const THEN IF x.mode # OJB.Var THEN load(x); pushConst(-1); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) ELSE pushConst(-1); load(x); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) END END END Set0; PROCEDURE Set1*(VAR x, y: Item); (* x := {x .. y} *) BEGIN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN IF x.a <= y.a THEN x.a := LSL(-1, x.a) - LSL(-2, y.a) ELSE x.a := 0 END ELSE IF y.mode = OJB.Const THEN pushConst(LSL(-2, y.a)); y.mode := Stack ELSIF y.mode # OJB.Var THEN load(y); pushConst(-2); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) ELSE pushConst(-2); load(y); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) END ; IF x.mode = OJB.Const THEN pushConst(LSL(-1, x.a)); x.mode := Stack; ClassFormat.putInsn(topCtx.m, Opcodes.SWAP) END ; ClassFormat.putInsn(topCtx.m, Opcodes.ISUB); END END Set1; (* Example s := 4 in {3..5} {3..5} = 56 = 00000000000000000000000000111000 4 = 100 We add 1 as our set is 0 based 4 + 1 = 5 = 101 ROR(56, 5) = 11000000000000000000000000000001 -> as the most significant bit is set to 1 this number is negative so it means that 4 is indeed in {3..5} Alternately as in the JVM ROR will be implemented with too many instructions (i.e. (x >>> n) | (x << -n) ) LSL(1, 4) = 00000000000000000000000000010000 LSL(1, 4) & {3..5} = 00000000000000000000000000010000 & 00000000000000000000000000111000 = 00000000000000000000000000010000 -> the result is not 0 so it means that 4 is indeed in {3..5} x IN y If x is not in the implementation defined SET range {0..MaxSetElement-1} the IN operator is undefined *) PROCEDURE In0*(VAR x: Item); (* x := x IN y *) BEGIN IF x.mode = OJB.Const THEN x.a := LSL(1, x.a); load(x) ELSE load(x); pushConst(1); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP); ClassFormat.putInsn(topCtx.m, Opcodes.ISHL) END ; SetCC(x, Opcodes.IFNE) END In0; PROCEDURE In1*(VAR x: Item); (* x := x IN y *) BEGIN load(x); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) END In1; (* See "SET: A neglected data type, and its compilation for the ARM" *) PROCEDURE SetOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) VAR xset, yset: SET; (*x.type.form = Set*) BEGIN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a); IF op = OJS.plus THEN xset := xset + yset ELSIF op = OJS.minus THEN xset := xset - yset ELSIF op = OJS.times THEN xset := xset * yset ELSIF op = OJS.rdiv THEN xset := xset / yset END ; x.a := SYSTEM.VAL(INTEGER, xset) ELSE loadAndMaybeSwap(x, y); IF op = OJS.plus THEN ClassFormat.putInsn(topCtx.m, Opcodes.IOR) ELSIF op = OJS.minus THEN (*ANN*) pushConst(-1); ClassFormat.putInsn(topCtx.m, Opcodes.IXOR); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) ELSIF op = OJS.times THEN ClassFormat.putInsn(topCtx.m, Opcodes.IAND) ELSIF op = OJS.rdiv THEN ClassFormat.putInsn(topCtx.m, Opcodes.IXOR) END END END SetOp; (* Code generation for relations *) PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) BEGIN IF (y.mode = OJB.Const) & (y.type.form # OJB.Proc) & (y.a = 0) THEN load(x); IF y.type.form = OJB.NilTyp THEN SetCC(x, relmapNil[op - OJS.eql]) ELSE SetCC(x, relmap0[op - OJS.eql]) END ELSE loadAndMaybeSwap(x, y); IF (x.type.form = OJB.Pointer) OR (x.type.form = OJB.Proc) OR (x.type.form = OJB.NilTyp) THEN SetCC(x, relmapAdr[op - OJS.eql]) ELSE SetCC(x, relmap[op - OJS.eql]) END END END IntRelation; PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) BEGIN loadAndMaybeSwap(x, y); IF (op = OJS.lss) OR (op = OJS.leq) THEN ClassFormat.putInsn(topCtx.m, Opcodes.FCMPG) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.FCMPL) END ; SetCC(x, relmap0[op - OJS.eql]) END RealRelation; PROCEDURE StrToChar*(VAR x: Item); BEGIN x.type := OJB.charType; x.a := ORD(OJS.ExtractChar(x.a)) END StrToChar; PROCEDURE CharToStr*(VAR x: Item); VAR c: CHAR; BEGIN c := CHR(x.a); x.mode := OJB.Const; x.type := OJB.strType; x.a := OJS.InsertChar(c); x.b := 2; (* 1 char + 0X *) x.rdo := TRUE END CharToStr; PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) BEGIN (*x, y are char arrays or strings*) IF (x.type.form = OJB.String) & (x.b = 2) & (y.type.form = OJB.String) & (y.b = 2) THEN StrToChar(x); StrToChar(y); IntRelation(op, x, y) ELSIF (x.type.form # OJB.String) & (y.type.form = OJB.String) & (y.b = 1) THEN (* x := x < "" *) load(x); pushConst(0); pushTypedArray(x.type.base); SetCC(x, relmap0[op - OJS.eql]) ELSIF (x.type.form = OJB.String) & (y.type.form # OJB.String) THEN load(y); load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, "java/lang/String", "toCharArray", "()[C", 0); x.mode := Stack; ClassFormat.putInsn(topCtx.m, Opcodes.SWAP); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "StrCmp", "([C[C)I", 2); SetCC(x, relmap0[op - OJS.eql]) ELSE load(x); IF x.type.form = OJB.String THEN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, "java/lang/String", "toCharArray", "()[C", 0); x.mode := Stack END ; load(y); IF y.type.form = OJB.String THEN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, "java/lang/String", "toCharArray", "()[C", 0); x.mode := Stack END ; ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "StrCmp", "([C[C)I", 2); SetCC(x, relmap0[op - OJS.eql]) END END StringRelation; PROCEDURE makeCopyDesc(VAR s, desc: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := Strings.Write("(L", desc, 0); i := Strings.Write(s, desc, i); i := Strings.Write(";)V", desc, i); IF i = -1 THEN OJS.Mark("Maximum descriptor length reached") END END makeCopyDesc; (* Code generation of Assignments *) PROCEDURE Store*(VAR x, y: Item; storeStruct: BOOLEAN); (* x := y *) VAR desc, typeName :ClassFormat.Descriptor; BEGIN load(y); IF storeStruct THEN internalName(x.type, typeName); makeCopyDesc(typeName, desc); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, typeName, "copyFrom", desc, 1) ELSE IF (x.mode = OJB.Var) OR (x.mode = Stack) OR (x.mode = OJB.ParStruct) THEN IF x.r > 0 THEN (*local*) storeTypedLocal(x) ELSE Descriptor(x.type, desc); ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, x.modName, x.name, desc) END ELSIF x.mode = RegI THEN storeTypedArray(x.type) ELSIF x.mode = Field THEN Descriptor(x.type, desc); ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTFIELD, x.recordName, x.name, desc) ELSIF x.mode = OJB.Par THEN storeTypedArray(x.type) ELSE OJS.Mark("illegal assignment") END END END Store; PROCEDURE storeArrayR(i: INTEGER; type: OJB.Type; VAR x, y: Item); VAR desc, iname: ClassFormat.Descriptor; cond, end, lastTmp, index: INTEGER; BEGIN IF type.form = OJB.Array THEN IF type.len < 0 THEN (* only monodimensional open arrays are supported. ex. PROCEDURE P(VAR b : ARRAY OF ARRAY OF INTEGER); VAR c: ARRAY 10, 10 OF INTEGER; BEGIN c := b; (* illegal see Type Rule E.6, B.2, B.3 *) END P; *) ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a); ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH); pushConst(1); ClassFormat.putInsn(topCtx.m, Opcodes.ISUB) ELSE pushConst(type.len - 1) END ; (* topCtx.numTmpVars is the first free local to use *) index := i + topCtx.numTmpVars; ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, index); cond := topCtx.m.i; ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, index); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFLT, 0); storeArrayR(i + 1, type.base, x, y); ClassFormat.putIincInsn(topCtx.m, index, -1); ClassFormat.putGotoInsn(topCtx.m, cond-topCtx.m.i, 0); Fixup(end) ELSE (* as we incremented index(= last used local) we have to update topCtx.numTmpVars as it is still pointing to the first used local *) IF ~isPrimitiveType(type) & (type.form # OJB.Pointer) & (type.form # OJB.Proc) THEN topCtx.numTmpVars := topCtx.numTmpVars + i + 1; ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); lastTmp := pushIndexes2(i+1); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a); lastTmp := pushIndexes2(i+1); internalName(type, iname); makeCopyDesc(iname, desc); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname, "copyFrom", desc, 1); ELSE topCtx.numTmpVars := topCtx.numTmpVars + i; ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); lastTmp := pushIndexes2(i); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a); lastTmp := pushIndexes2(i); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp); pushTypedArray(type); storeTypedArray(type) END END END storeArrayR; PROCEDURE storeTempLocal(VAR x: Item); BEGIN load(x); x.a := topCtx.numTmpVars; storeTypedLocal(x); INC(topCtx.numTmpVars) END storeTempLocal; PROCEDURE storeArray*(VAR x, y: Item); VAR end: INTEGER; BEGIN load(y); y.a := topCtx.numTmpVars; storeTypedLocal(y); INC(topCtx.numTmpVars); (* OJP guarantees x and y are regular arrays (not open) with equal element types and length or x is a regular array, y is an open array with equal base type *) IF (check) & (y.type.len < 0) THEN (*open array len*) pushConst(x.type.len); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a); ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPGE, 0); Trap("array copy overflow"); Fixup(end) END ; IF isPrimitiveType(x.type.base) THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a); pushConst(0); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); pushConst(0); IF y.type.len < 0 THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, y.a); ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH) ELSE pushConst(y.type.len) END ; ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "java/lang/System", "arraycopy", "(Ljava/lang/Object;ILjava/lang/Object;II)V", 5) ELSE storeArrayR(0, y.type, x, y) END END storeArray; PROCEDURE StoreProc*(VAR x, y: Item); (* x := y *) BEGIN IF y.mode = OJB.Const THEN load(y) END ; Store(x, y, FALSE) END StoreProc; PROCEDURE ValueParam*(VAR x: Item); BEGIN load(x) END ValueParam; PROCEDURE StringParam*(VAR x: Item); BEGIN load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, "java/lang/String", "toCharArray", "()[C", 0) END StringParam; PROCEDURE CopyString*(VAR x, y: Item); (* x := y *) VAR len, end: INTEGER; BEGIN len := x.type.len; IF len >= 0 THEN IF len < y.b THEN OJS.Mark("string too long") END ELSIF check THEN (*open array len*) ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH); pushConst(y.b); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPGE, 0); Trap("string too long"); Fixup(end) END ; IF y.b = 1 THEN (* x := "" *) ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); pushConst(0); pushConst(0); ClassFormat.putInsn(topCtx.m, Opcodes.CASTORE) ELSE StringParam(y); pushConst(0); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); pushConst(0); pushConst(y.b); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "java/lang/System", "arraycopy", "(Ljava/lang/Object;ILjava/lang/Object;II)V", 5) END END CopyString; PROCEDURE loadPar*(VAR x: Item); BEGIN IF x.mode = OJB.Par THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0) END END loadPar; PROCEDURE VarParam*(VAR x: Item); VAR desc: ClassFormat.Descriptor; newStoreStmt: StoreStmt; type, newType: OJB.Type; BEGIN IF (x.mode = OJB.Par) & (x.oldType = NIL) THEN (* x is already a var parameter with no type guard, so pass it by value *) ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a) ELSE IF x.oldType # NIL THEN newType := x.oldType ELSE newType := x.type END ; NEW(newStoreStmt); IF x.mode = Field THEN newStoreStmt.x.a := topCtx.numTmpVars; newStoreStmt.x.mode := x.mode; Strings.Copy(x.recordName, newStoreStmt.x.recordName); Strings.Copy(x.modName, newStoreStmt.x.modName); Strings.Copy(x.name, newStoreStmt.x.name); newStoreStmt.x.type := newType; ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, newStoreStmt.x.a); INC(topCtx.numTmpVars) ELSIF x.mode = RegI THEN newStoreStmt.x.a := topCtx.numTmpVars; INC(topCtx.numTmpVars); newStoreStmt.x.b := topCtx.numTmpVars; INC(topCtx.numTmpVars); newStoreStmt.x.mode := x.mode; Strings.Copy(x.name, newStoreStmt.x.name); Strings.Copy(x.modName, newStoreStmt.x.modName); newStoreStmt.x.type := newType; ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, newStoreStmt.x.b); ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, newStoreStmt.x.a) ELSIF (x.mode = OJB.Var) OR (x.oldType # NIL) THEN newStoreStmt.x.a := x.a; newStoreStmt.x.r := x.r; newStoreStmt.x.mode := x.mode; Strings.Copy(x.name, newStoreStmt.x.name); Strings.Copy(x.modName, newStoreStmt.x.modName); newStoreStmt.x.type := newType ELSE OJS.Mark("Only variables allowed") END ; ClassFormat.putInsn(topCtx.m, Opcodes.ICONST1); type := x.type; IF isPrimitiveType(type) THEN emitPrimitiveNewArray(type) ELSIF type.form = OJB.Array THEN Descriptor(type, desc); ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, desc) ELSE internalName(type, desc); ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, desc) END ; ClassFormat.putInsn(topCtx.m, Opcodes.DUP); ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0); IF x.mode = Field THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, newStoreStmt.x.a) ELSIF x.mode = RegI THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, newStoreStmt.x.a); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, newStoreStmt.x.b) END ; load(x); storeTypedArray(x.type); newStoreStmt.y.a := topCtx.numTmpVars; ClassFormat.putVarInsn(topCtx.m, Opcodes.ASTORE, topCtx.numTmpVars); INC(topCtx.numTmpVars); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, newStoreStmt.y.a); newStoreStmt.y.mode := RegI; newStoreStmt.y.type := type; newStoreStmt.next := topCtx.storeStmt; topCtx.storeStmt := newStoreStmt END END VarParam; PROCEDURE storeVarPar*; VAR h: StoreStmt; BEGIN h := topCtx.storeStmt; WHILE h # NIL DO IF h.x.mode = Field THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.x.a) ELSIF h.x.mode = RegI THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.x.a); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, h.x.b) ELSIF h.x.mode = OJB.Par THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.x.a); ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0) END ; ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, h.y.a); ClassFormat.putInsn(topCtx.m, Opcodes.ICONST0); Store(h.x, h.y, FALSE); h := h.next; END ; topCtx.storeStmt := NIL END storeVarPar; PROCEDURE PrepAssign*(VAR x: Item); BEGIN IF x.type.form = OJB.Array THEN storeTempLocal(x) ELSIF x.type.form = OJB.Record THEN load(x) ELSE loadPar(x) END END PrepAssign; PROCEDURE For0*(VAR x, y: Item); BEGIN Store(x, y, FALSE) END For0; PROCEDURE For1*(VAR x, z, w: Item): INTEGER; VAR L, oldMode: INTEGER; BEGIN load(z); oldMode := x.mode; load(x); x.mode := oldMode; L := topCtx.m.i; IF w.a < 0 THEN ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPGT, 0) ELSIF w.a > 0 THEN ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFICMPLT, 0) ELSE OJS.Mark("zero increment") END RETURN L END For1; PROCEDURE For2*(VAR x, w: Item); BEGIN IF (x.mode = OJB.Var) & (x.r > 0) THEN ClassFormat.putIincInsn(topCtx.m, x.a, w.a) ELSIF x.mode = OJB.Par THEN loadPar(x); AddOp(OJS.plus, x, w); w.mode := Stack; x.mode := OJB.Par; Store(x, w, FALSE) ELSE AddOp(OJS.plus, x, w); w.mode := Stack; Store(x, w, FALSE) END END For2; PROCEDURE CaseIn*(VAR x: Item; L: INTEGER): INTEGER; BEGIN storeTempLocal(x) RETURN FJump(L) END CaseIn; PROCEDURE CaseDefault*(): INTEGER; VAR dflt: INTEGER; BEGIN dflt := topCtx.m.i; Trap("Invalid case in CASE statement") RETURN dflt END CaseDefault; PROCEDURE CaseOut*(VAR caseExpr: Item; end, L0, n, dflt: INTEGER; tab: ARRAY OF LabelRange); VAR max, lastLow, nLables, i, j: INTEGER; all: ARRAY NofCases OF INTEGER; BEGIN IF n > 0 THEN max := tab[n-1].high; lastLow := tab[0].low; nLables := ABS(max - lastLow + 1); ELSE max := 0; lastLow := 0; nLables := 0; END ; IF nLables <= NofCases THEN ClassFormat.FixLink(topCtx.m, L0); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, caseExpr.a); dflt := dflt-topCtx.m.i; i := 0; j := 0; WHILE j < n DO WHILE lastLow < tab[j].low DO all[i] := dflt; INC(i); INC(lastLow) END ; WHILE lastLow <= tab[j].high DO all[i] := tab[j].L-topCtx.m.i; INC(i); INC(lastLow) END ; INC(j) END ; ClassFormat.putTableSwitchInsn(topCtx.m, tab[0].low, max, dflt, nLables, all); ClassFormat.FixLink(topCtx.m, end) ELSE OJS.Mark("too many cases or no case in case statement") END END CaseOut; PROCEDURE PrepCall*(VAR x: Item); BEGIN (*x.type.form = OJB.Proc*) IF x.mode # OJB.Const THEN (*call on procedure variable*) load(x) END END PrepCall; PROCEDURE Call*(VAR x: Item); VAR iname: ClassFormat.Descriptor; BEGIN (*x.type.form = OJB.Proc*) IF x.mode = OJB.Const THEN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, x.modName, x.name, x.type.signature, x.type.nofpar) ELSE internalName(x.type, iname); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname, "invoke", x.type.signature, x.type.nofpar) END ; IF x.type.base.form # OJB.NoTyp THEN (*function*) x.mode := Stack END END Call; PROCEDURE Enter*(proc: OJB.Object; locblksize: INTEGER); VAR acc: INTEGER; nestedName: ARRAY OJS.IdLen + ClassFormat.nestedIdLen OF CHAR; BEGIN acc := Opcodes.ACCxSTATIC + Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL; IF proc.nestedId > 0 THEN Strings.Copy(proc.name, nestedName); Strings.AppendInt(proc.nestedId, 0, nestedName); topCtx.m := ClassFormat.NewMI(topCtx.c, acc, nestedName, proc.type.signature) ELSE topCtx.m := ClassFormat.NewMI(topCtx.c, acc, proc.name, proc.type.signature) END; clearCtx(topCtx); initializeScope(getLocalVars(proc.type.dsc, proc.type.nofpar), locblksize) END Enter; PROCEDURE Return*(type: OJB.Type; VAR x: Item); BEGIN IF (type # NIL) & (type.form # OJB.NoTyp) THEN load(x); IF type = OJB.byteType THEN pushConst(255); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) END ; emitTypedReturn(x.type) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx) END ; ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars); closeContext END Return; PROCEDURE Increment1*(upordown: INTEGER; VAR x, y, z: Item); VAR op: INTEGER; BEGIN IF upordown = 0 THEN op := Opcodes.IADD ELSE op := Opcodes.ISUB END ; IF y.type.form = OJB.NoTyp THEN y.mode := OJB.Const; y.a := 1 END ; IF (x.mode = OJB.Var) & (x.r > 0) & (y.mode = OJB.Const) & (y.a >= -128) & (y.a <= 127) THEN IF op = Opcodes.ISUB THEN y.a := -y.a END ; ClassFormat.putIincInsn(topCtx.m, x.a, y.a) ELSE IF (x.mode = OJB.Var) & (x.r > 0) THEN z := x; IF y.mode IN {OJB.Const, OJB.Var} THEN load(x); load(y) ELSE load(y); load(x); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP) END ELSE load(y) END ; ClassFormat.putInsn(topCtx.m, op); Store(z, x, FALSE) END END Increment1; PROCEDURE Increment0*(VAR x, z: Item); BEGIN IF (x.mode # OJB.Var) OR (x.r = 0) THEN z := x; IF x.mode = RegI THEN ClassFormat.putInsn(topCtx.m, Opcodes.DUP2) ELSIF x.mode = Field THEN ClassFormat.putInsn(topCtx.m, Opcodes.DUP) END ; IF x.mode = OJB.Par THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); pushConst(0); ClassFormat.putInsn(topCtx.m, Opcodes.DUP2); pushTypedArray(x.type); x.mode := Stack ELSE load(x) END ; END END Increment0; PROCEDURE Include0*(VAR x, z: Item); BEGIN z := x; IF x.mode = RegI THEN ClassFormat.putInsn(topCtx.m, Opcodes.DUP2) ELSIF x.mode = Field THEN ClassFormat.putInsn(topCtx.m, Opcodes.DUP) END ; IF x.mode = OJB.Par THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, x.a); pushConst(0); ClassFormat.putInsn(topCtx.m, Opcodes.DUP2); pushTypedArray(x.type); x.mode := Stack ELSE load(x) END ; END Include0; PROCEDURE Include1*(inorex: INTEGER; VAR y, z: Item); BEGIN Singleton(y); load(y); IF inorex = 0 THEN ClassFormat.putInsn(topCtx.m, Opcodes.IOR) ELSE pushConst(-1); ClassFormat.putInsn(topCtx.m, Opcodes.IXOR); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) END ; Store(z, y, FALSE) END Include1; PROCEDURE Assert*(VAR x: Item); VAR L0: INTEGER; BEGIN IF x.mode # Cond THEN loadCond(x) END ; L0 := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, x.r, x.b); ClassFormat.FixLink(topCtx.m, x.a); x.b := L0; Trap("assertion violated"); ClassFormat.FixLink(topCtx.m, x.b) END Assert; PROCEDURE New*(VAR x: Item); VAR iname: ClassFormat.Descriptor; dummy: Item; BEGIN loadPar(x); dummy.mode := Stack; internalName(x.type, iname); genNew(iname); Store(x, dummy, FALSE) END New; PROCEDURE ReadInt*(VAR x: Item); BEGIN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "ReadInt", "()I", 0); x.mode := Stack END ReadInt; PROCEDURE eot*(VAR x: Item); BEGIN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "eot", "()Z", 0); x.mode := Stack END eot; PROCEDURE WriteInt*(VAR x: Item); BEGIN load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "WriteInt", "(I)V", 1) END WriteInt; PROCEDURE WriteReal*(VAR x: Item); BEGIN load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "WriteReal", "(F)V", 1) END WriteReal; PROCEDURE WriteChar*(VAR x: Item); BEGIN load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "WriteChar", "(I)V", 1) END WriteChar; PROCEDURE WriteLn*; BEGIN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "WriteLn", "()V", 0) END WriteLn; PROCEDURE Args0*; BEGIN ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, topCtx.className, "args", "[Ljava/lang/String;"); END Args0; PROCEDURE Args1*(VAR x: Item); BEGIN load(x) END Args1; PROCEDURE Args2*(VAR y: Item); BEGIN load(y); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "ARGS", "([Ljava/lang/String;I[C)V", 3) END Args2; PROCEDURE Abs*(VAR x: Item); VAR f: REAL; end: INTEGER; BEGIN IF x.mode = OJB.Const THEN IF x.type.form = OJB.Real THEN f := ABS(SYSTEM.VAL(REAL, x.a)); x.a := SYSTEM.VAL(INTEGER, f) ELSE x.a := ABS(x.a) END ELSE load(x); IF x.type.form = OJB.Real THEN ClassFormat.putInsn(topCtx.m, Opcodes.DUP); ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0); ClassFormat.putInsn(topCtx.m, Opcodes.FCMPG); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFGT, 0); ClassFormat.putInsn(topCtx.m, Opcodes.FCONST0); ClassFormat.putInsn(topCtx.m, Opcodes.SWAP); ClassFormat.putInsn(topCtx.m, Opcodes.FSUB); Fixup(end) ELSE ClassFormat.putInsn(topCtx.m, Opcodes.DUP); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFGE, 0); ClassFormat.putInsn(topCtx.m, Opcodes.INEG); Fixup(end) END END END Abs; PROCEDURE Odd*(VAR x: Item); BEGIN IF x.mode = OJB.Const THEN x.a := ORD(ODD(x.a)) ELSE load(x); pushConst(1); ClassFormat.putInsn(topCtx.m, Opcodes.IAND); SetCC(x, Opcodes.IFNE) END END Odd; PROCEDURE Floor*(VAR x: Item); VAR f: REAL; BEGIN IF x.mode = OJB.Const THEN f := SYSTEM.VAL(REAL, x.a); x.a := FLOOR(f) ELSE load(x); ClassFormat.putInsn(topCtx.m, Opcodes.F2D); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "java/lang/Math", "floor", "(D)D", 1); ClassFormat.putInsn(topCtx.m, Opcodes.D2I) END END Floor; PROCEDURE IntToReal*(VAR x: Item); BEGIN load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "java/lang/Float", "intBitsToFloat", "(I)F", 1) END IntToReal; PROCEDURE RealToInt*(VAR x: Item); BEGIN load(x); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "java/lang/Float", "floatToRawIntBits", "(F)I", 1) END RealToInt; PROCEDURE Float*(VAR x: Item); BEGIN IF x.mode = OJB.Const THEN x.a := SYSTEM.VAL(INTEGER, FLT(x.a)) ELSE load(x); ClassFormat.putInsn(topCtx.m, Opcodes.I2F) END END Float; PROCEDURE Ord*(VAR x: Item); BEGIN (* allow constant folding: ORD("A") + 1 *) IF x.mode # OJB.Const THEN load(x) END END Ord; PROCEDURE Len*(VAR x: Item); BEGIN IF x.type.len >= 0 THEN Pop(x); x.mode := OJB.Const; x.a := x.type.len ELSE (*open array*) load(x); ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH); x.mode := Stack END END Len; PROCEDURE Argnum*(VAR x: Item); BEGIN ClassFormat.putFieldInsn(topCtx.m, Opcodes.GETSTATIC, topCtx.className, "args", "[Ljava/lang/String;"); ClassFormat.putInsn(topCtx.m, Opcodes.ARRAYLENGTH); x.mode := Stack END Argnum; PROCEDURE Shift*(fct: INTEGER; VAR x, y: Item); CONST Ror = 3; VAR op: INTEGER; BEGIN IF fct = 0 THEN op := Opcodes.ISHL ELSIF fct = 1 THEN op := Opcodes.ISHR ELSE op := Ror END ; IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN IF fct = 0 THEN x.a := LSL(x.a, y.a) ELSIF fct = 1 THEN x.a := ASR(x.a, y.a) ELSE x.a := ROR(x.a, y.a) END ELSE loadAndMaybeSwap(x, y); IF op = Ror THEN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, "OberonRuntime", "ROR", "(II)I", 2) ELSE ClassFormat.putInsn(topCtx.m, op) END END END Shift; PROCEDURE Band*(VAR x, y: Item); BEGIN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := AND(x.a, y.a) ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.IAND) END END Band; PROCEDURE Bor*(VAR x, y: Item); BEGIN IF (x.mode = OJB.Const) & (y.mode = OJB.Const) THEN x.a := BOR(x.a, y.a) ELSE loadAndMaybeSwap(x, y); ClassFormat.putInsn(topCtx.m, Opcodes.IOR) END END Bor; PROCEDURE Bnot*(VAR x: Item); BEGIN IF x.mode = OJB.Const THEN x.a := NOT(x.a) ELSE load(x); pushConst(-1); ClassFormat.putInsn(topCtx.m, Opcodes.IXOR) END END Bnot; PROCEDURE Open*(modid: ARRAY OF CHAR); VAR ctx: ClassContext; BEGIN ClassFormat.Init; check := TRUE; NEW(ctx); Strings.Copy(modid, ctx.className); topCtx := ctx; topCtx.c := ClassFormat.NewCF(Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL, topCtx.className, "java/lang/Object"); dummyMethod := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC, "DUMMY", "()V"); topCtx.m := dummyMethod END Open; PROCEDURE Header*(topScope: OJB.Object); VAR desc: ClassFormat.Descriptor; tmp: OJB.Object; BEGIN ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC, "args", "[Ljava/lang/String;"); tmp := topScope; WHILE tmp # NIL DO IF tmp.expo & (tmp.class = OJB.Const) & (tmp.type.form # OJB.Proc) & (tmp.type.form # OJB.String) THEN Descriptor(tmp.type, desc); ClassFormat.addConstField(topCtx.c, tmp.name, desc, tmp.val) ELSIF tmp.class = OJB.Var THEN Descriptor(tmp.type, desc); ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC, tmp.name, desc) END ; tmp := tmp.next END END Header; PROCEDURE copyRecord(x: OJB.Object); VAR desc, iname: ClassFormat.Descriptor; BEGIN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); loadRef(x); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1); loadRef(x); internalName(x.type, iname); makeCopyDesc(iname, desc); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname,"copyFrom", desc, 1) END copyRecord; PROCEDURE copyPrimitiveField(x: OJB.Object); BEGIN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1); loadRef(x); storeRef(x) END copyPrimitiveField; PROCEDURE copyArrayR(i: INTEGER; x: OJB.Object; type: OJB.Type; tmpVars, currTmpVar: OJB.Object); VAR desc, iname: ClassFormat.Descriptor; lastTmp: OJB.Object; cond, end: INTEGER; BEGIN IF type.form = OJB.Array THEN pushConst(type.len - 1); ClassFormat.putVarInsn(topCtx.m, Opcodes.ISTORE, currTmpVar.val); cond := topCtx.m.i; ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, currTmpVar.val); end := topCtx.m.i; ClassFormat.putJumpInsn(topCtx.m, Opcodes.IFLT, 0); copyArrayR(i + 1, x, type.base, tmpVars, currTmpVar.next); ClassFormat.putIincInsn(topCtx.m, currTmpVar.val, -1); ClassFormat.putGotoInsn(topCtx.m, cond-topCtx.m.i, 0); Fixup(end) ELSE IF ~isPrimitiveType(type) & (type.form # OJB.Pointer) & (type.form # OJB.Proc) THEN ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); loadRef(x); lastTmp := pushIndexes(i+1, tmpVars); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1); loadRef(x); lastTmp := pushIndexes(i+1, tmpVars); internalName(type, iname); makeCopyDesc(iname, desc); ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKEVIRTUAL, iname, "copyFrom", desc, 1) ELSE ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); loadRef(x); lastTmp := pushIndexes(i, tmpVars); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp.val); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 1); loadRef(x); lastTmp := pushIndexes(i, tmpVars); ClassFormat.putVarInsn(topCtx.m, Opcodes.ILOAD, lastTmp.val); pushTypedArray(type); storeTypedArray(type) END END END copyArrayR; PROCEDURE copyArray(x, tmpVars: OJB.Object); BEGIN copyArrayR(0, x, x.type, tmpVars, tmpVars) END copyArray; PROCEDURE copyState(x: OJB.Object); VAR type: OJB.Type; tempVars: OJB.Object; num: INTEGER; BEGIN (* 2 locals so far: this + copyFrom's parameter *) num := 2; tempVars := createArraysTempVars(x, num, FALSE); WHILE x # NIL DO IF (x.class = OJB.Var) OR (x.class = OJB.Fld) THEN type := x.type; IF type.form = OJB.Record THEN copyRecord(x) ELSIF type.form = OJB.Array THEN copyArray(x, tempVars) ELSE copyPrimitiveField(x) END END ; x := x.next; END ; topCtx.numTmpVars := num END copyState; PROCEDURE CopyMethod(obj: OJB.Object); VAR desc,typeName: ClassFormat.Descriptor; BEGIN internalName(obj.type, typeName); makeCopyDesc(typeName, desc); topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxFINAL, "copyFrom", desc); clearCtx(topCtx); copyState(obj.type.dsc); ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx); ClassFormat.setMaxVars(topCtx.m, topCtx.numTmpVars); closeContext END CopyMethod; PROCEDURE MainProc*(hasMain: BOOLEAN); BEGIN topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxPUBLIC + Opcodes.ACCxSTATIC, "main", "([Ljava/lang/String;)V"); clearCtx(topCtx); ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0); ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, topCtx.className, "args", "[Ljava/lang/String;"); IF hasMain THEN ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESTATIC, topCtx.className, "Main", "()V", 0) END ; ClassFormat.putInsn(topCtx.m, Opcodes.RETURNx); ClassFormat.setMaxVars(topCtx.m, 1); closeContext END MainProc; PROCEDURE addCmdLineArgs; BEGIN pushConst(0); ClassFormat.putTypeInsn(topCtx.m, Opcodes.ANEWARRAY, "java/lang/String"); ClassFormat.putFieldInsn(topCtx.m, Opcodes.PUTSTATIC, topCtx.className, "args", "[Ljava/lang/String;") END addCmdLineArgs; PROCEDURE ModuleBody*(topScope: OJB.Object); BEGIN topCtx.m := ClassFormat.NewMI(topCtx.c, Opcodes.ACCxSTATIC, "", "()V"); clearCtx(topCtx); addCmdLineArgs; initializeScope(topScope, 0) END ModuleBody; PROCEDURE Close*; VAR path: ARRAY OJS.maxPath OF CHAR; BEGIN genClassFilePath(topCtx.className, path); ClassFormat.toFile(topCtx.c, path) END Close; PROCEDURE deleteModule*; VAR path: ARRAY OJS.maxPath OF CHAR; r: INTEGER; BEGIN genClassFilePath(topCtx.className, path); r := Files.Delete(path) END deleteModule; PROCEDURE MakeRecordType*(obj: OJB.Object); VAR desc, name, baseName: ClassFormat.Descriptor; path: ARRAY OJS.maxPath OF CHAR; newCtx: ClassContext; access: INTEGER; tmp: OJB.Object; recordType: OJB.Type; BEGIN NEW(newCtx); internalName(obj.type, name); access := Opcodes.ACCxPUBLIC; Strings.Append("java/lang/Object", baseName); IF obj.type.base # NIL THEN internalName(obj.type.base, baseName); INC(access, Opcodes.ACCxSUPER) END ; Strings.Copy(topCtx.className, newCtx.className); newCtx.next := topCtx; topCtx := newCtx; newCtx.c := ClassFormat.NewCF(access, name, baseName); tmp := obj.type.dsc; recordType := obj.type; WHILE (tmp # NIL) & (tmp.class = OJB.Fld) & (recordType = tmp.recordType) DO Descriptor(tmp.type, desc); ClassFormat.addField(topCtx.c, Opcodes.ACCxPUBLIC, tmp.name, desc); tmp := tmp.next END ; Constructor(obj); CopyMethod(obj); genClassFilePath(name, path); ClassFormat.toFile(topCtx.c, path); topCtx := topCtx.next END MakeRecordType; BEGIN relmap[0] := Opcodes.IFICMPEQ; relmap[1] := Opcodes.IFICMPNE; relmap[2] := Opcodes.IFICMPLT; relmap[3] := Opcodes.IFICMPLE; relmap[4] := Opcodes.IFICMPGT; relmap[5] := Opcodes.IFICMPGE; relmap0[0] := Opcodes.IFEQ; relmap0[1] := Opcodes.IFNE; relmap0[2] := Opcodes.IFLT; relmap0[3] := Opcodes.IFLE; relmap0[4] := Opcodes.IFGT; relmap0[5] := Opcodes.IFGE; relmapNil[0] := Opcodes.IFNULL; relmapNil[1] := Opcodes.IFNONNULL; relmapAdr[0] := Opcodes.IFACMPEQ;relmapAdr[1] := Opcodes.IFACMPNE; END OJG. ================================================ FILE: src/OJP.Mod ================================================ (* Copyright 2017 Luca Boasso. Copyright (C)2013 Niklaus Wirth (NW), Juerg Gutknecht (JG), Paul Reed (PR/PDR). Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Parser of Oberon-JVM compiler. Uses Scanner OJS to obtain symbols (tokens), OJB for definition of data structures and for handling import and export, and OJG to produce bytecode. OJP performs type checking and data allocation. Parser is target-independent, except for part of the handling of allocations. *) MODULE OJP; (*Oberon compiler for JVM in Oberon-07*) IMPORT OJS, OJB, OJG, Strings; TYPE PtrBase = POINTER TO PtrBaseDesc; PtrBaseDesc = RECORD (*list of names of pointer base types*) name: OJS.Ident; type: OJB.Type; next: PtrBase END ; VAR sym: INTEGER; (*last symbol read*) level: INTEGER; nestedIdCounter: INTEGER; (*unique id for each nested procedure/type*) newSF, isDefinition: BOOLEAN; expression: PROCEDURE (VAR x: OJG.Item); (*to avoid forward reference*) Type: PROCEDURE (typedef: BOOLEAN): OJB.Type; FormalType: PROCEDURE (): OJB.Type; EqualSignatures: PROCEDURE (t0, t1: OJB.Type): BOOLEAN; modid: OJS.Ident; pbsList: PtrBase; (*list of names of pointer base types*) dummy: OJB.Object; hasMain: BOOLEAN; PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR); BEGIN IF sym = s THEN OJS.Get(sym) ELSE OJS.Mark(msg) END END Check; PROCEDURE qualident(VAR modName: ARRAY OF CHAR): OJB.Object; VAR obj, modObj: OJB.Object; BEGIN obj := OJB.thisObj(OJS.id); OJS.Get(sym); IF obj = NIL THEN OJS.Mark("undef"); obj := dummy END ; IF (sym = OJS.period) & (obj.class = OJB.Mod) THEN modObj := OJB.GetModFrom(obj); Strings.Copy(modObj.name, modName); OJS.Get(sym); IF sym = OJS.ident THEN obj := OJB.thisimport(obj, OJS.id); OJS.Get(sym); IF obj = NIL THEN OJS.Mark("undef"); obj := dummy END ELSE OJS.Mark("identifier expected"); obj := dummy END ELSE Strings.Copy(modid, modName) END RETURN obj END qualident; PROCEDURE CheckBool(VAR x: OJG.Item); BEGIN IF x.type.form # OJB.Bool THEN OJS.Mark("not Boolean"); x.type := OJB.boolType END END CheckBool; PROCEDURE CheckInt(VAR x: OJG.Item); BEGIN IF x.type.form # OJB.Int THEN OJS.Mark("not Integer"); x.type := OJB.intType END END CheckInt; PROCEDURE CheckByteRange(VAR x: OJG.Item); BEGIN IF (x.mode = OJB.Const) & ((x.a < 0) OR (x.a > 255)) THEN OJS.Mark("not a valid BYTE value") END END CheckByteRange; PROCEDURE CheckReal(VAR x: OJG.Item); BEGIN IF x.type.form # OJB.Real THEN OJS.Mark("not Real"); x.type := OJB.realType END END CheckReal; PROCEDURE CheckSet(VAR x: OJG.Item); BEGIN IF x.type.form # OJB.Set THEN OJS.Mark("not Set"); x.type := OJB.setType END END CheckSet; PROCEDURE CheckSetVal(VAR x: OJG.Item); BEGIN IF x.type.form # OJB.Int THEN OJS.Mark("not Int"); x.type := OJB.setType ELSIF x.mode = OJB.Const THEN IF (x.a < 0) OR (x.a >= OJG.MaxSetElement) THEN OJS.Mark("invalid set") END END END CheckSetVal; PROCEDURE CheckConst(VAR x: OJG.Item); BEGIN IF x.mode # OJB.Const THEN OJS.Mark("not a constant"); x.mode := OJB.Const END END CheckConst; PROCEDURE CheckReadOnly(VAR x: OJG.Item); BEGIN IF x.rdo THEN OJS.Mark("read-only") END END CheckReadOnly; PROCEDURE CheckExport(): BOOLEAN; VAR expo: BOOLEAN; BEGIN IF sym = OJS.times THEN expo := TRUE; OJS.Get(sym); IF level # 0 THEN OJS.Mark("remove asterisk") END ELSE expo := isDefinition END RETURN expo END CheckExport; PROCEDURE OrigFormalParamType(param: OJB.Object): OJB.Type; VAR partype: OJB.Type; BEGIN IF param.caseOrgType # NIL THEN partype := param.caseOrgType ELSE partype := param.type END RETURN partype END OrigFormalParamType; PROCEDURE FindObjFrom(modid: ARRAY OF CHAR; VAR x: OJG.Item): OJB.Object; VAR obj: OJB.Object; BEGIN IF (x.mode = OJB.Var) OR (x.mode = OJB.Par) OR (x.mode = OJB.ParStruct) THEN obj := OJB.FindObj(modid, x.modName, x.name) ELSE obj := NIL END RETURN obj END FindObjFrom; PROCEDURE IsExtension(t0, t1: OJB.Type): BOOLEAN; BEGIN (*t1 is an extension of t0*) RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base) END IsExtension; (* expressions *) PROCEDURE TypeTest(VAR x: OJG.Item; T: OJB.Type; guard: BOOLEAN); VAR xt: OJB.Type; BEGIN xt := x.type; IF (T.form = xt.form) & ((T.form = OJB.Pointer) OR (T.form = OJB.Record) & (x.mode = OJB.ParStruct)) THEN WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ; IF xt # T THEN xt := x.type; IF xt.form = OJB.Pointer THEN IF IsExtension(xt.base, T.base) THEN OJG.TypeTest(x, T.base, guard); x.type := T ELSE OJS.Mark("not an extension") END ELSIF (xt.form = OJB.Record) & (x.mode = OJB.ParStruct) THEN IF IsExtension(xt, T) THEN OJG.TypeTest(x, T, guard); x.type := T ELSE OJS.Mark("not an extension") END ELSE OJS.Mark("incompatible types") END ELSIF ~guard THEN OJG.ConstTypeTest(x) END ELSE OJS.Mark("type mismatch") END ; IF ~guard THEN x.type := OJB.boolType END END TypeTest; PROCEDURE selector(VAR x: OJG.Item); VAR y: OJG.Item; obj: OJB.Object; modName: OJS.Ident; BEGIN WHILE (sym = OJS.lbrak) OR (sym = OJS.period) OR (sym = OJS.arrow) OR (sym = OJS.lparen) & (x.type.form IN {OJB.Record, OJB.Pointer}) DO IF sym = OJS.lbrak THEN REPEAT OJG.Index0(x); OJS.Get(sym); expression(y); IF x.type.form = OJB.Array THEN CheckInt(y); OJG.Index(x, y); x.type := x.type.base ELSE OJS.Mark("not an array") END UNTIL sym # OJS.comma; Check(OJS.rbrak, "no ]") ELSIF sym = OJS.period THEN OJS.Get(sym); IF sym = OJS.ident THEN IF x.type.form = OJB.Pointer THEN x.type := x.type.base END ; IF x.type.form = OJB.Record THEN obj := OJB.thisfield(x.type); OJS.Get(sym); IF obj # NIL THEN OJG.FieldAccess(x, obj); x.type := obj.type ELSE OJS.Mark("undef") END ELSE OJS.Mark("not a record") END ELSE OJS.Mark("ident?") END ELSIF sym = OJS.arrow THEN OJS.Get(sym); IF x.type.form = OJB.Pointer THEN x.type := x.type.base ELSE OJS.Mark("not a pointer") END ELSE (*type guard*) OJS.Get(sym); IF sym = OJS.ident THEN obj := qualident(modName); IF obj.class = OJB.Typ THEN TypeTest(x, obj.type, TRUE) ELSE OJS.Mark("guard type expected") END ELSE OJS.Mark("not an identifier") END ; Check(OJS.rparen, " ) missing") END END END selector; (* Type Rule A, B *) PROCEDURE EqualTypes(t0, t1: OJB.Type): BOOLEAN; BEGIN RETURN (t0 = t1) OR (t0.form = OJB.Array) & (t1.form = OJB.Array) & (t0.len = t1.len) & EqualTypes(t0.base, t1.base) OR (t0.form = OJB.Proc) & (t1.form = OJB.Proc) & EqualSignatures(t0, t1) OR (t0.form = OJB.Pointer) & (t1.form = OJB.Pointer) & EqualTypes(t0.base, t1.base) END EqualTypes; (* Type Rule F.1, F.2 *) PROCEDURE CompatibleOpenArrays(t0, t1: OJB.Type): BOOLEAN; BEGIN RETURN EqualTypes(t0, t1) OR (t0.form = OJB.Array) & (t1.form = OJB.Array) & (t1.len < 0) & CompatibleOpenArrays(t0.base, t1.base) END CompatibleOpenArrays; PROCEDURE EqualSignatures0(t0, t1: OJB.Type): BOOLEAN; VAR p0, p1: OJB.Object; com: BOOLEAN; BEGIN com := TRUE; (* Type Rule C.1, C.2 *) IF (t0.nofpar = t1.nofpar) & EqualTypes(t0.base, t1.base) THEN p0 := t0.dsc; p1 := t1.dsc; WHILE p0 # NIL DO (* Type Rule C.3, C.4 *) IF (p0.class = p1.class) & (p0.rdo = p1.rdo) & EqualTypes(OrigFormalParamType(p0), OrigFormalParamType(p1)) THEN p0 := p0.next; p1 := p1.next ELSE p0 := NIL; com := FALSE END END ELSE com := FALSE END ; RETURN com END EqualSignatures0; PROCEDURE CompTypes(t0, t1: OJB.Type; varpar: BOOLEAN): BOOLEAN; BEGIN (*check for assignment compatibility*) (* Type Rule E.1, E.2, E.3, E.4 *) RETURN ~((t0.form = OJB.Array) & (t1.form = OJB.Array) & (t0.len < 0) & (t1.len < 0)) & EqualTypes(t0, t1) OR (t0.form = OJB.Record) & (t1.form = OJB.Record) & IsExtension(t0, t1) OR ~varpar & ((t0.form = OJB.Pointer) & (t1.form = OJB.Pointer) & IsExtension(t0.base, t1.base) OR (t0.form IN {OJB.Pointer, OJB.Proc}) & (t1.form = OJB.NilTyp)) END CompTypes; PROCEDURE Parameter(par: OJB.Object); VAR x: OJG.Item; varpar: BOOLEAN; partype: OJB.Type; BEGIN expression(x); IF par # NIL THEN partype := OrigFormalParamType(par); varpar := (par.class = OJB.Par) OR (par.class = OJB.ParStruct); IF CompTypes(partype, x.type, varpar) OR (* Type Rule G.1, G.2, G.3 *) CompatibleOpenArrays(x.type, partype) THEN (* Type Rule F.1, F.2 *) IF varpar & x.rdo THEN OJS.Mark("read only actual parameter") ELSIF ~varpar OR (par.class = OJB.ParStruct) THEN IF x.mode = OJB.Typ THEN OJS.Mark("illegal value parameter") END ; OJG.ValueParam(x) ELSE (*par.class = Par*) IF ~par.rdo THEN CheckReadOnly(x) END ; OJG.VarParam(x) END (* Type Rule F.3 *) ELSIF (x.type.form = OJB.String) & par.rdo & (partype.form = OJB.Array) & (partype.base.form = OJB.Char) & (partype.len < 0) THEN OJG.StringParam(x) (* Type Rule F.3, J *) ELSIF (x.type.form = OJB.Char) & x.rdo & par.rdo & (partype.form = OJB.Array) & (partype.base.form = OJB.Char) & (partype.len < 0) THEN OJG.CharToStr(x); OJG.StringParam(x) (* ~varpar below to prevent this: PROCEDURE P(VAR n: INTEGER); ... n := ... uses a STR instruction P(b) STR overwrites bytes around byte variable b *) (* Type Rule I, G.2 *) (*BYTE*) ELSIF ~varpar & (partype.form = OJB.Int) & (x.type.form = OJB.Int) THEN IF partype = OJB.byteType THEN CheckByteRange(x) END; OJG.ValueParam(x) (* Type Rule J, G.2 *) ELSIF (x.type.form = OJB.String) & (x.b = 2) & (par.class = OJB.Var) & (partype.form = OJB.Char) THEN OJG.StrToChar(x); OJG.ValueParam(x) ELSE OJS.Mark("incompatible parameters") END END END Parameter; PROCEDURE ParamList(VAR x: OJG.Item); VAR n: INTEGER; par: OJB.Object; BEGIN par := x.type.dsc; n := 0; IF sym # OJS.rparen THEN Parameter(par); n := 1; WHILE sym <= OJS.comma DO Check(OJS.comma, "comma?"); IF par # NIL THEN par := par.next END ; INC(n); Parameter(par) END ; Check(OJS.rparen, ") missing") ELSE OJS.Get(sym); END ; IF n < x.type.nofpar THEN OJS.Mark("too few params") ELSIF n > x.type.nofpar THEN OJS.Mark("too many params") END END ParamList; PROCEDURE StandFunc(VAR x: OJG.Item; fct: INTEGER; restyp: OJB.Type); VAR y: OJG.Item; n, npar: INTEGER; BEGIN Check(OJS.lparen, "no ("); npar := fct MOD 10; fct := fct DIV 10; n := 0; IF npar # 0 THEN expression(x); n := 1 END ; WHILE sym = OJS.comma DO OJS.Get(sym); IF (x.mode # OJB.Typ) & (* x.mode = ORB.Typ for SYSTEM.VAL(x, y) *) (x.mode # OJB.Const) (* allow constant folding in OJG.Shift/Band/Bor *) THEN OJG.ValueParam(x) END ; expression(y); INC(n) END ; Check(OJS.rparen, "no )"); IF n = npar THEN IF fct = 0 THEN (*ABS*) IF x.type.form IN {OJB.Int, OJB.Real} THEN OJG.Abs(x); restyp := x.type ELSE OJS.Mark("bad type") END ELSIF fct = 1 THEN (*ODD*) CheckInt(x); OJG.Odd(x) ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); OJG.Floor(x) ELSIF fct = 3 THEN (*FLT*) CheckInt(x); OJG.Float(x) ELSIF fct = 4 THEN (*ORD*) IF x.type.form IN {OJB.Char, OJB.Bool, OJB.Set} THEN OJG.Ord(x) ELSIF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x) ELSE OJS.Mark("bad type") END ELSIF fct = 5 THEN (*CHR*) CheckInt(x); OJG.Ord(x) ELSIF fct = 6 THEN (*LEN*) IF x.type.form = OJB.Array THEN OJG.Len(x) ELSE OJS.Mark("not an array") END ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) IF x.type.form IN {OJB.Int, OJB.Set} THEN CheckInt(x); CheckInt(y); OJG.Shift(fct-7, x, y); restyp := x.type ELSE OJS.Mark("bad type") END ELSIF fct = 11 THEN (*AND*) CheckInt(x); CheckInt(y); OJG.Band(x, y) ELSIF fct = 12 THEN (*BOR*) CheckInt(x); CheckInt(y); OJG.Bor(x, y) ELSIF fct = 15 THEN (*NOT*) CheckInt(x); OJG.Bnot(x) ELSIF fct = 16 THEN (*VAL*) IF x.mode = OJB.Typ THEN IF ((x.type = OJB.byteType) OR (x.type = OJB.intType)) & ((y.type = OJB.byteType) OR (y.type = OJB.intType)) THEN (* BYTE and INTEGER are compatible, this is a no-op. The resulting type must match the one of the expression to be converted, as the actual conversion happens elsewhere. *) restyp := y.type; ELSIF ((x.type = OJB.intType) OR (x.type.form = OJB.Set)) & ((y.type = OJB.intType) OR (y.type.form = OJB.Set)) THEN (* A SET is represented as an INTEGER, this is a no-op. *) restyp := x.type ELSIF (x.type.form = OJB.Real) & (y.type.form = OJB.Int) THEN OJG.IntToReal(y); restyp := x.type ELSIF (x.type.form = OJB.Int) & (y.type.form = OJB.Real) THEN OJG.RealToInt(y); restyp := x.type ELSIF (x.type.form = OJB.Pointer) & (y.type.form = OJB.Pointer) THEN TypeTest(y, x.type, TRUE); restyp := x.type ELSE OJS.Mark("casting not allowed") END ; x := y ELSE OJS.Mark("casting not allowed") END ELSIF fct = 21 THEN (*eot*) OJG.eot(x) ELSIF fct = 22 THEN (*ReadInt*) OJG.ReadInt(x) ELSIF fct = 23 THEN (*ARGNUM*) OJG.Argnum(x) END ; x.type := restyp ELSE OJS.Mark("wrong nof params") END END StandFunc; PROCEDURE element(VAR x: OJG.Item); VAR y: OJG.Item; BEGIN expression(x); CheckSetVal(x); IF sym = OJS.upto THEN OJS.Get(sym); OJG.Set0(x); expression(y); CheckSetVal(y); OJG.Set1(x, y) ELSE OJG.Singleton(x) END ; x.type := OJB.setType END element; PROCEDURE set(VAR x: OJG.Item); VAR y: OJG.Item; BEGIN IF sym >= OJS.if THEN IF sym # OJS.rbrace THEN OJS.Mark(" } missing") END ; OJG.MakeConstItem(x, OJB.setType, 0) (*empty set*) ELSE element(x); WHILE sym < OJS.rparen DO IF sym = OJS.comma THEN OJS.Get(sym) ELSE OJS.Mark("missing comma") END ; element(y); OJG.SetOp(OJS.plus, x, y) END END END set; PROCEDURE factor(VAR x: OJG.Item); VAR obj: OJB.Object; modName: OJS.Ident; BEGIN (*sync*) IF (sym < OJS.char) OR (sym > OJS.ident) THEN OJS.Mark("expression expected"); REPEAT OJS.Get(sym) UNTIL (sym >= OJS.char) & (sym <= OJS.for) OR (sym >= OJS.then) END ; IF sym = OJS.ident THEN obj := qualident(modName); IF obj.class = OJB.SFunc THEN StandFunc(x, obj.val, obj.type) ELSE Strings.Copy(modName, x.modName); OJG.MakeItem(x, obj); selector(x); IF sym = OJS.lparen THEN OJS.Get(sym); IF (x.type.form = OJB.Proc) & (x.type.base.form # OJB.NoTyp) THEN OJG.PrepCall(x); ParamList(x); OJG.Call(x); OJG.storeVarPar; x.type := x.type.base ELSE OJS.Mark("not a function"); ParamList(x) END END END ELSIF sym = OJS.int THEN OJG.MakeConstItem(x, OJB.intType, OJS.ival); OJS.Get(sym) ELSIF sym = OJS.real THEN OJG.MakeRealItem(x, OJS.rval); OJS.Get(sym) ELSIF sym = OJS.char THEN OJG.MakeConstItem(x, OJB.charType, OJS.ival); OJS.Get(sym) ELSIF sym = OJS.nil THEN OJS.Get(sym); OJG.MakeConstItem(x, OJB.nilType, 0) ELSIF sym = OJS.string THEN OJG.MakeStringItem(x); OJS.Get(sym) ELSIF sym = OJS.lparen THEN OJS.Get(sym); expression(x); Check(OJS.rparen, "no )") ELSIF sym = OJS.lbrace THEN OJS.Get(sym); set(x); Check(OJS.rbrace, "no }") ELSIF sym = OJS.not THEN OJS.Get(sym); factor(x); CheckBool(x); OJG.Not(x) ELSIF sym = OJS.false THEN OJS.Get(sym); OJG.MakeConstItem(x, OJB.boolType, 0) ELSIF sym = OJS.true THEN OJS.Get(sym); OJG.MakeConstItem(x, OJB.boolType, 1) ELSE OJS.Mark("not a factor"); OJG.MakeConstItem(x, OJB.intType, 0) END END factor; PROCEDURE term(VAR x: OJG.Item); VAR y: OJG.Item; op, f: INTEGER; BEGIN factor(x); f := x.type.form; WHILE (sym >= OJS.times) & (sym <= OJS.and) DO op := sym; OJS.Get(sym); IF op = OJS.times THEN OJG.loadOp(x); IF f = OJB.Int THEN factor(y); CheckInt(y); OJG.MulOp(x, y) ELSIF f = OJB.Real THEN factor(y); CheckReal(y); OJG.RealOp(op, x, y) ELSIF f = OJB.Set THEN factor(y); CheckSet(y); OJG.SetOp(op, x, y) ELSE OJS.Mark("bad type") END ELSIF (op = OJS.div) OR (op = OJS.mod) THEN OJG.loadOp(x); CheckInt(x); factor(y); CheckInt(y); OJG.DivOp(op, x, y) ELSIF op = OJS.rdiv THEN OJG.loadOp(x); IF f = OJB.Real THEN factor(y); CheckReal(y); OJG.RealOp(op, x, y) ELSIF f = OJB.Set THEN factor(y); CheckSet(y); OJG.SetOp(op, x, y) ELSE OJS.Mark("bad type") END ELSE (*op = and*) CheckBool(x); OJG.And1(x); factor(y); CheckBool(y); OJG.And2(x, y) END END END term; PROCEDURE SimpleExpression(VAR x: OJG.Item); VAR y: OJG.Item; op: INTEGER; BEGIN IF sym = OJS.minus THEN OJS.Get(sym); term(x); IF x.type.form IN {OJB.Int, OJB.Real, OJB.Set} THEN OJG.Neg(x) ELSE CheckInt(x) END ELSIF sym = OJS.plus THEN OJS.Get(sym); term(x); ELSE term(x) END ; WHILE (sym >= OJS.plus) & (sym <= OJS.or) DO op := sym; OJS.Get(sym); IF op = OJS.or THEN OJG.Or1(x); CheckBool(x); term(y); CheckBool(y); OJG.Or2(x, y) ELSIF x.type.form = OJB.Int THEN OJG.loadOp(x); term(y); CheckInt(y); OJG.AddOp(op, x, y) ELSIF x.type.form = OJB.Real THEN OJG.loadOp(x); term(y); CheckReal(y); OJG.RealOp(op, x, y) ELSE CheckSet(x); OJG.loadOp(x); term(y); CheckSet(y); OJG.SetOp(op, x, y) END END END SimpleExpression; PROCEDURE expression0(VAR x: OJG.Item); VAR y: OJG.Item; obj: OJB.Object; rel, xf, yf: INTEGER; modName: OJS.Ident; BEGIN SimpleExpression(x); IF (sym >= OJS.eql) & (sym <= OJS.geq) THEN rel := sym; OJS.Get(sym); OJG.loadOp(x); SimpleExpression(y); xf := x.type.form; yf := y.type.form; IF x.type = y.type THEN IF (xf IN {OJB.Char, OJB.Int}) THEN OJG.IntRelation(rel, x, y) ELSIF xf = OJB.Real THEN OJG.RealRelation(rel, x, y) ELSIF xf IN {OJB.Set, OJB.Pointer, OJB.Proc, OJB.NilTyp, OJB.Bool} THEN IF rel <= OJS.neq THEN OJG.IntRelation(rel, x, y) ELSE OJS.Mark("only = or #") END ELSIF (xf = OJB.Array) & (x.type.base.form = OJB.Char) OR (xf = OJB.String) THEN OJG.StringRelation(rel, x, y) ELSE OJS.Mark("illegal comparison") END ELSIF (xf IN {OJB.Pointer, OJB.Proc}) & (yf = OJB.NilTyp) OR (yf IN {OJB.Pointer, OJB.Proc}) & (xf = OJB.NilTyp) THEN IF rel <= OJS.neq THEN OJG.IntRelation(rel, x, y) ELSE OJS.Mark("only = or #") END ELSIF (xf = OJB.Pointer) & (yf = OJB.Pointer) & (IsExtension(x.type.base, y.type.base) OR IsExtension(y.type.base, x.type.base)) OR (xf = OJB.Proc) & (yf = OJB.Proc) & EqualSignatures(x.type, y.type) THEN IF rel <= OJS.neq THEN OJG.IntRelation(rel, x, y) ELSE OJS.Mark("only = or #") END ELSIF (xf = OJB.Array) & (x.type.base.form = OJB.Char) & ((yf = OJB.String) OR (yf = OJB.Array) & (y.type.base.form = OJB.Char)) OR (yf = OJB.Array) & (y.type.base.form = OJB.Char) & (xf = OJB.String) THEN OJG.StringRelation(rel, x, y) ELSIF (xf = OJB.Char) & (yf = OJB.String) & (y.b = 2) THEN OJG.StrToChar(y); OJG.IntRelation(rel, x, y) ELSIF (yf = OJB.Char) & (xf = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x); OJG.IntRelation(rel, x, y) (*BYTE*) ELSIF (xf = OJB.Int) & (yf = OJB.Int) THEN OJG.IntRelation(rel, x, y) ELSE OJS.Mark("illegal comparison") END ; x.type := OJB.boolType ELSIF sym = OJS.in THEN OJG.In0(x); OJS.Get(sym); CheckInt(x); SimpleExpression(y); CheckSet(y); OJG.In1(y); x.type := OJB.boolType ELSIF sym = OJS.is THEN OJS.Get(sym); obj := qualident(modName); Strings.Copy(modName, x.modName); TypeTest(x, obj.type, FALSE); x.type := OJB.boolType END END expression0; (* statements *) PROCEDURE StandProc(pno: INTEGER); VAR npar: INTEGER; (*nof formal parameters*) x, y, z: OJG.Item; BEGIN npar := pno MOD 10; pno := pno DIV 10; IF (npar = 0) & (pno = 17) THEN OJG.WriteLn ELSIF (npar = 2) & (pno = 24) THEN (*ARGS*) OJG.Args0(); Check(OJS.lparen, "no ("); expression(x); CheckInt(x); OJG.Args1(x); Check(OJS.comma, "no ,"); expression(y); Check(OJS.rparen, "no )"); IF (y.type.form # OJB.Array) OR (y.type.base # OJB.charType) THEN OJS.Mark("not ARRAY OF CHAR") END ; OJG.Args2(y) ELSIF (npar = 2) & ((pno = 2) OR (pno = 3)) THEN (*INCL, EXCL*) Check(OJS.lparen, "no ("); expression(x); CheckSet(x); CheckReadOnly(x); OJG.Include0(x, z); Check(OJS.comma, "no ,"); expression(y); Check(OJS.rparen, "no )"); CheckInt(y); OJG.Include1(pno-2, y, z) ELSIF (pno = 0) OR (pno = 1) THEN (*INC, DEC*) Check(OJS.lparen, "no ("); expression(x); CheckInt(x); CheckReadOnly(x); OJG.Increment0(x, z); IF sym = OJS.comma THEN OJS.Get(sym); expression(y); CheckInt(y) ELSE y.type := OJB.noType END ; Check(OJS.rparen, "no )"); OJG.Increment1(pno, x, y, z) ELSE Check(OJS.lparen, "no ("); expression(x); Check(OJS.rparen, "no )"); IF pno = 4 THEN CheckBool(x); OJG.Assert(x) ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x); IF (x.type.form = OJB.Pointer) & (x.type.base.form = OJB.Record) THEN OJG.New(x) ELSE OJS.Mark("not a pointer to record") END ELSIF pno = 15 THEN IF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x) ELSIF x.type.form # OJB.Char THEN OJS.Mark("not Char"); x.type := OJB.charType END ; OJG.WriteChar(x) ELSIF pno = 16 THEN CheckInt(x); OJG.WriteInt(x) ELSIF pno = 18 THEN CheckReal(x); OJG.WriteReal(x) END END END StandProc; PROCEDURE StatSequence; VAR obj: OJB.Object; orgtype: OJB.Type; (*original type of case var*) x, y, z, w: OJG.Item; L0, L1: INTEGER; modName: OJS.Ident; PROCEDURE TypeCase(obj: OJB.Object; VAR x: OJG.Item); VAR typobj: OJB.Object; modName: OJS.Ident; BEGIN IF sym = OJS.ident THEN typobj := qualident(modName); Strings.Copy(modName, x.modName); OJG.MakeItem(x, obj); x.oldType := NIL; IF typobj.class # OJB.Typ THEN OJS.Mark("not a type") END ; TypeTest(x, typobj.type, FALSE); obj.caseOrgType := obj.type; obj.type := typobj.type; OJG.CFJump(x); Check(OJS.colon, ": expected"); StatSequence ELSE OJS.Mark("type id expected"); OJG.CFJump(x) END END TypeCase; PROCEDURE LabelRange(labelForm: INTEGER; VAR x, y: OJG.Item; VAR n: INTEGER; VAR tab: ARRAY OF OJG.LabelRange; stmts: INTEGER); VAR i: INTEGER; done: BOOLEAN; BEGIN expression(x); CheckConst(x); IF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x) END ; IF x.type.form # labelForm THEN OJS.Mark("wrong type of case label") END ; IF sym = OJS.upto THEN OJS.Get(sym); expression(y); CheckConst(y); IF (y.type.form = OJB.String) & (y.b = 2) THEN OJG.StrToChar(y) END ; IF y.type.form # x.type.form THEN OJS.Mark("wrong type of case label") END ; IF y.a < x.a THEN OJS.Mark("illegal value of constant"); y.a := x.a END; ELSE y := x END ; (*enter label range into ordered table*) i := n; done := FALSE; IF i < OJG.NofCases THEN WHILE (i # 0) & ~done DO IF tab[i-1].low <= y.a THEN IF tab[i-1].high >= x.a THEN OJS.Mark("case label defined more than once") END ; done := TRUE ELSE tab[i] := tab[i-1]; DEC(i) END END ; tab[i].low := x.a; tab[i].high := y.a; tab[i].L := stmts; INC(n) ELSE OJS.Mark("too many cases or no case in case statement") END END LabelRange; PROCEDURE Case(labelForm: INTEGER; VAR n: INTEGER; VAR tab: ARRAY OF OJG.LabelRange); VAR x, y: OJG.Item; stmts: INTEGER; BEGIN IF sym IN {OJS.int, OJS.char, OJS.minus, OJS.plus, OJS.string, OJS.ident} THEN stmts := OJG.getPC(); LabelRange(labelForm, x, y, n, tab, stmts); WHILE sym = OJS.comma DO OJS.Get(sym); LabelRange(labelForm, x, y, n, tab, stmts) END ; IF sym IN {OJS.int, OJS.char, OJS.minus, OJS.plus, OJS.string,OJS.ident} THEN OJS.Mark("',' missing") END ; Check(OJS.colon, ": expected"); StatSequence; ELSE OJS.Mark("integer or character expected") END END Case; PROCEDURE CasePart(VAR caseExpr: OJG.Item); VAR n, L0, dflt, end: INTEGER; tab: ARRAY OJG.NofCases OF OJG.LabelRange; BEGIN L0 := 0; end := 0; n := 0; L0 := OJG.CaseIn(caseExpr, L0); Case(caseExpr.type.form, n, tab); end := OJG.FJump(end); WHILE sym = OJS.bar DO OJS.Get(sym); Case(caseExpr.type.form, n, tab); end := OJG.FJump(end) END ; dflt := OJG.CaseDefault(); OJG.CaseOut(caseExpr, end, L0, n, dflt, tab) END CasePart; PROCEDURE SkipCase; BEGIN WHILE sym # OJS.colon DO OJS.Get(sym) END ; OJS.Get(sym); StatSequence END SkipCase; BEGIN (* StatSequence *) REPEAT (*sync*) obj := NIL; IF ~((sym >= OJS.ident) & (sym <= OJS.for) OR (sym >= OJS.semicolon)) THEN OJS.Mark("statement expected"); REPEAT OJS.Get(sym) UNTIL sym >= OJS.ident END ; OJG.SetLineNumber(OJS.GetLine()); IF sym = OJS.ident THEN obj := qualident(modName); Strings.Copy(modName, x.modName); OJG.MakeItem(x, obj); IF x.mode = OJB.SProc THEN StandProc(obj.val) ELSE selector(x); IF sym = OJS.becomes THEN (*assignment*) OJS.Get(sym); CheckReadOnly(x); OJG.PrepAssign(x); expression(y); IF y.mode = OJB.Typ THEN OJS.Mark("illegal assignment") (* Type Rule E.1, E.2, E.3, E.4 *) ELSIF CompTypes(x.type, y.type, FALSE) THEN IF x.type.form <= OJB.Pointer THEN OJG.Store(x, y, FALSE) ELSIF x.type.form = OJB.Proc THEN OJG.StoreProc(x, y) ELSIF y.type.form = OJB.Record THEN OJG.Store(x, y, TRUE) ELSIF y.type.form = OJB.Array THEN OJG.storeArray(x, y) END (* Type Rule E.6 *) ELSIF (x.type.form = OJB.Array) & (y.type.form = OJB.Array) & (x.type.len > 0) & (y.type.len < 0) & EqualTypes(x.type.base, y.type.base) THEN OJG.storeArray(x, y) (* Type Rule E.5 *) ELSIF (x.type.form = OJB.Array) & (x.type.base.form = OJB.Char) & (y.type.form = OJB.String) THEN OJG.CopyString(x, y) (* Type Rule E.5, J *) ELSIF (x.type.form = OJB.Array) & (x.type.base.form = OJB.Char) & y.rdo & (y.type.form = OJB.Char) THEN OJG.CharToStr(y); OJG.CopyString(x, y); (* Type Rule I *) (*BYTE*) ELSIF (x.type.form = OJB.Int) & (y.type.form = OJB.Int) THEN IF x.type = OJB.byteType THEN CheckByteRange(y) END; OJG.Store(x, y, FALSE) (* Type Rule J *) ELSIF (x.type.form = OJB.Char) & (y.type.form = OJB.String) & (y.b = 2) THEN OJG.StrToChar(y); OJG.Store(x, y, FALSE) ELSE OJS.Mark("illegal assignment") END ELSIF sym = OJS.eql THEN OJS.Mark("should be :="); OJS.Get(sym); expression(y) ELSIF sym = OJS.lparen THEN (*procedure call*) OJS.Get(sym); IF (x.type.form = OJB.Proc) & (x.type.base.form = OJB.NoTyp) THEN OJG.PrepCall(x); ParamList(x); OJG.Call(x); OJG.storeVarPar ELSE OJS.Mark("not a procedure"); ParamList(x) END (*procedure call without parameters*) ELSIF x.type.form = OJB.Proc THEN IF x.type.nofpar > 0 THEN OJS.Mark("missing parameters") END ; IF x.type.base.form = OJB.NoTyp THEN OJG.PrepCall(x); OJG.Call(x) ELSE OJS.Mark("not a procedure") END ELSIF x.mode = OJB.Typ THEN OJS.Mark("illegal assignment") ELSE OJS.Mark("not a procedure") END END ELSIF sym = OJS.if THEN OJS.Get(sym); expression(x); CheckBool(x); OJG.CFJump(x); Check(OJS.then, "no THEN"); StatSequence; L0 := 0; WHILE sym = OJS.elsif DO OJS.Get(sym); L0 := OJG.FJump(L0); OJG.Fixup(x.a); expression(x); CheckBool(x); OJG.CFJump(x); Check(OJS.then, "no THEN"); StatSequence END ; IF sym = OJS.else THEN OJS.Get(sym); L0 := OJG.FJump(L0); OJG.Fixup(x.a); StatSequence ELSE OJG.Fixup(x.a) END ; OJG.Fixup(L0); Check(OJS.end, "no END") ELSIF sym = OJS.while THEN OJS.Get(sym); L0 := OJG.getPC(); expression(x); CheckBool(x); OJG.CFJump(x); Check(OJS.do, "no DO"); StatSequence; OJG.BJump(L0); WHILE sym = OJS.elsif DO OJS.Get(sym); OJG.Fixup(x.a); expression(x); CheckBool(x); OJG.CFJump(x); Check(OJS.do, "no DO"); StatSequence; OJG.BJump(L0) END ; OJG.Fixup(x.a); Check(OJS.end, "no END") ELSIF sym = OJS.repeat THEN OJS.Get(sym); L0 := OJG.getPC(); StatSequence; IF sym = OJS.until THEN OJS.Get(sym); expression(x); CheckBool(x); OJG.CBJump(x, L0) ELSE OJS.Mark("missing UNTIL") END ELSIF sym = OJS.for THEN OJS.Get(sym); IF sym = OJS.ident THEN obj := qualident(modName); Strings.Copy(modName, x.modName); OJG.MakeItem(x, obj); CheckInt(x); CheckReadOnly(x); IF sym = OJS.becomes THEN OJG.loadPar(x); OJS.Get(sym); expression(y); CheckInt(y); OJG.For0(x, y); L0 := OJG.getPC(); Check(OJS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE; IF sym = OJS.by THEN OJS.Get(sym); expression(w); CheckConst(w); CheckInt(w) ELSE OJG.MakeConstItem(w, OJB.intType, 1) END ; Check(OJS.do, "no DO"); L1 := OJG.For1(x, z, w); StatSequence; Check(OJS.end, "no END"); OJG.For2(x, w); OJG.BJump(L0); OJG.Fixup(L1); obj.rdo := FALSE ELSE OJS.Mark(":= expected") END ELSE OJS.Mark("identifier expected") END ELSIF sym = OJS.case THEN OJS.Get(sym); expression(x); Check(OJS.of, "OF expected"); obj := FindObjFrom(modid, x); IF (obj # NIL) & ((obj.type.form = OJB.Pointer) OR (obj.type.form = OJB.Record) & (obj.class = OJB.ParStruct)) THEN orgtype := obj.type; TypeCase(obj, x); L0 := 0; WHILE sym = OJS.bar DO OJS.Get(sym); L0 := OJG.FJump(L0); OJG.Fixup(x.a); obj.type := orgtype; obj.caseOrgType := NIL; TypeCase(obj, x) END ; OJG.Fixup(x.a); OJG.Fixup(L0); obj.type := orgtype; obj.caseOrgType := NIL ELSIF (obj = NIL) & ((x.type.form = OJB.Pointer) OR (x.type.form = OJB.Record)) THEN OJS.Mark("identifier expected") ELSIF (x.type.form = OJB.Int) OR (x.type.form = OJB.Char) THEN CasePart(x) ELSE OJS.Mark("inadmissible type"); SkipCase; WHILE sym = OJS.bar DO SkipCase END END ; Check(OJS.end, "no END") END ; IF sym = OJS.semicolon THEN OJS.Get(sym) ELSIF sym < OJS.semicolon THEN OJS.Mark("missing semicolon?") END ; IF (OJG.curStack() # 0) & (OJS.errcnt = 0) THEN OJS.Mark("Reg Stack") END UNTIL sym > OJS.semicolon END StatSequence; (* Types and declarations *) PROCEDURE IdentList(class: INTEGER): OJB.Object; VAR obj, first: OJB.Object; BEGIN IF sym = OJS.ident THEN first := OJB.InsertObj(OJS.id, class); OJS.Get(sym); first.expo := CheckExport(); WHILE sym = OJS.comma DO OJS.Get(sym); IF sym = OJS.ident THEN obj := OJB.InsertObj(OJS.id, class); OJS.Get(sym); obj.expo := CheckExport() ELSE OJS.Mark("ident?") END END; IF sym = OJS.colon THEN OJS.Get(sym) ELSE OJS.Mark(":?") END ELSE first := NIL END RETURN first END IdentList; PROCEDURE ArrayType(): OJB.Type; VAR x: OJG.Item; typ, type: OJB.Type; len: INTEGER; BEGIN NEW(typ); typ.form := OJB.NoTyp; expression(x); IF (x.mode = OJB.Const) & (x.type.form = OJB.Int) & (x.a >= 0) THEN len := x.a ELSE len := 1; OJS.Mark("not a valid length") END ; IF sym = OJS.of THEN OJS.Get(sym); typ.base := Type(FALSE); ELSIF sym = OJS.comma THEN OJS.Get(sym); typ.base := ArrayType() ELSE OJS.Mark("missing OF"); typ.base := OJB.intType END ; typ.form := OJB.Array; typ.len := len; type := typ RETURN type END ArrayType; PROCEDURE RecordType(): OJB.Type; VAR obj, obj0, new, bot, base: OJB.Object; type, typ, tp: OJB.Type; modName: OJS.Ident; BEGIN NEW(typ); typ.form := OJB.NoTyp; typ.base := NIL; typ.nofpar := 0; bot := NIL; IF sym = OJS.lparen THEN OJS.Get(sym); (*record extension*) IF sym = OJS.ident THEN base := qualident(modName); IF base.class = OJB.Typ THEN IF base.type.form = OJB.Record THEN typ.base := base.type ELSE typ.base := OJB.intType; OJS.Mark("invalid extension") END ; bot := typ.base.dsc ELSE OJS.Mark("type expected") END ELSE OJS.Mark("ident expected") END ; Check(OJS.rparen, "no )") END ; WHILE sym = OJS.ident DO (*fields*) obj := bot; WHILE sym = OJS.ident DO obj0 := obj; WHILE (obj0 # NIL) & (obj0.name # OJS.id) DO obj0 := obj0.next END ; IF obj0 # NIL THEN OJS.Mark("mult def") END ; NEW(new); Strings.Copy(OJS.id, new.name); new.nestedId := 0; new.class := OJB.Fld; new.recordType := typ; new.next := obj; obj := new; OJS.Get(sym); new.expo := CheckExport(); IF (sym # OJS.comma) & (sym # OJS.colon) THEN OJS.Mark("comma expected") ELSIF sym = OJS.comma THEN OJS.Get(sym) END END ; Check(OJS.colon, "colon expected"); tp := Type(FALSE); IF (tp.form = OJB.Array) & (tp.len < 0) THEN OJS.Mark("dyn array not allowed") END ; obj0 := obj; WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; obj0 := obj0.next END; bot := obj; IF sym = OJS.semicolon THEN OJS.Get(sym) ELSIF sym # OJS.end THEN OJS.Mark(" ; or END") END END ; typ.form := OJB.Record; typ.dsc := bot; type := typ RETURN type END RecordType; PROCEDURE FPSection(VAR adr: INTEGER; VAR nofpar: INTEGER); VAR obj, first: OJB.Object; tp: OJB.Type; cl: INTEGER; rdo: BOOLEAN; BEGIN IF sym = OJS.var THEN OJS.Get(sym); cl := OJB.Par ELSE cl := OJB.Var END ; first := IdentList(cl); tp := FormalType(); rdo := FALSE; IF (cl = OJB.Var) & (tp.form >= OJB.Array) THEN (* cl = ORB.Par; not needed as arrays/records are references in JVM*) rdo := TRUE ELSIF (cl = OJB.Par) & (tp.form >= OJB.Array) THEN (* arrays/records are references in JVM, OJB.ParStruct is equivalent to OJB.Var but for structured types *) cl := OJB.ParStruct END ; obj := first; WHILE obj # NIL DO INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr; adr := adr + 1; obj := obj.next END ; IF adr > OJG.ParamsMax THEN OJS.Mark("too many parameters") END END FPSection; PROCEDURE ProcedureType(ptype: OJB.Type; parblksize: INTEGER): INTEGER; VAR obj: OJB.Object; size: INTEGER; nofpar: INTEGER; modName: OJS.Ident; BEGIN ptype.base := OJB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL; IF sym = OJS.lparen THEN OJS.Get(sym); IF sym = OJS.rparen THEN OJS.Get(sym) ELSE FPSection(size, nofpar); WHILE sym = OJS.semicolon DO OJS.Get(sym); FPSection(size, nofpar) END ; Check(OJS.rparen, "no )") END ; IF sym = OJS.colon THEN (*function*) OJS.Get(sym); IF sym = OJS.ident THEN obj := qualident(modName); ptype.base := obj.type; (* Type Rule H *) IF ~((obj.class = OJB.Typ) & (obj.type.form IN {OJB.Byte .. OJB.Pointer, OJB.Proc})) THEN OJS.Mark("illegal function type") END ELSE OJS.Mark("type identifier expected") END END END ; ptype.nofpar := nofpar; parblksize := size RETURN parblksize END ProcedureType; PROCEDURE FormalType0(): OJB.Type; VAR obj: OJB.Object; dmy: INTEGER; typ: OJB.Type; modName: OJS.Ident; BEGIN IF sym = OJS.ident THEN obj := qualident(modName); IF obj.class = OJB.Typ THEN typ := obj.type ELSE OJS.Mark("not a type"); typ := OJB.intType END ELSIF sym = OJS.array THEN OJS.Get(sym); Check(OJS.of, "OF ?"); NEW(typ); typ.form := OJB.Array; typ.len := -1; typ.base := FormalType() ELSIF sym = OJS.procedure THEN OJS.Get(sym); OJB.OpenScope; NEW(typ); typ.form := OJB.Proc; dmy := ProcedureType(typ, 0); typ.dsc := OJB.topScope.next; OJB.CloseScope; OJG.genSignature(typ); OJG.MakeProcType(typ) ELSE OJS.Mark("identifier expected"); typ := OJB.noType END RETURN typ END FormalType0; PROCEDURE Type0(typedef: BOOLEAN): OJB.Type; VAR dmy: INTEGER; obj, tmp: OJB.Object; ptbase: PtrBase; type: OJB.Type; modName: OJS.Ident; BEGIN type := OJB.intType; (*sync*) IF (sym # OJS.ident) & (sym < OJS.array) THEN OJS.Mark("not a type"); REPEAT OJS.Get(sym) UNTIL (sym = OJS.ident) OR (sym >= OJS.array) END ; IF sym = OJS.ident THEN obj := qualident(modName); IF obj.class = OJB.Typ THEN IF (obj.type # NIL) & (obj.type.form # OJB.NoTyp) THEN type := obj.type END ELSE OJS.Mark("not a type or undefined") END ELSIF sym = OJS.array THEN OJS.Get(sym); type := ArrayType() ELSIF sym = OJS.record THEN OJS.Get(sym); type := RecordType(); Check(OJS.end, "no END"); IF ~typedef & ~isDefinition THEN OJG.MakeRecordType(OJB.generateAnonymousTypeObj(type)) END ELSIF sym = OJS.pointer THEN OJS.Get(sym); Check(OJS.to, "no TO"); NEW(type); type.form := OJB.Pointer; type.base := OJB.intType; IF sym = OJS.ident THEN obj := OJB.thisObj(OJS.id); IF obj # NIL THEN OJS.Get(sym); IF (obj.class = OJB.Typ) & (obj.type.form IN {OJB.Record, OJB.NoTyp}) THEN type.base := obj.type ELSIF (sym = OJS.period) & (obj.class = OJB.Mod) THEN OJS.Get(sym); IF sym = OJS.ident THEN obj := OJB.thisimport(obj, OJS.id); OJS.Get(sym); IF obj = NIL THEN OJS.Mark("undef") ELSE type.base := obj.type END ELSE OJS.Mark("identifier expected") END ELSE OJS.Mark("no valid base type") END ELSE (*enter into list of forward references to be fixed in Declarations*) NEW(ptbase); Strings.Copy(OJS.id, ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase; OJS.Get(sym); (* Temporarily save base type name (needed by OJG.internalName despite forward references are not fixed yet) *) NEW(type.base); type.base.form := OJB.Int; NEW(tmp); Strings.Copy(ptbase.name, tmp.name); IF level > 0 THEN tmp.nestedId := nestedIdCounter; INC(nestedIdCounter) END ; type.base.typobj := tmp END ELSE type.base := Type(FALSE); IF type.base.form # OJB.Record THEN OJS.Mark("must point to record"); type := OJB.intType END END ELSIF sym = OJS.procedure THEN OJS.Get(sym); OJB.OpenScope; NEW(type); type.form := OJB.Proc; dmy := ProcedureType(type, 0); type.dsc := OJB.topScope.next; OJB.CloseScope; OJG.genSignature(type); OJG.MakeProcType(type) ELSE OJS.Mark("illegal type") END RETURN type END Type0; PROCEDURE Declarations(varsize: INTEGER): INTEGER; VAR obj, first: OJB.Object; x: OJG.Item; tp: OJB.Type; ptbase: PtrBase; expo, alias: BOOLEAN; id: OJS.Ident; BEGIN (*sync*) pbsList := NIL; IF (sym < OJS.const) & (sym # OJS.end) & (sym # OJS.return) THEN OJS.Mark("declaration?"); REPEAT OJS.Get(sym) UNTIL (sym >= OJS.const) OR (sym = OJS.end) OR (sym = OJS.return) END ; IF sym = OJS.const THEN OJS.Get(sym); WHILE sym = OJS.ident DO Strings.Copy(OJS.id, id); OJS.Get(sym); expo := CheckExport(); IF sym = OJS.eql THEN OJS.Get(sym) ELSE OJS.Mark("= ?") END; expression(x); IF (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x) END ; obj := OJB.InsertObj(id, OJB.Const); obj.expo := expo; obj.rdo := TRUE; IF x.mode = OJB.Const THEN obj.val := x.a; obj.len := x.b; obj.type := x.type ELSE OJS.Mark("expression not constant"); obj.type := OJB.intType END; Check(OJS.semicolon, "; missing") END END ; IF sym = OJS.type THEN OJS.Get(sym); WHILE sym = OJS.ident DO alias := FALSE; Strings.Copy(OJS.id, id); OJS.Get(sym); expo := CheckExport(); IF sym = OJS.eql THEN OJS.Get(sym) ELSE OJS.Mark("=?") END ; tp := Type(TRUE); obj := OJB.InsertObj(id, OJB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level; IF level > 0 THEN obj.nestedId := nestedIdCounter; INC(nestedIdCounter) END ; IF tp.typobj = NIL THEN (*aliases must not modify the typobj*) tp.typobj := obj ELSE alias := TRUE END ; IF tp.form = OJB.Record THEN (* Check whether this object record (obj) is the base of a pointer type that was created (via Type()) before obj was inserted in the symbol table (via InsertObj(id, OJB.Typ)) When this happens the base of the pointer type must to be fixed. Examples: 1. P is defined before R is defined: P = POINTER TO R; R = RECORD END; 2. The type of x is defined before R is fully defined. R = RECORD x: POINTER TO R END; *) ptbase := pbsList; WHILE ptbase # NIL DO IF obj.name = ptbase.name THEN (* Keep the nestedId computed when the tmp base object type was created *) obj.type.typobj.nestedId := ptbase.type.base.typobj.nestedId; ptbase.type.base := obj.type END ; ptbase := ptbase.next END ; END ; Check(OJS.semicolon, "; missing"); IF (obj.type.form = OJB.Record) & ~alias & ~isDefinition THEN OJG.MakeRecordType(obj) END END END ; IF sym = OJS.var THEN OJS.Get(sym); WHILE sym = OJS.ident DO first := IdentList(OJB.Var); tp := Type(FALSE); obj := first; WHILE obj # NIL DO obj.type := tp; obj.lev := level; obj.val := varsize; INC(varsize); obj := obj.next END ; Check(OJS.semicolon, "; missing") END END ; ptbase := pbsList; WHILE ptbase # NIL DO IF ptbase.type.base.form = OJB.Int THEN OJS.MarkAppend("undefined pointer base: ", ptbase.name) END ; ptbase := ptbase.next END ; IF (sym >= OJS.const) & (sym <= OJS.var) THEN OJS.Mark("declaration in bad order") END RETURN varsize END Declarations; PROCEDURE ProcedureDecl; VAR proc: OJB.Object; type: OJB.Type; procid: OJS.Ident; x: OJG.Item; locblksize, parblksize: INTEGER; BEGIN (* ProcedureDecl *) OJS.Get(sym); IF sym = OJS.ident THEN Strings.Copy(OJS.id, procid); OJS.Get(sym); proc := OJB.InsertObj(OJS.id, OJB.Const); proc.lev := level; parblksize := 0; NEW(type); type.form := OJB.Proc; proc.type := type; IF level > 0 THEN proc.nestedId := nestedIdCounter; INC(nestedIdCounter) END ; proc.expo := CheckExport(); OJB.OpenScope; INC(level); proc.val := 0; type.base := OJB.noType; parblksize := ProcedureType(type, parblksize); (*formal parameter list*) IF procid = "Main" THEN IF type.nofpar # 0 THEN OJS.Mark("Main cannot have formal parameters") ELSIF type.base # OJB.noType THEN OJS.Mark("Main cannot have a return type") ELSE hasMain := TRUE END END ; IF ~isDefinition THEN Check(OJS.semicolon, "no ;"); locblksize := parblksize; locblksize := Declarations(locblksize); proc.type.dsc := OJB.topScope.next; OJG.genSignature(proc.type); IF sym = OJS.procedure THEN REPEAT ProcedureDecl; Check(OJS.semicolon, "no ;") UNTIL sym # OJS.procedure; proc.type.dsc := OJB.topScope.next END ; OJG.Enter(proc, locblksize); IF sym = OJS.begin THEN OJS.Get(sym); StatSequence END ; IF sym = OJS.return THEN OJS.Get(sym); expression(x); IF type.base = OJB.noType THEN OJS.Mark("this is not a function") (* Type Rule I *) ELSIF (type.base.form = OJB.Int) & (x.type.form = OJB.Int) THEN IF type.base = OJB.byteType THEN CheckByteRange(x) END (* Type Rule J *) ELSIF (type.base.form = OJB.Char) & (x.type.form = OJB.String) & (x.b = 2) THEN OJG.StrToChar(x); (* Type Rule H *) ELSIF ~CompTypes(type.base, x.type, FALSE) THEN OJS.Mark("wrong result type") END ELSIF type.base.form # OJB.NoTyp THEN OJS.Mark("function without result"); type.base := OJB.noType END ; OJG.Return(type.base, x); OJB.CheckUnused(parblksize); OJB.CloseScope; DEC(level); Check(OJS.end, "no END"); IF sym = OJS.ident THEN IF OJS.id # procid THEN OJS.Mark("no match") END ; OJS.Get(sym) ELSE OJS.Mark("no proc id") END ELSE proc.type.dsc := OJB.topScope.next; OJG.genSignature(proc.type); OJB.CloseScope; DEC(level) END ELSE OJS.Mark("proc id expected") END END ProcedureDecl; PROCEDURE Import; VAR aliasName, impName: OJS.Ident; BEGIN IF sym = OJS.ident THEN Strings.Copy(OJS.id, aliasName); OJS.Get(sym); IF sym = OJS.becomes THEN OJS.Get(sym); IF isDefinition THEN OJS.Mark("module alias not allowed") END ; IF sym = OJS.ident THEN Strings.Copy(OJS.id, impName); OJS.Get(sym) ELSE OJS.Mark("id expected"); impName := "" END ELSE Strings.Copy(aliasName, impName) END ; OJB.Import(aliasName, impName, modid) ELSE OJS.Mark("id expected") END END Import; PROCEDURE Module(outputFolder: ARRAY OF CHAR); VAR dc: INTEGER; dmy: OJG.Item; BEGIN isDefinition := FALSE; hasMain := FALSE; nestedIdCounter := 1; OJS.Get(sym); IF (sym = OJS.module) OR (sym = OJS.definition) THEN IF sym = OJS.definition THEN isDefinition := TRUE END ; OJS.Get(sym); IF sym = OJS.ident THEN Strings.Copy(OJS.id, modid); OJS.Get(sym); ELSE OJS.Mark("identifier expected") END ; Check(OJS.semicolon, "no ;"); level := 0; dc := 0; OJB.Init(outputFolder, modid); OJB.OpenScope; IF sym = OJS.import THEN OJS.Get(sym); Import; WHILE sym = OJS.comma DO OJS.Get(sym); Import END ; Check(OJS.semicolon, "; missing") END ; OJG.Open(modid); dc := Declarations(dc); WHILE sym = OJS.procedure DO ProcedureDecl; Check(OJS.semicolon, "no ;") END ; IF ~isDefinition THEN OJG.Header(OJB.topScope); OJG.MainProc(hasMain); OJG.ModuleBody(OJB.topScope); IF sym = OJS.begin THEN OJS.Get(sym); StatSequence END ; OJG.Return(NIL, dmy); END ; Check(OJS.end, "no END"); IF sym = OJS.ident THEN IF OJS.id # modid THEN OJS.Mark("no match") END ; OJS.Get(sym) ELSE OJS.Mark("identifier missing") END ; IF sym # OJS.period THEN OJS.Mark("period missing") END ; IF ~isDefinition THEN OJB.CheckUnused(0) END ; IF OJS.errcnt = 0 THEN OJB.Export(modid, newSF); END ; IF OJS.errcnt = 0 THEN IF ~isDefinition THEN OJG.Close END ; ELSE OJS.Mark("compilation FAILED"); OJG.deleteModule END ; OJB.CloseScope; pbsList := NIL ELSE OJS.Mark("must start with MODULE or DEFINITION") END END Module; PROCEDURE Compile*(fname: ARRAY OF CHAR; newSym: BOOLEAN; VAR outputFolder: ARRAY OF CHAR); BEGIN newSF := newSym; OJS.Init(fname); IF OJS.errcnt = 0 THEN Module(outputFolder) END END Compile; BEGIN NEW(dummy); dummy.class := OJB.Var; dummy.type := OJB.intType; expression := expression0; Type := Type0; FormalType := FormalType0; EqualSignatures := EqualSignatures0 END OJP. ================================================ FILE: src/OJS.Mod ================================================ (* Copyright 2017 Luca Boasso. Copyright (C)2013 Niklaus Wirth (NW), Juerg Gutknecht (JG), Paul Reed (PR/PDR). Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Oberon Scanner does lexical analysis. Input is UTF8 text, output is sequence of symbols, i.e identifiers, numbers, strings, and special symbols. Recognises all Oberon keywords and skips comments. The keywords are recorded in a table. Get(sym) delivers next symbol from input text. Mark()/MarkAppend() record error and delivers error message on standard output. If Get delivers ident, then the identifier (a string) is in variable id, if int or char in ival, if real in rval, and if string in str (and slen) *) MODULE OJS; IMPORT SYSTEM, Strings, Files, Out; CONST IdLen* = 32; NKW = 34; (*nof keywords*) maxKWX = 11; maxKWD = 11; maxExp = 38; minExp = -45; stringBufSize* = 256; maxStrx = stringBufSize*500; maxSrcSize = 200000; maxErrMsgSize = 200; maxPath* = 200; (*lexical symbols*) null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4; and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; in* = 15; is* = 16; arrow* = 17; period* = 18; char* = 20; int* = 21; real* = 22; false* = 23; true* = 24; nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29; lbrace* = 30; ident* = 31; if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37; comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44; rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49; to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54; else* = 55; elsif* = 56; until* = 57; return* = 58; array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64; var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; definition* = 70; eot = 71; TYPE Ident* = ARRAY IdLen OF CHAR; VAR ival*, strpos*: INTEGER; (*results of Get*) slen*: INTEGER; (*include terminal 0X*) rval*: REAL; id*: Ident; (*for identifiers*) strBuf: ARRAY maxStrx OF CHAR; strx: INTEGER; errcnt*: INTEGER; ch: CHAR; (*last character read*) errpos: INTEGER; pos: INTEGER; EOF: BOOLEAN; k: INTEGER; KWX: ARRAY maxKWX OF INTEGER; keyTab: ARRAY NKW OF RECORD sym: INTEGER; id: ARRAY maxKWD OF CHAR END; src: ARRAY maxSrcSize OF BYTE; srcSize: INTEGER; line, prevLine, col, prevCol: INTEGER; inputPath: ARRAY maxPath OF CHAR; PROCEDURE MarkAppend*(msg, extra: ARRAY OF CHAR); VAR out: ARRAY maxErrMsgSize OF CHAR; BEGIN IF (pos > errpos) & (errcnt < 25) THEN Strings.Append(inputPath, out); Strings.AppendChar(":", out); Strings.AppendInt(prevLine, 0, out); Strings.AppendChar(":", out); Strings.AppendInt(prevCol, 0, out); Strings.Append(": ", out); Strings.Append(msg, out); Out.String(out); Out.String(extra); Out.Ln; INC(errcnt); errpos := pos + 4 END END MarkAppend; PROCEDURE Mark*(msg: ARRAY OF CHAR); BEGIN MarkAppend(msg, "") END Mark; PROCEDURE ExtractChar*(a: INTEGER): CHAR; VAR c: CHAR; BEGIN IF a < maxStrx THEN c := strBuf[a] ELSE c := 0X END RETURN c END ExtractChar; PROCEDURE InsertChar*(c: CHAR): INTEGER; VAR idx: INTEGER; BEGIN idx := strx; IF (strx + 1) < maxStrx THEN strBuf[strx] := c; strBuf[strx + 1] := 0X; INC(strx, 2) ELSE Mark("too many strings") END RETURN idx END InsertChar; PROCEDURE ExtractStr*(i, len: INTEGER; VAR out: ARRAY OF CHAR); VAR j: INTEGER; BEGIN j := 0; WHILE (j < len) & (i < maxStrx) & (j < LEN(out)) DO out[j] := strBuf[i]; INC(i); INC(j) END END ExtractStr; PROCEDURE InsertStr*(in: ARRAY OF CHAR; len: INTEGER): INTEGER; VAR i, idx: INTEGER; BEGIN i := 0; idx := strx; IF (strx + len - 1) < maxStrx THEN WHILE len > 0 DO strBuf[strx] := in[i]; INC(strx); INC(i); DEC(len) END ELSE Mark("too many strings") END RETURN idx END InsertStr; PROCEDURE getUTF8(): BOOLEAN; VAR ok: BOOLEAN; x, b1, b2, b3: INTEGER; BEGIN ok := FALSE; ch := 0X; IF pos < srcSize THEN b1 := src[pos]; x := ASR(b1, 4); CASE x OF 0..7: (* 1 bytes format: 0xxxxxxx *) ch := CHR(b1); ok := TRUE | 12, 13: (* 2 bytes format: 110xxxxx 10xxxxxx *) IF pos+1 < srcSize THEN INC(pos); b2 := src[pos]; IF AND(b2, 0C0H) # 80H THEN Mark("Invalid UTF8 character") ELSE ch := CHR(BOR(LSL(AND(b1, 1FH), 6), AND(b2, 3FH))); ok := TRUE END END | 14: (* 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx *) IF pos+2 < srcSize THEN INC(pos); b2 := src[pos]; INC(pos); b3 := src[pos]; IF (AND(b2, 0C0H) # 80H) OR (AND(b3, 0C0H) # 80H) THEN Mark("Invalid UTF8 character") ELSE ch := CHR(BOR(LSL(AND(b1, 0FH), 12), BOR(LSL(AND(b2, 3FH), 6), AND(b3, 3FH)))); ok := TRUE END END | 8..11, 15: (* ERROR + 4 bytes format: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx *) Mark("Invalid UTF8 character") END END RETURN ok END getUTF8; PROCEDURE read(); BEGIN IF getUTF8() THEN IF ch = 0AX THEN (* 0AX = \n *) col := 0; INC(line) ELSE INC(col); END ; INC(pos) ELSE EOF := TRUE; ch := 0X END END read; PROCEDURE GetLine*(): INTEGER; RETURN line END GetLine; PROCEDURE Identifier(VAR sym: INTEGER); VAR i, k: INTEGER; BEGIN i := 0; REPEAT IF i < IdLen-1 THEN id[i] := ch; INC(i) END ; read UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z"); id[i] := 0X; IF i < maxKWX THEN k := KWX[i-1]; (*search for keyword*) WHILE (k < KWX[i]) & (id # keyTab[k].id) DO INC(k) END ; IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END ELSE sym := ident END END Identifier; PROCEDURE String; BEGIN read; strpos := strx; WHILE ~EOF & (ch # 22X) DO (* 22X = " *) IF ch >= " " THEN IF strx < maxStrx-1 THEN strBuf[strx] := ch; INC(strx) ELSE Mark("string too long") END END ; read END ; IF strx < maxStrx THEN strBuf[strx] := 0X; INC(strx) END; read; slen := strx-strpos END String; PROCEDURE HexString; VAR m, n: INTEGER; BEGIN read; strpos := strx; WHILE ~EOF & (ch # "$") DO WHILE ~EOF & (ch <= " ") DO read END ; (*skip*) IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - ORD("0") ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - ORD("7") ELSE m := 0; Mark("hexdig expected") END ; read; IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - ORD("0") ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - ORD("7") ELSE n := 0; Mark("hexdig expected") END ; IF strx < maxStrx THEN strBuf[strx] := CHR(m*10H + n); INC(strx) ELSE Mark("string too long") END ; read END ; read; slen := strx-strpos (*no 0X appended*) END HexString; PROCEDURE Ten(e: INTEGER): REAL; VAR x, t: REAL; BEGIN x := 1.0; t := 10.0; WHILE e > 0 DO IF ODD(e) THEN x := t * x END ; t := t * t; e := e DIV 2 END ; RETURN x END Ten; PROCEDURE Number(VAR sym: INTEGER); CONST max = 2147483647 (*2^31 - 1*); maxChar = 0FFFFH ; VAR i, k, e, n, s, h: INTEGER; x: REAL; d: ARRAY 16 OF INTEGER; negE: BOOLEAN; BEGIN ival := 0; i := 0; n := 0; k := 0; REPEAT IF n < 16 THEN d[n] := ORD(ch)-ORD("0"); INC(n) ELSE Mark("too many digits"); n := 0 END ; read UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*) REPEAT h := d[i]; (* ex . ORD("A")-ORD("0") = 65-48 = 17 -> 17-7 = 10 *) IF h >= 10 THEN h := h-7 END ; k := k*10H + h; INC(i) (*no overflow check*) UNTIL i = n; IF ch = "X" THEN sym := char; IF k <= maxChar THEN ival := k ELSE Mark("illegal value"); ival := 0 END ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k) ELSE sym := int; ival := k END ; read ELSIF ch = "." THEN read; IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*) REPEAT IF d[i] < 10 THEN IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END ELSE Mark("bad integer") END ; INC(i) UNTIL i = n; sym := int; ival := k ELSE (*real number*) x := 0.0; e := 0; REPEAT (*integer part*) x := x * 10.0 + FLT(d[i]); INC(i) UNTIL i = n; WHILE (ch >= "0") & (ch <= "9") DO (*fraction*) x := x * 10.0 + FLT(ORD(ch) - ORD("0")); DEC(e); read END ; IF (ch = "E") OR (ch = "D") THEN (*scale factor*) read; s := 0; IF ch = "-" THEN negE := TRUE; read ELSE negE := FALSE; IF ch = "+" THEN read END END ; IF (ch >= "0") & (ch <= "9") THEN REPEAT s := s*10 + ORD(ch)-ORD("0"); read UNTIL (ch < "0") OR (ch >"9"); IF negE THEN e := e-s ELSE e := e+s END ELSE Mark("digit?") END END ; IF e < 0 THEN IF e >= minExp THEN x := x / Ten(-e) ELSE x := 0.0 END ELSIF e > 0 THEN IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END END ; sym := real; rval := x END ELSE (*decimal integer*) REPEAT IF d[i] < 10 THEN IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END ELSE Mark("bad integer") END ; INC(i) UNTIL i = n; sym := int; ival := k END END Number; PROCEDURE comment; VAR level: INTEGER; BEGIN level := 1; read; WHILE ~EOF & (level > 0) DO IF ch = "(" THEN read; IF ch = "*" THEN INC(level); read END ELSIF ch = "*" THEN read; IF ch = ")" THEN DEC(level); read END ELSE read END END ; IF level # 0 THEN Mark("unterminated comment") END END comment; PROCEDURE Get*(VAR sym: INTEGER); BEGIN prevLine := line; prevCol := col; REPEAT WHILE ~EOF & ((ch <= " ") OR (ch > 7FX)) DO read END; IF EOF THEN sym := eot ELSE CASE ch OF (* " " < ch <= 7FX *) "!", "%", "'", "?", "@", "\", "_", "`": read; sym := null | 22X : String; sym := string | "#" : read; sym := neq | "$" : HexString; sym := string | "&" : read; sym := and | "(" : read; IF ch = "*" THEN sym := null; comment ELSE sym := lparen END | ")" : read; sym := rparen | "*" : read; sym := times | "+" : read; sym := plus | "," : read; sym := comma | "-" : read; sym := minus | "." : read; IF ch = "." THEN read; sym := upto ELSE sym := period END | "/" : read; sym := rdiv | "0".."9": Number(sym) | ":" : read; IF ch = "=" THEN read; sym := becomes ELSE sym := colon END | ";" : read; sym := semicolon | "<" : read; IF ch = "=" THEN read; sym := leq ELSE sym := lss END | "=" : read; sym := eql | ">" : read; IF ch = "=" THEN read; sym := geq ELSE sym := gtr END | "A".."Z": Identifier(sym) | "[" : read; sym := lbrak | "]" : read; sym := rbrak | "^" : read; sym := arrow | "a".."z": Identifier(sym) | "{" : read; sym := lbrace | "|" : read; sym := bar | "}" : read; sym := rbrace | "~" : read; sym := not | 7FX : read; sym := upto END END UNTIL sym # null END Get; PROCEDURE Init*(path: ARRAY OF CHAR); VAR f: Files.File; n, len: INTEGER; BEGIN pos := 0; line := 1; col := 0; EOF := FALSE; errpos := -1; errcnt := 0; Strings.Copy(path, inputPath); f := Files.Open(path); IF f = NIL THEN Mark("file not found") ELSE len := Files.Size(f); IF (len = -1) OR (len >= maxSrcSize) THEN Mark("file too big") ELSE Files.ReadBytes(f, src, n); srcSize := n; IF Files.Status(f) # Files.OK THEN Mark("error while reading the file") END ; read END ; Files.Close(f) END END Init; PROCEDURE InitStr*(s: ARRAY OF BYTE); BEGIN pos := 0; line := 1; col := 0; EOF := FALSE; errpos := -1; errcnt := 0; src := s; srcSize := LEN(s); read END InitStr; PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR); BEGIN keyTab[k].id := name; keyTab[k].sym := sym; INC(k) END EnterKW; BEGIN strx := 0; k := 0; KWX[0] := 0; KWX[1] := 0; EnterKW(if, "IF"); EnterKW(do, "DO"); EnterKW(of, "OF"); EnterKW(or, "OR"); EnterKW(to, "TO"); EnterKW(in, "IN"); EnterKW(is, "IS"); EnterKW(by, "BY"); KWX[2] := k; EnterKW(end, "END"); EnterKW(nil, "NIL"); EnterKW(var, "VAR"); EnterKW(div, "DIV"); EnterKW(mod, "MOD"); EnterKW(for, "FOR"); KWX[3] := k; EnterKW(else, "ELSE"); EnterKW(then, "THEN"); EnterKW(true, "TRUE"); EnterKW(type, "TYPE"); EnterKW(case, "CASE"); KWX[4] := k; EnterKW(elsif, "ELSIF"); EnterKW(false, "FALSE"); EnterKW(array, "ARRAY"); EnterKW(begin, "BEGIN"); EnterKW(const, "CONST"); EnterKW(until, "UNTIL"); EnterKW(while, "WHILE"); KWX[5] := k; EnterKW(record, "RECORD"); EnterKW(repeat, "REPEAT"); EnterKW(return, "RETURN"); EnterKW(import, "IMPORT"); EnterKW(module, "MODULE"); KWX[6] := k; EnterKW(pointer, "POINTER"); KWX[7] := k; KWX[8] := k; EnterKW(procedure, "PROCEDURE"); KWX[9] := k; EnterKW(definition, "DEFINITION"); KWX[10] := k END OJS. ================================================ FILE: src/Opcodes.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) MODULE Opcodes; CONST (* access flags *) ACCxPUBLIC* = 0001H; ACCxPRIVATE* = 0002H; ACCxSTATIC* = 0008H; ACCxFINAL* = 0010H; ACCxSUPER* = 0020H; ACCxABSTRACT* = 0400H; (* types for NEWARRAY *) TBOOLEAN* = 4; TCHAR* = 5; TFLOAT* = 6; TBYTE* = 8; TINT* = 10; (* opcodes *) ACONSTNULL* = 1; ICONSTM1* = 2; ICONST0* = 3; ICONST1* = 4; ICONST2* = 5; ICONST3* = 6; ICONST4* = 7; ICONST5* = 8; FCONST0* = 11; FCONST1* = 12; FCONST2* = 13; BIPUSH* = 16; SIPUSH* = 17; LDC* = 18; LDCW* = 19; ILOAD* = 21; FLOAD* = 23; ALOAD* = 25; IALOAD* = 46; FALOAD* = 48; AALOAD* = 50; BALOAD* = 51; CALOAD* = 52; ISTORE* = 54; FSTORE* = 56; ASTORE* = 58; IASTORE* = 79; FASTORE* = 81; AASTORE* = 83; BASTORE* = 84; CASTORE* = 85; POP* = 87; POP2* = 88; DUP* = 89; DUP2* = 92; SWAP* = 95; IADD* = 96; FADD* = 98; ISUB* = 100; FSUB* = 102; IMUL* = 104; FMUL* = 106; FDIV* = 110; INEG* = 116; FNEG* = 118; ISHL* = 120; ISHR* = 122; IAND* = 126; IOR* = 128; IXOR* = 130; IINC* = 132; I2F* = 134; F2D* = 141; D2I* = 142; FCMPL* = 149; FCMPG* = 150; IFEQ* = 153; IFNE* = 154; IFLT* = 155; IFGE* = 156; IFGT* = 157; IFLE* = 158; IFICMPEQ* = 159; IFICMPNE* = 160; IFICMPLT* = 161; IFICMPGE* = 162; IFICMPGT* = 163; IFICMPLE* = 164; IFACMPEQ* = 165; IFACMPNE* = 166; GOTO* = 167; TABLESWITCH* = 170; IRETURN* = 172; FRETURN* = 174; ARETURN* = 176; RETURNx* = 177; GETSTATIC* = 178; PUTSTATIC* = 179; GETFIELD* = 180; PUTFIELD* = 181; INVOKEVIRTUAL* = 182; INVOKESPECIAL* = 183; INVOKESTATIC* = 184; INVOKEINTERFACE* = 185; NEW* = 187; NEWARRAY* = 188; ANEWARRAY* = 189; ARRAYLENGTH* = 190; ATHROW* = 191; CHECKCAST* = 192; INSTANCEOF* = 193; MULTIANEWARRAY* = 197; IFNULL* = 198; IFNONNULL* = 199; GOTOW* = 200; END Opcodes. ================================================ FILE: src/Os.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) DEFINITION Os; PROCEDURE GetEnv(VAR out: ARRAY OF CHAR; name: ARRAY OF CHAR); (* Get time in seconds since 2010-01-01-UTC *) PROCEDURE CurrentTime(): INTEGER; (* Terminate the current program. The input "status" is the exit code returned to the OS. *) PROCEDURE Exit(status: INTEGER); END Os. ================================================ FILE: src/Out.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Simple procedures to print to standard output *) DEFINITION Out; PROCEDURE Char(ch: CHAR); PROCEDURE String(str: ARRAY OF CHAR); PROCEDURE Real(x: REAL; n: INTEGER); PROCEDURE Int(x, n: INTEGER); PROCEDURE Ln; PROCEDURE Hex(x: INTEGER); END Out. ================================================ FILE: src/Strings.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) (* Strings provides a set of operations on strings (i.e., on string constants and character arrays, both of which contain the character 0X as a terminator). All positions in strings start at 0. Strings.Length(s) returns the number of characters in s up to and excluding the first 0X. Strings.Insert(src, pos, dst) inserts the string src into the string dst at position pos (0 <= pos <= Length(dst)). If pos >= Length(dst), src is appended to dst. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X. Strings.Append(s, dst) has the same effect as Insert(s, Length(s), dst). Strings.AppendChar(c, dst) has the same effect as WriteChar(c, dst, Length(dst)) Strings.AppendInt(x, n, dst) has the same effect as WriteInt(x, n, dst, Length(dst)) Strings.Delete(s, pos, n) deletes n characters from s starting at position pos (0 <= pos < Length(s)). If n > Length(s) - pos, the new length of s is pos. Strings.Replace(src, pos, dst) has the same effect as Delete(dst, pos, Length(src)) followed by an Insert(src, pos, dst). Strings.Extract(src, pos, n, dst) extracts a substring dst with n characters from position pos (0 <= pos < Length(src)) in src. If n > Length(src) - pos, dst is only the part of src from pos to Length(src) - 1. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X. Strings.Pos(pat, s, pos) returns the position of the first occurrence of pat in s after position pos (inclusive). If pat is not found, -1 is returned. Strings.Cap(s) replaces each lower case letter in s by its upper case equivalent. Strings.Copy(s, dst) has the same effect as Insert(s, 0, dst). Strings.Write(s, dst, at) write the string s (and a final 0X) in dst at position at overwriting any existing characters. It returns the position of the terminal 0X. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X and the function returns -1. Strings.WriteChar(c, dst, at) write the character c in dst at position at, if the size of dst is large enough to hold c while keeping the terminal character 0X. It returns the position of terminal 0X or -1 if nothing was written. Strings.WriteInt(x, n, dst) write in dst at position at the string representation of x padded with blanks on the left up to a length of n. If n is too small no padding is applied. If the size of dst is too small to hold x and the padding, the function does not append any characters. It returns the position of terminal 0X or -1 if nothing was written. *) MODULE Strings; (*HM 94-06-22, LB 2017 *) PROCEDURE Length* (s: ARRAY OF CHAR): INTEGER; VAR i: INTEGER; BEGIN i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END; RETURN i END Length; PROCEDURE Write* (src: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR; at: INTEGER): INTEGER; VAR i, ldest, lsrc: INTEGER; BEGIN ldest := LEN(dest)-1; lsrc := LEN(src); IF (at >= 0) & (ldest > 0) & (lsrc > 0) & (at < ldest) THEN i := 0; WHILE (at < ldest) & (i < lsrc) & (src[i] # 0X) DO dest[at] := src[i]; INC(at); INC(i) END; dest[at] := 0X; IF (i < lsrc) & (src[i] # 0X) THEN at := -1 END ELSE at := -1 END RETURN at END Write; PROCEDURE Append* (extra: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR); VAR n1, n2, i: INTEGER; BEGIN n1 := Length(dest); n2 := Length(extra); i := 0; WHILE (i < n2) & (i + n1 < LEN(dest)) DO dest[i + n1] := extra[i]; INC(i) END; IF i + n1 < LEN(dest) THEN dest[i + n1] := 0X ELSIF LEN(dest) # 0 THEN dest[LEN(dest)-1] := 0X END END Append; PROCEDURE WriteChar* (c: CHAR; VAR dest: ARRAY OF CHAR; at: INTEGER): INTEGER; BEGIN IF (at >= 0) & (at+1 < LEN(dest)) THEN dest[at] := c; dest[at+1] := 0X; INC(at) ELSE at := -1 END RETURN at END WriteChar; PROCEDURE AppendChar* (c: CHAR; VAR dest: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := WriteChar(c, dest, Length(dest)) END AppendChar; PROCEDURE WriteInt* (x, n: INTEGER; VAR dest: ARRAY OF CHAR; at: INTEGER): INTEGER; VAR i, size, tot, neg: INTEGER; a: ARRAY 10 OF CHAR; BEGIN IF ROR(x, 31) = 1 THEN at := Write(" -2147483648", dest, at) ELSE i := 0; IF x < 0 THEN DEC(n); x := -x; neg := 1 ELSE neg := 0 END; REPEAT a[i] := CHR(x MOD 10 + 30H); x := x DIV 10; INC(i) UNTIL x = 0; size := LEN(dest); tot := at + i + neg; IF n >= i THEN tot := tot + (n - i) END; IF (at >= 0) & (tot < size) THEN WHILE n > i DO dest[at] := " "; DEC(n); INC(at) END; IF neg = 1 THEN dest[at] := "-"; INC(at) END; REPEAT DEC(i); dest[at] := a[i]; INC(at) UNTIL i = 0; dest[at] := 0X ELSE at := -1 END END RETURN at END WriteInt; PROCEDURE AppendInt* (x, n: INTEGER; VAR dest: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := WriteInt(x, n, dest, Length(dest)) END AppendInt; PROCEDURE Copy* (src: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR); VAR i, ldest, lsrc: INTEGER; BEGIN ldest := LEN(dest)-1; lsrc := LEN(src); IF (ldest > 0) & (lsrc > 0) THEN i := 0; WHILE (i < ldest) & (i < lsrc) & (src[i] # 0X) DO dest[i] := src[i]; INC(i) END; dest[i] := 0X END END Copy; PROCEDURE Insert* (source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR); VAR n1, n2, len, i, j: INTEGER; BEGIN n1 := Length(dest); n2 := Length(source); len := LEN(dest); IF pos < 0 THEN pos := 0 END; IF pos > n1 THEN Append(source, dest) ELSE (*--- make room for source*) IF pos + n2 < len THEN i := n1; j := i + n2; (*move also 0X if it is there*) WHILE i >= pos DO IF j < len THEN dest[j] := dest[i] END; DEC(i); DEC(j) END END; (*--- copy source to dest*) i := 0; j := pos; WHILE (i < n2) & (j < len) DO dest[j] := source[i]; INC(i); INC(j) END; IF (j >= len) & (LEN(dest) # 0) THEN dest[len-1] := 0X END END END Insert; PROCEDURE Delete* (VAR s: ARRAY OF CHAR; pos, n: INTEGER); VAR len, i: INTEGER; BEGIN len:=Length(s); IF pos < len THEN IF pos < 0 THEN pos:=0 END; IF pos + n < len THEN i:=pos + n; WHILE i < len DO s[i - n]:=s[i]; INC(i) END; IF i - n < LEN(s) THEN s[i - n]:=0X END ELSIF LEN(s) # 0 THEN s[pos]:=0X END END END Delete; PROCEDURE Replace* (source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR); BEGIN Delete(dest, pos, Length(source)); Insert(source, pos, dest) END Replace; PROCEDURE Extract* (source: ARRAY OF CHAR; pos, n: INTEGER; VAR dest: ARRAY OF CHAR); VAR len, destLen, i: INTEGER; BEGIN IF (LEN(dest) # 0) & (LEN(source) # 0) THEN len := Length(source); destLen := LEN(dest) - 1; IF pos < 0 THEN pos := 0 END; IF pos >= len THEN dest[0] := 0X ELSE i := 0; WHILE (pos + i <= LEN(source)) & (source[pos + i] # 0X) & (i < n) DO IF i < destLen THEN dest[i] := source[pos + i] END; INC(i) END; dest[i] := 0X END END END Extract; PROCEDURE Pos* (pattern, s: ARRAY OF CHAR; pos: INTEGER): INTEGER; VAR n1, n2, i, j, res: INTEGER; done: BOOLEAN; BEGIN n1 := Length(s); n2 := Length(pattern); IF n2 = 0 THEN res := 0 ELSE res := -1; done := FALSE; i := pos; WHILE ~done & (i <= n1 - n2) DO IF s[i] = pattern[0] THEN j := 1; WHILE (j < n2) & (s[i + j] = pattern[j]) DO INC(j) END; IF j = n2 THEN res := i; done := TRUE END END; INC(i) END; END RETURN res END Pos; PROCEDURE Cap* (VAR s: ARRAY OF CHAR); VAR i: INTEGER; BEGIN IF LEN(s) # 0 THEN i := 0; WHILE s[i] # 0X DO IF ("a" <= s[i]) & (s[i] <= "z") THEN s[i] := CHR(ORD(s[i]) - ORD("a") + ORD("A")) END; INC(i) END END END Cap; PROCEDURE Match* (string, pattern: ARRAY OF CHAR): BOOLEAN; PROCEDURE M (name, mask: ARRAY OF CHAR; n, m: INTEGER): BOOLEAN; VAR res: BOOLEAN; BEGIN res := TRUE; WHILE (n >= 0) & (m >= 0) & (mask[m] # "*") DO IF name[n] # mask[m] THEN res := FALSE; n := 0; END; DEC(n); DEC(m) END; IF res THEN res := FALSE; (* ----- name empty | mask empty | mask ends with "*" *) IF m < 0 THEN res := n < 0 ELSE (* ----- name empty | mask ends with "*" *) WHILE (m >= 0) & (mask[m] = "*") DO DEC(m) END; IF m < 0 THEN res := TRUE ELSE (* ----- name empty | mask still to be matched *) WHILE n >= 0 DO IF M(name, mask, n, m) THEN res := TRUE; n := 0 END; DEC(n) END END END END RETURN res END M; BEGIN RETURN M(string, pattern, Length(string)-1, Length(pattern)-1) END Match; END Strings. ================================================ FILE: src/java/Files.java ================================================ /* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ import java.io.FileNotFoundException; import java.io.IOException; import java.io.RandomAccessFile; import java.nio.file.Paths; import static java.nio.file.StandardCopyOption.REPLACE_EXISTING; public final class Files { public static final int OK = 0; public static final int EOF = -1; public static final int IOERROR = -2; public static final int UTF8ERROR = -3; public static final char[] SEPARATOR = java.io.File.separator.toCharArray(); // Ensure non-instantiability private Files() {} public static int Status(Files_FileDesc file) { return file.err; } public static int Rename(char[] from, char[] to) { int r = OK; try { java.nio.file.Files.move(Paths.get(toStr(from)), Paths.get(toStr(to)), REPLACE_EXISTING); } catch(IOException e) { r = IOERROR; } return r; } public static boolean Exists(char[] name) { boolean r; r = false; java.io.File f = new java.io.File(toStr(name)); if(f.exists() && !f.isDirectory()) { r = true; } return r; } public static int Delete(char[] name) { int r; r = OK; java.io.File f = new java.io.File(toStr(name)); try { if(!f.delete()) { r = IOERROR; } } catch(SecurityException e) { r = IOERROR; } return r; } public static Files_FileDesc Create(char[] name) { return open(name, "rw", true); } private static Files_FileDesc open(char[] name, String mode, boolean truncate) { Files_FileDesc file; file = new Files_FileDesc(); try { file.f = new RandomAccessFile(toStr(name), mode); if(truncate) { file.f.setLength(0); } file.err = OK; } catch(FileNotFoundException e) { file = null; } catch(IOException e) { file.err = IOERROR; } return file; } public static Files_FileDesc Open(char[] name) { return open(name, "r", false); } public static void Close(Files_FileDesc file) { try { file.f.close(); } catch(IOException e) { file.err = IOERROR; } } private static String toStr(char[] name) { int i, len; len = name.length; i = 0; if(len > 0) { while(i < len && name[i] != '\0') { i++; } } return new String(name, 0, i); } public static void WriteAsciiStr(Files_FileDesc file, char[] str) { int i; if(str.length > 0 && file.err == OK) { i = 0; while(i < str.length && str[i] != '\0' && file.err == OK) { Write(file, (byte) (str[i] & 0xFF)); i++; } Write(file, (byte) 0); } } public static void WriteStr(Files_FileDesc file, char[] str) { int i; if(str.length > 0 && file.err == OK) { i = 0; while(i < str.length && str[i] != '\0' && file.err == OK) { WriteChar(file, str[i]); i++; } Write(file, (byte) 0); } } public static void Write(Files_FileDesc file, byte b) { if(file.err == OK) { try { file.f.write(b); } catch(IOException e) { file.err = IOERROR; } } } public static void WriteChar(Files_FileDesc file, char c) { // 0x0000 <= c <= 0xFFFF if(file.err == OK) { if (c >= 0x0000 && c <= 0x007F) { // 1 bytes format: 0xxxxxxx Write(file, (byte) c); } else if(c >= 0x0800) { // 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx Write(file, (byte) (0xE0 | ((c >> 12) & 0x0F))); Write(file, (byte) (0x80 | ((c >> 6) & 0x3F))); Write(file, (byte) (0x80 | (c & 0x3F))); } else { // 2 bytes format: 110xxxxx 10xxxxxx Write(file, (byte) (0xC0 | ((c >> 6) & 0x1F))); Write(file, (byte) (0x80 | (c & 0x3F))); } } } public static void WriteBytes(Files_FileDesc file, byte[] b) { if(file.err == OK) { try { file.f.write(b); } catch(IOException e) { file.err = IOERROR; } } } public static void WriteNBytes(Files_FileDesc file, byte[] b, int len) { if(file.err == OK) { try { file.f.write(b, 0, len); } catch(IOException e) { file.err = IOERROR; } } } /* Little endian */ public static void WriteInt(Files_FileDesc file, int x) { if(file.err == OK) { Write(file, (byte) (x & 0xFF)); Write(file, (byte) ((x >> 8) & 0xFF)); Write(file, (byte) ((x >> 16) & 0xFF)); Write(file, (byte) ((x >> 24) & 0xFF)); } } /* LEB128 LEB128 ("Little-Endian Base 128") is a variable-length encoding for arbitrary signed or unsigned integer quantities. Each LEB128 encoded value consists of one to five bytes, which together represent a single 32-bit value. Each byte has its most significant bit set except for the final byte in the sequence, which has its most significant bit clear. The remaining seven bits of each byte are payload, with the least significant seven bits of the quantity in the first byte, the next seven in the second byte and so on. In the case of a signed LEB128, the most significant PAYLOAD bit of the final byte in the sequence is sign-extended to produce the final value. With 7 bits I can store numbers in this range: -2^6 <= x <= 2^6-1 -64 <= x <= 63 -64 <= x < 64 -0x40 <= x < 0x40 example: -908 = 11111111111111111111110001110100 in two's complement 1111 1111111 1111111 1111000 1110100 -> group of 7 bits write 8 bits -> 1 1110100 ^----------- always one so these bits represent an unsigned byte >= 128 shift -908 7 bits to the right -> 1111 1111111 1111111 1111000 = -8 -64 <= -8 < 64 , write it in 8 bits -> 01111000 */ public static void WriteNum(Files_FileDesc file, int x) { if(file.err == OK) { while((x < -0x40 || x >= 0x40) && file.err == OK) { Write(file, (byte) ((x & 0x7F) + 0x80)); x = x >> 7; } Write(file, (byte) (x & 0x7F)); } } /* example: read -999999999 = 11000100011001010011011000000001 = 1100 0100011 0010100 1101100 0000001 back from 10000001 11101100 10010100 10100011 01111100 1 0000001 ^----------- one so these bits represent an unsigned byte >= 128 remove the first one -> 1 0000001 - 0x80 = 00000001 = 0000 0000000 0000000 0000000 0000001 The number 0000001 represents the first least significant 7 bits group of the original number. The next byte read 11101100, encode the next 7 bits group (after removing the first one, like before), so we shift it by 7 and add it to the previous number: 1 1101100 >= 128 remove the first one -> 1 1101100 - 0x80 = 0 1101100 = 0000 0000000 0000000 0000000 1101100 shift to the left by 7 on a 32 bit range -> 00000000000000000011011000000000 and add it to the previous number: 00000000000000000011011000000000 + 00000000000000000000000000000001 = 00000000000000000011011000000001 = 0000 0000000 0000000 1101100 0000001 We keep doing the above for the next bytes with the MSB set to 1 resulting in the sum 0000 0100011 0010100 1101100 0000001. the last byte 01111100 = 124 < 128 0 1 111100 ^---------- sign of the original number ^----------- tag, always 0 for the last byte read. We separate the sign bit of the original number form the rest. Sign 0 1 111100 AND 0x40 = 0 1 111100 AND 0 1 000000 = 0 1 000000 The rest 0 1 111100 AND 0x3F = 0 1 111100 AND 0 0 111111 = 0 0 111100 We now can sign extend this last most significant 7 bits of the original number by subtracting 0 0 111100 with 0 1 000000: 0000 0000000 0000000 0000000 0 0 111100 - 0000 0000000 0000000 0000000 0 1 000000 = 1111 1111111 1111111 1111111 1 1 111100 Now we can do a final shift and sum it with 0000 0100011 0010100 1101100 0000001, to obtain the result 1111 1111111 1111111 1111111 1 1 111100 << 28 = 1100 0000000 0000000 0000000 0000000 0000 0100011 0010100 1101100 0000001 + 1100 0000000 0000000 0000000 0000000 = 1100 0100011 0010100 1101100 0000001 = -999999999 */ public static int ReadNum(Files_FileDesc file) { int n, y, b, x; x = 0; if(file.err == OK) { n = 0; y = 0; b = read(file); while(b >= 0x80) { y += ((b - 0x80) << n); n += 7; b = read(file); } b = (b & 0x3F) - (b & 0x40); x = y + (b << n); } return x; } public static byte Read(Files_FileDesc file) { byte b = 0; if(file.err == OK) { b = (byte) read(file); } return b; } public static char ReadChar(Files_FileDesc file) { int b1, b2, b3; char ch = '\0'; b1 = read(file); if (file.err == OK) { switch(b1 >> 4) { case 0: case 1: case 2: case 3: case 4: case 5: case 6: case 7: // 1 bytes format: 0xxxxxxx ch = (char) b1; break; case 12: case 13: // 2 bytes format: 110xxxxx 10xxxxxx b2 = read(file); if(file.err == OK && (b2 & 0xC0) != 0x80) { file.err = UTF8ERROR; } ch = (char) (((b1 & 0x1F) << 6) | (b2 & 0x3F)); break; case 14: // 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx b2 = read(file); b3 = read(file); if(file.err == OK && ((b2 & 0xC0) != 0x80 || (b3 & 0xC0) != 0x80)) { file.err = UTF8ERROR; } ch = (char) (((b1 & 0x0F) << 12) | ((b2 & 0x3F) << 6) | (b3 & 0x3F)); break; default: // ERROR + 4 bytes format: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx file.err = UTF8ERROR; ch = '\0'; } } return ch; } private static int read(Files_FileDesc file) { int x; x = 0; if(file.err == OK) { try { x = file.f.read(); if(x < 0) { file.err = EOF; } } catch(IOException e) { file.err = IOERROR; } } return x; } public static void ReadBytes(Files_FileDesc file, byte[] b, int[] n) { if(file.err == OK) { try { n[0] = file.f.read(b); if(n[0] < 0) { file.err = EOF; } } catch(IOException e) { file.err = IOERROR; } } } /* Little endian */ public static int ReadInt(Files_FileDesc file) { int x0, x1, x2, x3, x; x0 = read(file); x1 = read(file); x2 = read(file); x3 = read(file); x = (((((x3 << 8) + x2) << 8) + x1) << 8) + x0; return x; } public static void ReadAsciiStr(Files_FileDesc file, char[] str) { int i, ch, last; if(str.length > 0 && file.err == OK) { i = 0; last = str.length - 1; ch = read(file); while(i < last && ch != '\0' && file.err == OK) { str[i] = (char) ch; ch = read(file); i++; } str[i] = '\0'; } } public static int ReadStr(Files_FileDesc file, char[] str) { int i, last; char ch; i = 0; if(str.length > 0 && file.err == OK) { last = str.length - 1; ch = ReadChar(file); while(i < last && ch != '\0' && file.err == OK) { str[i] = ch; ch = ReadChar(file); i++; } str[i] = '\0'; } return i; } public static int Seek(Files_FileDesc file, int pos) { int r; r = OK; try { file.f.seek(pos); if(file.err == EOF) { file.err = OK; } } catch(IOException e) { r = IOERROR; } return r; } public static int Size(Files_FileDesc file) { int len; len = -1; if(file.err == OK) { try { len = (int) file.f.length(); } catch(IOException e) { file.err = IOERROR; } } return len; } } ================================================ FILE: src/java/Files_FileDesc.java ================================================ /* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ import java.io.RandomAccessFile; public class Files_FileDesc { public RandomAccessFile f; public int err; public Files_FileDesc() {} public Files_FileDesc copy() { Files_FileDesc x = new Files_FileDesc(); x.f = this.f; x.err = this.err; return x; } } ================================================ FILE: src/java/In.java ================================================ /* Copyright 2019 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ import java.util.Scanner; public final class In { static public boolean Done; static private Scanner scanner; // Ensure non-instantiability private In() {} static { Done = true; scanner = new Scanner(System.in, "UTF-8"); } static public void Char(char[] ch) { Done = true; try { int c = System.in.read(); if (c == -1) { Done = false; } else { ch[0] = (char) (c & 0xFF); } } catch(Exception e) { Done = false; } } static public void String(char[] str) { int i, ldest, lsrc; char[] line; Done = true; try { line = scanner.nextLine().toCharArray(); ldest = str.length - 1; lsrc = line.length; if(ldest > 0) { i = 0; while(i < ldest && i < lsrc && line[i] != '\0') { str[i] = line[i]; i++; } str[i] = '\0'; } } catch(Exception e) { Done = false; } } static public void Real(float[] x) { Done = true; try { x[0] = scanner.nextFloat(); } catch(Exception e) { Done = false; } } static public void Int(int[] i) { Done = true; try { i[0] = scanner.nextInt(); } catch(Exception e) { Done = false; } } } ================================================ FILE: src/java/Math.java ================================================ /* Copyright 2020 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ public final class Math { public static final float pi = 3.14159265358979323846f; public static final float e = 2.71828182845904523536f; // Ensure non-instantiability private Math() {} public static float sqrt(float x) { return (float) java.lang.Math.sqrt(x); } public static float power(float x, float base) { return (float) java.lang.Math.pow(base, x); } public static float exp(float x) { return (float) java.lang.Math.exp(x); } public static float ln(float x) { return (float) java.lang.Math.log(x); } public static float log(float x, float b) { return (float) (java.lang.Math.log(x) / java.lang.Math.log(b)); } public static float round(float x) { return (float) java.lang.Math.round(x); } public static float sin(float x) { return (float) java.lang.Math.sin(x); } public static float cos(float x) { return (float) java.lang.Math.cos(x); } public static float tan(float x) { return (float) java.lang.Math.tan(x); } public static float arcsin(float x) { return (float) java.lang.Math.asin(x); } public static float arccos(float x) { return (float) java.lang.Math.acos(x); } public static float arctan(float x) { return (float) java.lang.Math.atan(x); } public static float arctan2(float x, float y) { return (float) java.lang.Math.atan2(x, y); } public static float sinh(float x) { return (float) java.lang.Math.sinh(x); } public static float cosh(float x) { return (float) java.lang.Math.cosh(x); } public static float tanh(float x) { return (float) java.lang.Math.tanh(x); } public static float arcsinh(float x) { return (float) java.lang.Math.log(x + (float) java.lang.Math.sqrt(x * x + 1.0f)); } public static float arccosh(float x) { return (float) java.lang.Math.log(x + (float) java.lang.Math.sqrt(x * x - 1.0f)); } public static float arctanh(float x) { return (float) (0.5 * java.lang.Math.log((1.0f + x) / (1.0f - x))); } } ================================================ FILE: src/java/OberonRuntime.java ================================================ /* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ import java.io.IOException; import java.util.Locale; public final class OberonRuntime { // Ensure non-instantiability private OberonRuntime() {} /* Euclidean division (from "Division and Modulus for Computer Scientists") For any real numbers x and y with y # 0, there exists a unique pair of numbers q and r that satisfy the following conditions: - q is a signed integer - x = q*y + r - 0 <= r < |y| Euclidean division satisfies the following: 1. x DIV (-y) = - (x DIV y) 2. x MOD (-y) = x MOD y 3. x DIV 2^n = x ASR n (arithmetic/signed shift right) 4. x * 2^n = x LSL n (logical shift left) 5. x MOD 2^n = x and (2^n - 1) */ public static int DIV(int x, int y) { int q = x / y; int r = x % y; if (r < 0) { if (y > 0) { q = q - 1; } else { q = q + 1; } } return q; } public static int MOD(int x, int y) { int r = x % y; if (r < 0) { if (y > 0) { r = r + y; } else { r = r - y; } } return r; } public static int ASR(int x, int n) { return x >> n; } public static int ROR(int x, int n) { // see Integer.rotateRight() return (x >>> n) | (x << -n); } public static int StrCmp(char[] s0, char[] s1) { int cmp; int i = 0; int len = java.lang.Math.min(s0.length, s1.length); while(i < len && s0[i] == s1[i] && s0[i] != '\0') { i++; } if(i < len) { // this is safe, it will never overflow as cmp is an int (32 bits) and // s0, s1 are of type char (16 bits) cmp = s0[i] - s1[i]; } else { cmp = s0.length - s1.length; } return cmp; } public static void ARGS(String[] args, int i, char[] out) { int end; if(out.length > 0) { end = 0; if(i < args.length) { end = args[i].length(); if(end >= out.length) { end = out.length - 1; } System.arraycopy(args[i].toCharArray(), 0, out, 0, end); } out[end] = '\0'; } } public static int ReadInt() { int c; int num = 0; boolean neg = false; try { c = System.in.read(); if(c == '-') { neg = true; c = System.in.read(); } while(c != -1 && c != ' ' && c != '\n') { num = (num*10) + c - '0'; c = System.in.read(); } } catch(IOException e) { num = 0;} if(neg) { num = -num; } return num; } public static void WriteInt(int num) { if(num <= 999 && num >= -99) { System.out.printf(Locale.US, "%4d", num); } else { System.out.printf(Locale.US, " %d", num); } } public static void WriteReal(float num) { System.out.printf(Locale.US, " %f", num); } public static void WriteChar(int c) { System.out.print((char)c); } public static void WriteLn() { System.out.print('\n'); } public static boolean eot() { int available = 0; try { available = System.in.available(); } catch(IOException e) { } return available == 0; } } ================================================ FILE: src/java/Os.java ================================================ /* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ public final class Os { private static long date2010x01x01xUTC = 1262304000000L; // Ensure non-instantiability private Os() {} private static String toString(char[] name) { int i; i = 0; while(i < name.length && name[i] != '\0') { i++; } return new String(name, 0, i); } public static void GetEnv(char[] out, char[] name) { int i; if(out.length > 0 && name.length > 0) { try { String s = System.getenv(toString(name)); i = 0; if(s != null) { i = java.lang.Math.min(s.length(), out.length-1); System.arraycopy(s.toCharArray(), 0, out, 0, i); } out[i] = '\0'; } catch(Exception e) { out[0] = '\0'; } } } public static int CurrentTime() { return (int) ((System.currentTimeMillis() - date2010x01x01xUTC) / 1000); } public static void Exit(int status) { System.exit(status); } } ================================================ FILE: src/java/Out.java ================================================ /* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. */ import java.io.PrintStream; import java.io.UnsupportedEncodingException; public final class Out { // Ensure non-instantiability private Out() {} static { try { System.setOut(new PrintStream(System.out, true, "UTF-8")); System.setErr(new PrintStream(System.err, true, "UTF-8")); } catch(UnsupportedEncodingException e) { // keep defaults } } public static void Char(char ch) { System.out.print(ch); } public static void String(char[] str) { int i = 0; int len = str.length; while(i < len && str[i] != '\0') { i++; } System.out.print(new String(str, 0, i)); } public static void Real(float x, int n) { if(n <= 0) { System.out.print(x); } else { System.out.printf("%" + n + "f", x); } } public static void Int(int x, int n) { if(n <= 0) { System.out.print(x); } else { System.out.printf("%" + n + "d", x); } } public static void Ln() { System.out.print('\n'); } public static void Hex(int x) { System.out.printf("%08X", x); } } ================================================ FILE: src/oberonc.Mod ================================================ (* Copyright 2017 Luca Boasso. Use of this source code is governed by a MIT license that can be found in the LICENSE file. *) MODULE oberonc; IMPORT OJS, OJP, Out, Os, Strings; PROCEDURE Help; BEGIN Out.String("Oberon-07 compiler v1.X"); Out.Ln; Out.Ln; Out.String("Usage: oberonc outputFolder sourceFile1.Mod[+] sourceFile2.Mod[+] ..."); Out.Ln; Out.Ln; Out.String("It compiles the list of provided source module files and places the generated"); Out.Ln; Out.String("classes in the existing 'outputFolder'."); Out.Ln; Out.String("The optional suffix '+' allows the compiler to create a new symbol file. If this"); Out.Ln; Out.String("option is not specified, a change in the interface of the module results in a"); Out.Ln; Out.String("compilation error."); Out.Ln; END Help; PROCEDURE Main; VAR i, len, n, ret: INTEGER; folder, arg: ARRAY OJS.maxPath OF CHAR; newSym: BOOLEAN; BEGIN ret := 0; n := ARGNUM(); IF n < 2 THEN Help ELSE ARGS(0, folder); FOR i := 1 TO n-1 DO ARGS(i, arg); len := Strings.Length(arg); IF arg[len-1] = "+" THEN newSym := TRUE; arg[len-1] := 0X ELSE newSym := FALSE END ; OJP.Compile(arg, newSym, folder); IF OJS.errcnt > 0 THEN ret := 1 END END END ; Os.Exit(ret) END Main; END oberonc. ================================================ FILE: tests/TestRunner.java ================================================ import java.io.ByteArrayInputStream; import java.io.ByteArrayOutputStream; import java.io.File; import java.io.InputStream; import java.io.PrintStream; import java.lang.reflect.Method; public class TestRunner { private static final String suitePath = "tests/base/"; private static final String outFolder = "tests/out/"; public static void main(String[] args) { int[] tot = new int[1]; int[] successful = new int[1]; int[] failed = new int[1]; String[] tests = { "VarInit", "DivMul", "ProcVariables0", "ProcVariables1", "ProcVariables2", "ProcVariables3", "ProcVariables4", "ProcVariables5", "ProcVariables6", "RecordAndTypeExtension", "ProcComparisons", "FragileBaseClass", "Strings0", "Strings1", "Strings2", "OpenArrays2", "OpenArrays3", "TestABS", "TestCPS", "TestODD", "TestOOP", "SetTest", "Out0", "UTF8String", "TestAnonymousName", "RecordAssignment", "TestShift", "TestByteType", "TestINC0", "TestINC1", "Arrays2", "Arrays3", "TestFor", "Out3", "EmptyArrayAndRecord", "ArrayAssignment", "OpenArrays", "TestAssignmentMix", "TestEqualSignature00", "BitFunc", "Out4", "ProcType", "ConstantFoldingAndLoadOp", "CommutativeSwap", "Out5", "TestFunction0", "RealExpressions", "Pattern2a", "Pattern2b", "Pattern2c", "Out2", "TestReturn0", "CaseNum0", "CaseNum1", "TestINCLAndEXCL", "CaseRecord0", "CaseRecord1", "CaseRecord2", "TestTypeConvFun", "TestFor1", "Out1", "TestAssert", "CaseChar0", "Out6", "TestSystemVal", "TestNestedProcs", "Pattern1", "TestStringsMod", "OutTest", "ProcVariables7", "RecordAssignment2", "RecordParam", "CaseRecord3", "VarParGuard", "TestTypeTest", "TestConstFunc", "TestMath", "CaseRecord4", "UniqueTypeAndProcNames", "ForwardPointerRef" }; successful[0] = 0; failed[0] = 0; tot[0] = 0; for(String test : tests) { check(tot, successful, failed, compileAndRun(test)); } check(tot, successful, failed, compileAndRunArgs("TestCmdLineArgs", "", new String[] {"Hello", "World!"})); testImports(tot, successful, failed); testCyclicImports(tot, successful, failed); testWithInputs(tot, successful, failed); testTypeGuardExt(tot, successful, failed); check(tot, successful, failed, compileAndFail("TestReadOnlyPar", 3, "read only")); check(tot, successful, failed, compileAndFail("ArrayConstantSize", 2, "not a valid length")); check(tot, successful, failed, compileAndFail("TestExprVarPar", 2, "Only variables allowed")); System.err.println("TOTAL: " + tot[0]); System.err.println("SUCCESSFUL: " + successful[0]); System.err.println("FAILED: " + failed[0]); } private static void check(int[] tot, int[] successful, int[] failed, boolean res) { if(res) { successful[0]++; } else { failed[0]++; } tot[0]++; } private static void testImports(int[] tot, int[] successful, int[] failed) { boolean res, res0, res1; int i; // the compilation order matters String[][] suite = { {"TestImport00", "TestImport01"}, {"TestImport10", "TestImport11"}, {"TestImport20", "TestImport21", "TestImport22"}, {"TestImport30", "TestImport31"}, {"TestImport40", "TestImport41", "TestImport42"}, {"TestImport50", "TestImport51", "TestImport52", "TestImport53"}, {"TestImport60", "TestImport61", "TestImport62"}, {"TestImport70", "TestImport71"}, {"TestImport81", "TestImport82", "TestImport80"}, {"TestImport90", "TestImport91"}, {"TestImport100"}, {"TestImport120", "TestImport121", "TestImport122"}, {"TestImport130", "TestImport131"}, {"TestImport140", "TestImport141", "TestImport142"}, {"TestImport150", "TestImport151"}, }; for(String[] test : suite) { res = true; for(i = 0; i < test.length && res; i++) { res = compileAndRun(test[i]); } check(tot, successful, failed, res); } res0 = compileAndRun("TestImport110"); res1 = compile("TestImport111", false) == 0; res = compileAndRun("TestImport112"); check(tot, successful, failed, res0 && res1 && res); } private static void testCyclicImports(int[] tot, int[] successful, int[] failed) { check(tot, successful, failed, compile("TestCyclicImport00A", true) == 0 && compile("TestCyclicImport01A", true) == 0 && compileAndFail("TestCyclicImport00B", 2, "recursive import")); check(tot, successful, failed, compile("TestCyclicImport00A", true) == 0 && compile("TestCyclicImport01B", true) == 0 && compileAndFail("TestCyclicImport00B", 2, "recursive import")); check(tot, successful, failed, compile("TestCyclicImport10A", true) == 0 && compile("TestCyclicImport12", true) == 0 && compile("TestCyclicImport11", true) == 0 && compileAndFail("TestCyclicImport10B", 2, "recursive import")); } private static void testWithInputs(int[] tot, int[] successful, int[] failed) { int i; String[] tests = { "Samples0", "Samples1", "Samples2", "MagicSquares", "PrimeNumbers", "Fractions", "Permutations", "Powers" }; String[] inputs = { "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", "32\n" }; for(i = 0; i < tests.length; i++) { check(tot, successful, failed, compileAndRunWithInput(tests[i], inputs[i])); } } private static void testTypeGuardExt(int[] tot, int[] successful, int[] failed) { check(tot, successful, failed, compile("ExtTypes", true) == 0 && compileAndRun("TestTypeGuardExt")); } private static boolean assertEquals(String name, String expected, String actual) { boolean res = expected.equals(actual); if(!res) { System.err.println("Test '" + suitePath + name + ".Mod" + "' FAILED:"); System.err.println("EXPECTING:\n" + "'" + expected + "'"); System.err.println("FOUND:\n" + "'" + actual + "'"); System.err.println("---END---\n"); } return res; } private static boolean compileAndRunArgs(String name, String input, String[] argv) { boolean res; InputStream org_in = System.in; PrintStream org_out = System.out; try { ByteArrayOutputStream out = new ByteArrayOutputStream(); PrintStream ps = new PrintStream(out); InputStream in = new ByteArrayInputStream(input.getBytes()); System.setIn(in); System.setOut(ps); if(compile(name, false) != 0) { System.err.println("Compilation of " + suitePath + name + ".Mod" + " FAILED:"); System.err.println(out.toString()); System.err.println("---END---\n"); res = false; } else { ClassLoader classLoader = TestRunner.class.getClassLoader(); Class aClass = classLoader.loadClass(name); Method main = aClass.getMethod("main", String[].class); main.invoke(null, (Object) argv); res = assertEquals(name, getExpectedOutput(name), out.toString()); } } catch (Exception e) { System.err.println("EXCEPTION thrown while executing " + suitePath + name + ".Mod:"); e.printStackTrace(); System.err.println("---END---\n"); res = false; } System.setIn(org_in); System.setOut(org_out); return res; } private static int compile(String name, boolean newSym) { OJP.Compile((suitePath + name + ".Mod\0").toCharArray(), newSym, outFolder.toCharArray()); return OJS.errcnt; } private static boolean compileAndRunWithInput(String name, String input) { return compileAndRunArgs(name, input, null); } private static boolean compileAndRun(String name) { return compileAndRunArgs(name, "", null); } private static boolean compileAndFail(String name, int errors, String msg) { boolean res; int errcnt; ByteArrayOutputStream out = new ByteArrayOutputStream(); PrintStream ps = new PrintStream(out); System.setOut(ps); errcnt = compile(name, false); if(errcnt != errors) { System.err.println("Test '" + name + "' FAILED:"); System.err.println("EXPECTING: " + errors + " compilation error[s]"); System.err.println("FOUND: " + errcnt); System.err.println("---END---\n"); res = false; } else { res = out.toString().contains(msg); if(!res) { System.err.println("Test '" + name + "' FAILED:"); System.err.println("EXPECTED ERROR: " + msg); System.err.println("NOT FOUND IN: " + out.toString()); System.err.println("---END---\n"); } } return res; } private static String getExpectedOutput(String name) { char[] expected = new char[2000]; String res; Files_FileDesc f = Files.Open((suitePath + name + ".txt\0").toCharArray()); if(f == null) { System.err.println("ERROR: cannot open " + suitePath + name + ".txt"); res = ""; } else { Files.ReadStr(f, expected); Files.Close(f); res = new String(expected, 0, Strings.Length(expected)); } return res; } } ================================================ FILE: tests/base/ArrayAssignment.Mod ================================================ MODULE ArrayAssignment; TYPE arr2 = ARRAY 2 OF INTEGER; multy = ARRAY 2, 4 OF INTEGER; R = RECORD x : arr2; y : ARRAY 2, 2 OF INTEGER END; VAR a : arr2; m : multy; b : ARRAY 2 OF INTEGER; d0, d1 : ARRAY 2 OF R; e0, e1 : ARRAY 2, 9 OF R; PROCEDURE localAssignment(VAR c2 : arr2; VAR z2 : multy); VAR a2 : arr2; m2 : multy; b2 : ARRAY 2 OF INTEGER; d2, d3 : ARRAY 2 OF R; e2, e3 : ARRAY 2, 9 OF R; BEGIN b2[0] := 5; a2 := b2; WriteInt(a2[0]); (* 5 *) a2[0] := 6; WriteInt(b2[0]); (* 5 *) a2 := c2; WriteInt(a2[0]); (* 7 *) a2[0] := 6; WriteInt(c2[0]); (* 7 *) c2 := a2; a2[0] := 8; WriteInt(c2[0]); (* 6 *) WriteInt(a2[0]); (* 8 *) d2[1].x := b2; WriteInt(d2[1].x[0]); (* 5 *) d2[1].x[0] := 10; WriteInt(b2[0]); (* 5 *) a2 := d2[1].x; WriteInt(a2[0]); (* 10 *) d2[0].y[1][0] := 11; d2[0].y[0] := d2[0].y[1]; WriteInt(d2[0].y[0][0]); (* 11 *) d2[0].y[0][0] := 12; WriteInt(d2[0].y[1][0]); (* 11 *) WriteInt(d2[0].y[0][0]); (* 12 *) d3[0].x[1] := 15; d2 := d3; WriteInt(d2[0].x[1]); (* 15 *) d2[0].x[1] := 16; WriteInt(d3[0].x[1]); (* 15 *) WriteInt(d2[0].x[1]); (* 16 *) e3[0][8].x[1] := 25; e2 := e3; WriteInt(e2[0][8].x[1]); (* 25 *) e2[0][8].x[1] := 26; WriteInt(e3[0][8].x[1]); (* 25 *) WriteInt(e2[0][8].x[1]); (* 26 *) m2 := z2; WriteInt(m2[0][1]); (* 77 *) m2[0][1] := 66; WriteInt(z2[0][1]); (* 77 *) z2 := m2; m2[0][1] := 88; WriteInt(z2[0][1]); (* 66 *) WriteInt(m2[0][1]); (* 88 *) END localAssignment; BEGIN a[0] := 7; m[0][1] := 77; localAssignment(a, m); a := b; d0[1].x := b; a := d0[1].x; d0[0].y[0] := d0[0].y[1]; d0 := d1; e0[0][1].x := b; a := e0[0][1].x; e0[0][0].y[0] := e0[0][0].y[1]; e0[0][0].y := e0[0][0].y; e0[0][0].y := e1[0][0].y; e0 := e1; END ArrayAssignment. ================================================ FILE: tests/base/ArrayAssignment.txt ================================================ 5 5 7 7 6 8 5 5 10 11 11 12 15 15 16 25 25 26 77 77 66 88 ================================================ FILE: tests/base/ArrayConstantSize.Mod ================================================ MODULE ArrayConstantSize; VAR N: INTEGER; e: ARRAY 2*N OF CHAR; END ArrayConstantSize. ================================================ FILE: tests/base/Arrays2.Mod ================================================ MODULE Arrays2; TYPE X = ARRAY 1 OF INTEGER; VAR a : X; b : ARRAY 1 OF INTEGER; (*i : ARRAY 3, 2 OF INTEGER; j : ARRAY 2, 4 OF INTEGER;*) i0 : ARRAY 4, 3, 2 OF INTEGER; j0 : ARRAY 4, 3, 2 OF INTEGER; PROCEDURE P(s : X); BEGIN WriteInt(s[0] + 1); (* 3 *) END P; BEGIN a[0] := 1; b[0] := 2; a := b; WriteInt(a[0]); (* 2 *) (*i := j; illegal assignment *) i0[1, 1, 1] := 8; j0[1][1][1] := 9; WriteInt(i0[1, 1, 1]); (* 8 *); i0 := j0; WriteInt(i0[1, 1, 1]); (* 9 *); P(a); P(b); END Arrays2. ================================================ FILE: tests/base/Arrays2.txt ================================================ 2 8 9 3 3 ================================================ FILE: tests/base/Arrays3.Mod ================================================ MODULE Arrays3; TYPE ARR = ARRAY 3 OF INTEGER; ARR2 = ARRAY 3, 2 OF INTEGER; VAR x : ARRAY 3 OF INTEGER; y : ARR; i : ARRAY 3, 2 OF INTEGER; k0, m0 : ARRAY 0 OF INTEGER; k1, m1 : ARRAY 3, 0 OF INTEGER; PROCEDURE P1(VAR b, c : ARRAY OF INTEGER; d : ARRAY OF INTEGER); VAR y2 : ARR; (*y3 : ARRAY 0 OF INTEGER; y4 : ARRAY 1 OF INTEGER;*) BEGIN (* b := c; illegal assignment *) (* b := d; illegal assignment *) y2[1] := 0; y2 := b; WriteInt(y2[1]); (*88*) (* y3 := b; illegal assignment *) (*y4:= b; trap *) END P1; PROCEDURE P4(b : ARRAY OF ARRAY OF INTEGER); VAR k : INTEGER; BEGIN k := b[0][1]; WriteInt(k) (*8*) END P4; PROCEDURE P3(VAR b : ARRAY OF ARRAY OF INTEGER); BEGIN b[0][1] := 8 END P3; PROCEDURE P5(VAR b : ARR2); VAR c : ARRAY 3, 2 OF INTEGER; BEGIN c[0][1] := 9; b := c END P5; BEGIN y[1] := 88; P1(y, y, y); x[1] := 1; y[1] := 99; y := x; WriteInt(y[1]); (*1*) i[0][1] := 0; P3(i); WriteInt(i[0][1]); (*8*) P4(i); P5(i); WriteInt(i[0][1]); (*9*) k0 := m0; k1 := m1; END Arrays3. ================================================ FILE: tests/base/Arrays3.txt ================================================ 88 1 8 8 9 ================================================ FILE: tests/base/BitFunc.Mod ================================================ MODULE BitFunc; VAR x: ARRAY 18 OF BYTE; i: INTEGER; ch: CHAR; PROCEDURE next(in: ARRAY OF BYTE; VAR i: INTEGER): CHAR; VAR x, size, b1, b2, b3: INTEGER; ch: CHAR; BEGIN ch := 0X; size := LEN(in); IF i < size THEN b1 := in[i]; x := ASR(b1, 4); CASE x OF 0..7: (* 1 bytes format: 0xxxxxxx *) ch := CHR(b1); INC(i) | 12,13: (* 2 bytes format: 110xxxxx 10xxxxxx *) IF i+1 < size THEN INC(i); b2 := in[i]; IF AND(b2, 0C0H) = 80H THEN ch := CHR(BOR(LSL(AND(b1, 1FH), 6), AND(b2, 3FH))) END; INC(i) END | 14: (* 3 bytes format: 1110xxxx 10xxxxxx 10xxxxxx *) IF i+2 < size THEN INC(i); b2 := in[i]; INC(i); b3 := in[i]; IF (AND(b2, 0C0H) = 80H) & (AND(b3, 0C0H) = 80H) THEN ch := CHR(BOR(LSL(AND(b1, 0FH), 12), BOR(LSL(AND(b2, 3FH), 6), AND(b3, 3FH)))); END; INC(i) END | 8..11, 15: (* ERROR + 4 bytes format: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx *) ch := 0X END END RETURN ch END next; BEGIN x[0] := 041H; x[1] := 0D0H; x[2] := 094H; x[3] := 0D0H; x[4] := 0B0H; x[5] := 0E2H; x[6] := 082H; x[7] := 0ACH; x[8] := 0E4H; x[9] := 0B8H; x[10] := 096H; x[11] := 0E7H; x[12] := 095H; x[13] := 08CH; x[14] := 0F0H; x[15] := 000H; x[16] := 000H; x[17] := 000H; i := NOT(-1); (* 0 *) ch := next(x, i); WHILE ch # 0X DO WriteChar(ch); WriteInt(ORD(ch)); WriteLn; ch := next(x, i) END END BitFunc. ================================================ FILE: tests/base/BitFunc.txt ================================================ A 65 Д 1044 а 1072 € 8364 世 19990 界 30028 ================================================ FILE: tests/base/CaseChar0.Mod ================================================ MODULE CaseChar0; CONST C = "C"; VAR i, a : CHAR; BEGIN i := "B"; CASE i OF "A".."C", "Z": a := "1"; | "I".. "K": a := "2"; | "W": a := "3"; END; WriteChar(a); (* 1 *) CASE C OF 22X: i := "4"; | "A".."C", "Z": i := "5"; END; WriteChar(i) (* 5 *) END CaseChar0. ================================================ FILE: tests/base/CaseChar0.txt ================================================ 15 ================================================ FILE: tests/base/CaseNum0.Mod ================================================ MODULE CaseNum0; VAR i, a : INTEGER; PROCEDURE P(i : INTEGER); VAR a : INTEGER; BEGIN CASE i OF 8..10, 14: a := 1; |2..4, 15..20, 25: a := 2; |5..6: a := 3; END; WriteInt(a) END P; PROCEDURE P1; VAR i: INTEGER; BEGIN i := 8; CASE i OF 0..255: WriteInt(8) END; i := 0; CASE i OF -255..0: WriteInt(9) END END P1; PROCEDURE P2; VAR i: INTEGER; BEGIN i := -1; CASE i OF -1: WriteInt(-1) | 0: WriteInt(0) | +1: WriteInt(1) END END P2; BEGIN i := 2; CASE i OF 8..10, 14: a := 1; |2..4, 15..20, 25: a := 2; |5..6: a := 3; END; WriteInt(a); (* 2 *) P(9); (* 1 *) P(4); (* 2 *) P(6); (* 3 *) P2; (* -1 *) P1 (* 8 9 *) END CaseNum0. ================================================ FILE: tests/base/CaseNum0.txt ================================================ 2 1 2 3 -1 8 9 ================================================ FILE: tests/base/CaseNum1.Mod ================================================ MODULE CaseNum1; TYPE ARR = ARRAY 3 OF RECORD c: CHAR END; VAR b: ARR; PROCEDURE P(i: INTEGER); VAR a: INTEGER; BEGIN CASE i OF 8..10, 14: a := 1; |2..4, 15..20, 25: CASE i OF 3, 15..19: a := 2; |25: a := 3; END; |5..6: a := 4; END; WriteInt(a) END P; PROCEDURE NoLocals(i: INTEGER); BEGIN CASE i OF 5: WriteInt(i) END END NoLocals; PROCEDURE P2(i: ARR); BEGIN CASE i[2].c OF "P": WriteInt(ORD(i[2].c)) END END P2; PROCEDURE P3(i: ARR); BEGIN CASE ORD(i[2].c) OF 80: WriteChar(i[2].c) END END P3; BEGIN P(9); (* 1 *) P(18); (* 2 *) P(25); (* 3 *) P(6); (* 4 *) NoLocals(5); (* 5 *) b[2].c := "P"; P2(b); (* 80 *) P3(b) (* "P" *) END CaseNum1. ================================================ FILE: tests/base/CaseNum1.txt ================================================ 1 2 3 4 5 80P ================================================ FILE: tests/base/CaseRecord0.Mod ================================================ MODULE CaseRecord0; TYPE R = RECORD a: INTEGER END ; R0 = RECORD (R) b: REAL END ; R1 = RECORD (R) b: INTEGER END ; R2 = RECORD (R) b: SET END ; P = POINTER TO R; P0 = POINTER TO R0; P1 = POINTER TO R1; P2 = POINTER TO R2; VAR p, old: P; p1 : P1; i : INTEGER; PROCEDURE VarPar(VAR p: P); VAR i : INTEGER; BEGIN CASE p OF P0: p.b := 2.5; i := 0 | P1: p.b := 8; i:= 8 | P2: p.b := {0, 2}; i:= 2 END; WriteInt(i); (* 8 *) NEW(p); p.a := 9 END VarPar; BEGIN NEW(p1); p := p1; p.a := 1; CASE p OF P0: p.b := 2.5; i := 0 | P1: p.b := p.a + p.b + p.b DIV 3; i:= p.a | P2: p.b := {0, 2}; i:= 2 END; WriteInt(i); (* 1 *) old := p; VarPar(p); WriteInt(p.a); (* 9 *) IF old # p THEN WriteInt(10) END END CaseRecord0. ================================================ FILE: tests/base/CaseRecord0.txt ================================================ 1 8 9 10 ================================================ FILE: tests/base/CaseRecord1.Mod ================================================ MODULE CaseRecord1; TYPE R = RECORD a: INTEGER END ; R0 = RECORD (R) b: INTEGER END ; R1 = RECORD (R) b: REAL END ; R2 = RECORD (R) b: SET END ; VAR r1: R1; r : R; i : INTEGER; PROCEDURE P(VAR r : R); BEGIN CASE r OF R0: r.b := 10; i := 0 | R1: r.b := 2.5; i:= 1 | R2: r.b := {0, 2}; i:= 2 END; WriteInt(i) END P; BEGIN P(r1); i := -1; P(r) END CaseRecord1. ================================================ FILE: tests/base/CaseRecord1.txt ================================================ 1 -1 ================================================ FILE: tests/base/CaseRecord2.Mod ================================================ MODULE CaseRecord2; TYPE P = POINTER TO R; P0 = POINTER TO R0; P1 = POINTER TO R1; P2 = POINTER TO R2; R = RECORD a: INTEGER; next : P END ; R0 = RECORD (R) b: INTEGER; c : ARRAY 11 OF INTEGER END ; R1 = RECORD (R) b: REAL END ; R2 = RECORD (R) b: SET END ; VAR p: P; p0 : P0; p1 : P1; p2 : P2; i : INTEGER; PROCEDURE Run(p : P); VAR tmp : P; BEGIN CASE p OF P0: p.b := 10; p.c[p.b] := p.b; i := 0; tmp := p.next; CASE tmp OF P2: tmp.b := {3}; i := 1 END; | P1: p.b := 2.5; i:= 2; CASE p OF P1: p.b := 3.0; i := 3 END; | P2: p.b := {0, 2}; i:= 4 END; WriteInt(i) END Run; BEGIN NEW(p1); p := p1; Run(p); NEW(p0); NEW(p2); p := p0; p.next := p2; Run(p); END CaseRecord2. ================================================ FILE: tests/base/CaseRecord2.txt ================================================ 3 1 ================================================ FILE: tests/base/CaseRecord3.Mod ================================================ MODULE CaseRecord3; TYPE P = POINTER TO R; P0 = POINTER TO R0; P1 = POINTER TO R1; P2 = POINTER TO R2; R = RECORD a: INTEGER END ; R0 = RECORD (R) b: REAL; y: P0 END ; R1 = RECORD (R0) c: INTEGER END ; R2 = RECORD (R1) d: REAL; z: ARRAY 10 OF P1 END ; VAR p: P; p2 : P2; i : INTEGER; BEGIN NEW(p2); NEW(p2.z[2]); NEW(p2.z[3]); p2.d := 2.0; p2.c := 6; p2.z[2].b := 3.0; p2.a := 1; p2.z[3].c := 8; p2.y := p2.z[3]; p := p2; CASE p OF P0: p.b := 1.5 + p(P2).d + p(P2).z[2].b + FLT(p.a) + FLT(p.y(P1).c) + FLT(p(P1).c DIV 3); WriteInt(FLOOR(p.b)); (* 17 *) i:= p.a | P2: p.b := 1.8; i:= 2 END; WriteInt(i) (* 1 *) END CaseRecord3. ================================================ FILE: tests/base/CaseRecord3.txt ================================================ 17 1 ================================================ FILE: tests/base/CaseRecord4.Mod ================================================ MODULE CaseRecord4; TYPE A = POINTER TO ADesc; ADesc = RECORD next: A END; B = POINTER TO RECORD(ADesc) value: INTEGER END; VAR x: B; fn: PROCEDURE(z: A); PROCEDURE CaseGuardOnParam(a: A); BEGIN IF a # NIL THEN CASE a OF B: WriteChar("B"); WriteLn; (* BUG-FIX: here 'a' has type B thanks to the implicit type guard: so 'a.next' is equivalent to 'a(B).next'. The 'next' field has type A and the formal parameter 'a' must be treated as of type A while we type check the function call to CaseGuardOnParam *) CaseGuardOnParam(a.next); (* BUG-FIX: In the signature of CaseGuardOnParam, 'a' must have type A, regardless of implicit type guards. Only when 'a' appears in expressions we can assume it has type 'B' *) fn := CaseGuardOnParam END END END CaseGuardOnParam; BEGIN NEW(x); x.next := NIL; CaseGuardOnParam(x) END CaseRecord4. ================================================ FILE: tests/base/CaseRecord4.txt ================================================ B ================================================ FILE: tests/base/CommutativeSwap.Mod ================================================ MODULE CommutativeSwap; VAR i : INTEGER; a : ARRAY 10 OF INTEGER; BEGIN i := 5; a[i+3] := 5; WriteInt(1 - i + 3 * i); (* 11 *) WriteInt(2 - a[i+3]); (* -3 *) END CommutativeSwap. ================================================ FILE: tests/base/CommutativeSwap.txt ================================================ 11 -3 ================================================ FILE: tests/base/ConstantFoldingAndLoadOp.Mod ================================================ MODULE ConstantFoldingAndLoadOp; CONST con = 100; TYPE V = RECORD x : ARRAY 10 OF INTEGER; END; VAR i,j : INTEGER; c : ARRAY 2 OF INTEGER; d : V; e : ARRAY 2 OF BOOLEAN; b : BOOLEAN; PROCEDURE PrintBool(x : BOOLEAN); BEGIN IF x THEN WriteInt(1) ELSE WriteInt(0) END; END PrintBool; BEGIN j := 2; c[0] := 3; d.x[0] := 4; e[0] := TRUE; i := 2 * 3 + 10 DIV 2; WriteInt(i); i := 2*c[0]; WriteInt(i); i := 2*d.x[0]; WriteInt(i); i := 2*con; WriteInt(i); i := j*c[0]; WriteInt(i); i := j*d.x[0]; WriteInt(i); i := j*con; WriteInt(i); WriteLn; i := c[0] - 2; WriteInt(i); i := d.x[0] - 2; WriteInt(i); i := con - 2; WriteInt(i); i := c[0] - j; WriteInt(i); i := d.x[0] - j; WriteInt(i); i := con - j; WriteInt(i); i := con + 0; WriteInt(i); i := con - 0; WriteInt(i); WriteLn; b := TRUE & e[0]; PrintBool(b); b := b & e[0]; PrintBool(b); b := e[0] & TRUE; PrintBool(b); b := e[0] & b; PrintBool(b); b := (TRUE & e[0]) OR e[0]; PrintBool(b); b := TRUE OR TRUE; PrintBool(b); END ConstantFoldingAndLoadOp. ================================================ FILE: tests/base/ConstantFoldingAndLoadOp.txt ================================================ 11 6 8 200 6 8 200 1 2 98 1 2 98 100 100 1 1 1 1 1 1 ================================================ FILE: tests/base/DivMul.Mod ================================================ MODULE DivMul; CONST eight = 8; PROCEDURE PrintDiv(a,b : INTEGER); BEGIN WriteInt(a); WriteInt(b); WriteInt(a DIV b); WriteInt(a MOD b); WriteLn END PrintDiv; PROCEDURE Division; VAR x,y : INTEGER; a : ARRAY 2 OF INTEGER; BEGIN PrintDiv(8, 3); PrintDiv(8, -3); PrintDiv(-8, 3); PrintDiv(-8, -3); PrintDiv(1, 2); PrintDiv(1, -2); PrintDiv(-1, 2); PrintDiv(-1, -2); WriteInt(10 DIV 8); WriteInt(10 MOD eight); WriteLn; x := 8; WriteInt(10 DIV x); WriteInt(10 MOD x); x := 10; WriteInt(x DIV 8); WriteInt(x MOD eight); y := 8; WriteInt(x DIV y); WriteInt(x MOD y); WriteLn; a[0] := 8; WriteInt(10 DIV a[0]); WriteInt(10 MOD a[0]); a[0] := 10; WriteInt(a[0] DIV 8); WriteInt(a[0] MOD eight); a[1] := 8; WriteInt(a[0] DIV a[1]); WriteInt(a[0] MOD a[1]); END Division; PROCEDURE Multiplication; TYPE V = RECORD x : INTEGER END; VAR x,y : INTEGER; a : ARRAY 2 OF INTEGER; b : V; BEGIN WriteInt(4 * 8); WriteInt(4 * eight); WriteLn; x := 8; b.x := 8; WriteInt(4 * x); WriteInt(4 * b.x); x := 4; b.x := 4; WriteInt(x * 8); WriteInt(b.x * eight); y := 8; WriteInt(x * y); WriteInt(y * b.x); WriteLn; a[0] := 8; WriteInt(4 * a[0]); WriteInt(b.x * a[0]); a[0] := 4; b.x := 8; WriteInt(a[0] * 8); WriteInt(a[0] * b.x); a[1] := 8; WriteInt(a[0] * a[1]); END Multiplication; BEGIN Division; WriteLn; Multiplication END DivMul. ================================================ FILE: tests/base/DivMul.txt ================================================ 8 3 2 2 8 -3 -2 2 -8 3 -3 1 -8 -3 3 1 1 2 0 1 1 -2 0 1 -1 2 -1 1 -1 -2 1 1 1 2 1 2 1 2 1 2 1 2 1 2 1 2 32 32 32 32 32 32 32 32 32 32 32 32 32 ================================================ FILE: tests/base/EmptyArrayAndRecord.Mod ================================================ MODULE EmptyArrayAndRecord; TYPE EMPTY0 = RECORD END; EMPTY2 = RECORD e : RECORD END END; EMPTY3 = RECORD e : ARRAY 0 OF INTEGER END; EMPTY4 = RECORD e : ARRAY 0, 2 OF EMPTY0 END; EMPTY5 = RECORD e : ARRAY 2, 0 OF EMPTY0 END; EMPTY6 = RECORD i : INTEGER; e : ARRAY 2, 0 OF EMPTY0 END; AEMPTY = ARRAY 0 OF INTEGER; AEMPTY2 = ARRAY 0, 2 OF INTEGER; AEMPTY3 = ARRAY 0, 2 OF EMPTY0; AEMPTY4 = ARRAY 2, 0 OF EMPTY0; VAR empty0, empty1 : EMPTY0; empty2, empty3 : EMPTY2; empty4, empty5 : EMPTY3; empty6, empty7 : EMPTY4; empty8, empty9 : EMPTY5; empty10, empty11 : EMPTY6; aempty0, aempty1 : AEMPTY; aempty2, aempty3 : AEMPTY2; aempty4, aempty5 : AEMPTY3; aempty6, aempty7 : AEMPTY4; x, y : ARRAY 1 OF EMPTY0; y0, y1 : ARRAY 2, 0 OF EMPTY0; y2, y3 : ARRAY 3 OF RECORD i : INTEGER; j : ARRAY 0 OF EMPTY0; END; e : EMPTY0; i : INTEGER; BEGIN empty0 := empty1; empty2 := empty3; empty4 := empty5; empty6 := empty7; empty8 := empty9; empty10 := empty11; aempty0 := aempty1; aempty2 := aempty3; aempty4 := aempty5; aempty6 := aempty7; x := y; x[i] := e; y0 := y1; y2[i].j := y3[i].j; i := 10; WriteInt(i); END EmptyArrayAndRecord. ================================================ FILE: tests/base/EmptyArrayAndRecord.txt ================================================ 10 ================================================ FILE: tests/base/ExtTypes.Mod ================================================ MODULE ExtTypes; TYPE pR0* = POINTER TO R0; pR1* = POINTER TO R1; R0 = RECORD x: INTEGER END; R1 = RECORD(R0) y*: INTEGER END; END ExtTypes. ================================================ FILE: tests/base/ForwardPointerRef.Mod ================================================ MODULE ForwardPointerRef; TYPE P0 = POINTER TO R0; R0 = RECORD i: INTEGER END; R1 = RECORD j: INTEGER; dsc: POINTER TO R1; next: POINTER TO R2 END; P2 = POINTER TO R2; R2 = RECORD c: CHAR END; VAR p0: P0; pa: POINTER TO R1; pb: P2; BEGIN NEW(p0); p0.i := 3; WriteInt(p0.i); (* 3 *) NEW(pa); pa.j := 4; WriteInt(pa.j); (* 4 *) pa.dsc := pa; WriteInt(pa.dsc.j); (* 4 *) NEW(pb); pb.c := "C"; pa.next := pb; WriteChar(pa.next.c); (* C *) WriteLn; END ForwardPointerRef. ================================================ FILE: tests/base/ForwardPointerRef.txt ================================================ 3 4 4C ================================================ FILE: tests/base/Fractions.Mod ================================================ MODULE Fractions; (*NW 10.10.07; Tabulate fractions 1/n*) CONST Base = 10; N = 32; PROCEDURE Go; VAR i, j, m, n, r: INTEGER; d: ARRAY N OF INTEGER; (*digits*) x: ARRAY N OF INTEGER; (*index*) BEGIN n := ReadInt(); i := 2; WHILE i <= n DO j := 0; WHILE j < i DO x[j] := 0; j := j+1 END ; m := 0; r := 1; WHILE x[r] = 0 DO x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; m := m+1 END ; WriteInt(i); WriteChar(CHR(9)); WriteChar("."); j := 0; WHILE j < x[r] DO WriteChar(CHR(d[j] + 48)); j := j+1 END ; WriteChar("'"); WHILE j < m DO WriteChar(CHR(d[j] + 48)); j := j+1 END ; WriteLn; i := i+1 END END Go; BEGIN Go END Fractions. ================================================ FILE: tests/base/Fractions.txt ================================================ 2 .5'0 3 .3'3 4 .25'0 5 .2'0 6 .1'6 7 .1'428571 8 .125'0 9 .1'1 10 .1'0 11 .0'90 12 .08'3 13 .0'769230 14 .0'714285 15 .0'6 16 .0625'0 17 .0'5882352941176470 18 .0'5 19 .0'526315789473684210 20 .05'0 ================================================ FILE: tests/base/FragileBaseClass.Mod ================================================ MODULE FragileBaseClass; TYPE List = POINTER TO ListDesc; Node = POINTER TO NodeDesc; List2 = POINTER TO List2Desc; ListDesc = RECORD head: Node; add: PROCEDURE(l: List; i: INTEGER); addAll: PROCEDURE(l: List; i: ARRAY OF INTEGER); size: PROCEDURE(s: List): INTEGER; END; List2Desc = RECORD(ListDesc) count: INTEGER; END; NodeDesc = RECORD x: INTEGER; next: Node; END; VAR l: List; arr: ARRAY 2 OF INTEGER; PROCEDURE addList(l: List; i: INTEGER); VAR n: Node; BEGIN NEW(n); n.x := i; n.next := l.head; l.head := n; END addList; PROCEDURE addList2(l: List; i: INTEGER); BEGIN addList(l, i); INC(l(List2).count) END addList2; (* First version, the base class implements addAll without using the add method. This works fine. *) PROCEDURE addAllListA(l: List; i: ARRAY OF INTEGER); VAR j: INTEGER; n: Node; BEGIN FOR j := 0 TO LEN(i)-1 DO NEW(n); n.x := i[j]; n.next := l.head; l.head := n END END addAllListA; (* Second version, the base class implements addAll by calling "add" in a loop. This works fine and does not break the subclass because "add" is called as a static invocation to addList. This is not possible in Java that resolves "add" dynamically. *) PROCEDURE addAllListB(l: List; i: ARRAY OF INTEGER); VAR j: INTEGER; BEGIN FOR j := 0 TO LEN(i)-1 DO addList(l, i[j]) END END addAllListB; (* Third version, the base class implements addAll by calling "add" in a loop. This manifest the fragile base class problem. This is similar to Java normal dynamic dispatch of the method call "add": l.add(l, i[j]) will invoke addList2 that will invoke addList and so increment the count twice per element of the array i. *) PROCEDURE addAllListC(l: List; i: ARRAY OF INTEGER); VAR j: INTEGER; BEGIN FOR j := 0 TO LEN(i)-1 DO l.add(l, i[j]) END END addAllListC; PROCEDURE addAllList2A(l: List; i: ARRAY OF INTEGER); VAR len: INTEGER; BEGIN addAllListA(l, i); len := LEN(i); INC(l(List2).count, len) END addAllList2A; PROCEDURE addAllList2B(l: List; i: ARRAY OF INTEGER); VAR len: INTEGER; BEGIN addAllListB(l, i); len := LEN(i); INC(l(List2).count, len) END addAllList2B; PROCEDURE addAllList2C(l: List; i: ARRAY OF INTEGER); VAR len: INTEGER; BEGIN addAllListC(l, i); len := LEN(i); INC(l(List2).count, len) END addAllList2C; PROCEDURE sizeList(l: List) :INTEGER; VAR size: INTEGER; tmp: Node; BEGIN size := 0; tmp := l.head; WHILE(tmp # NIL) DO INC(size); tmp := tmp.next END; RETURN size END sizeList; PROCEDURE sizeList2(l: List) :INTEGER; RETURN l(List2).count END sizeList2; PROCEDURE newList2(addAll: PROCEDURE(l: List; i: ARRAY OF INTEGER)): List2; VAR l: List2; BEGIN NEW(l); l.head := NIL; l.add := addList2; l.addAll := addAll; l.size := sizeList2; RETURN l END newList2; BEGIN arr[0] := 8; arr[1] := 9; l := newList2(addAllList2A); l.addAll(l, arr); WriteInt(l.size(l)); l := newList2(addAllList2B); l.addAll(l, arr); WriteInt(l.size(l)); l := newList2(addAllList2C); l.addAll(l, arr); WriteInt(l.size(l)) END FragileBaseClass. ================================================ FILE: tests/base/FragileBaseClass.txt ================================================ 2 2 4 ================================================ FILE: tests/base/MagicSquares.Mod ================================================ MODULE MagicSquares; (*for Oberon-0 NW 25.1.2013*) PROCEDURE Generate; (*magic square of order 3, 5, 7, ... *) VAR i, j, x, nx, nsq, n: INTEGER; M: ARRAY 13 OF ARRAY 13 OF INTEGER; BEGIN n := ReadInt(); nsq := n*n; x := 0; i := n DIV 2; j := n-1; WHILE x < nsq DO nx := n + x; j := (j-1) MOD n; x := x+1; M[i][j] := x; WHILE x < nx DO i := (i+1) MOD n; j := (j+1) MOD n; x := x+1; M[i][j] := x END END ; i := 0; REPEAT j := 0; REPEAT WriteInt(M[i][j]); j := j+1 UNTIL j = n; WriteLn; i := i+1 UNTIL i = n END Generate; BEGIN Generate END MagicSquares. ================================================ FILE: tests/base/MagicSquares.txt ================================================ 3 8 4 5 1 9 7 6 2 ================================================ FILE: tests/base/OpenArrays.Mod ================================================ MODULE OpenArrays; VAR x : ARRAY 1 OF INTEGER; y : ARRAY 2 OF INTEGER; PROCEDURE P2(a : ARRAY OF INTEGER; VAR b : ARRAY OF INTEGER); VAR k : INTEGER; BEGIN WriteInt(b[0]); (* 1 *) (* a[0] := 1; read only*) (* a[3] := 2; read only*) b[0] := 2; (* b[3] := 2; TRAP *) k := a[0]; (* k := a[3]; TRAP *) k := b[0]; WriteInt(k); (* 2 *) (* k := b[3]; TRAP *) END P2; PROCEDURE P1(a : ARRAY OF INTEGER; VAR b : ARRAY OF INTEGER); VAR k : INTEGER; BEGIN (* a[0] := 1; read only*) (* a[3] := 2; read only*) b[0] := 1; (* b[3] := 2; TRAP *) k := a[0]; (* k := a[3]; TRAP *) k := b[0]; (* k := b[3]; TRAP *) P2(a, b) END P1; BEGIN P1(x, y); WriteInt(y[0]); (* 2 *) END OpenArrays. ================================================ FILE: tests/base/OpenArrays.txt ================================================ 1 2 2 ================================================ FILE: tests/base/OpenArrays2.Mod ================================================ MODULE OpenArrays2; TYPE ARR = ARRAY 3 OF INTEGER; VAR x : ARR; i : INTEGER; PROCEDURE P1(VAR b : ARRAY OF INTEGER; c : ARR; VAR d : ARR; e : ARRAY OF INTEGER); BEGIN WriteInt(b[i]); WriteInt(c[i]); WriteInt(d[i]); WriteInt(e[i]) END P1; BEGIN i := 1; x[i] := 8; P1(x, x, x, x) END OpenArrays2. ================================================ FILE: tests/base/OpenArrays2.txt ================================================ 8 8 8 8 ================================================ FILE: tests/base/OpenArrays3.Mod ================================================ MODULE OpenArrays3; TYPE ARR = ARRAY 3 OF INTEGER; R = RECORD i : INTEGER END; VAR d : ARRAY 10 OF INTEGER; x : ARRAY 3 OF INTEGER; e : ARRAY 10 OF R; y : ARRAY 3 OF R; f : ARRAY 10 OF ARRAY 3 OF INTEGER; z : ARRAY 3 OF ARR; PROCEDURE P0(VAR a : ARRAY OF INTEGER; b : ARRAY OF R; c : ARRAY OF ARR); BEGIN d := a; WriteInt(d[1]); e := b; WriteInt(e[1].i); f := c; WriteInt(f[1][1]) END P0; PROCEDURE P1(VAR a : ARRAY OF INTEGER; b : ARRAY OF R; c : ARRAY OF ARR); VAR d : ARRAY 10 OF INTEGER; e : ARRAY 10 OF R; f : ARRAY 10 OF ARR; BEGIN d[1] := -1; e[1].i := -1; f[1][1] := -1; d := a; WriteInt(d[1]); e := b; WriteInt(e[1].i); f := c; WriteInt(f[1][1]) END P1; BEGIN d[1] := -1; x[1] := 1; e[1].i := -1; y[1].i := 2; f[1][1] := -1; z[1][1] := 3; P0(x, y, z); WriteLn; x[1] := 4; y[1].i := 5; z[1][1] := 6; P1(x, y, z) END OpenArrays3. ================================================ FILE: tests/base/OpenArrays3.txt ================================================ 1 2 3 4 5 6 ================================================ FILE: tests/base/Out0.Mod ================================================ MODULE Out0; CONST con = 100; TYPE V = RECORD x : ARRAY 10 OF INTEGER END; Hello = RECORD world : INTEGER; x : ARRAY 3 OF ARRAY 10 OF V; END; int = INTEGER; ARR = ARRAY 9 OF int; ARR2 = ARRAY 9 OF V; VAR a : ARRAY 4 OF INTEGER; b : ARRAY 3 OF ARRAY 5 OF INTEGER; c : ARRAY 1 OF ARRAY 2 OF ARRAY 3 OF ARRAY 4 OF INTEGER; d : V; e : Hello; f : int; g : ARR; h : ARR2; z : RECORD y : int END; i, j : INTEGER; k : BOOLEAN; BEGIN a[2] := 8; WriteInt(a[2]); b[2][3] := 9; WriteInt(b[2][3]); c[0][1][2][3] := 10; WriteInt(c[0][1][2][3]); d.x[9] := 11; WriteInt(d.x[9]); e.world := 12; WriteInt(e.world); e.x[2][3].x[3] := 13; WriteInt(e.x[2][3].x[3]); f := 14; WriteInt(f); g[6] := 15; WriteInt(g[6]); h[8].x[2] := 16; WriteInt(h[8].x[2]); z.y := 17; WriteInt(z.y); i := -z.y + c[0][1][2][3] + h[8].x[2] * e.x[2][3].x[3] -1; WriteInt(i); j := 2; k := (i = j) OR (i >= j); IF k THEN WriteInt(1) END END Out0. ================================================ FILE: tests/base/Out0.txt ================================================ 8 9 10 11 12 13 14 15 16 17 200 1 ================================================ FILE: tests/base/Out1.Mod ================================================ MODULE Out1; CONST con = 100; VAR a : ARRAY 4 OF INTEGER; b : ARRAY 3 OF ARRAY 5 OF INTEGER; c : ARRAY 4 OF INTEGER; i, j : INTEGER; BEGIN i := 1; j := 2; a[j] := 1; WriteInt(a[j]); a[2] := 2; WriteInt(a[2]); a[i+j] := 3; WriteInt(a[i+j]); b[i][j] := 4; WriteInt(b[i][j]); b[2][4] := 5; WriteInt(b[2][4]); a[a[i]] := 6; WriteInt(a[a[i]]); a[c[i]] := 7; WriteInt(a[c[i]]); END Out1. ================================================ FILE: tests/base/Out1.txt ================================================ 1 2 3 4 5 6 7 ================================================ FILE: tests/base/Out2.Mod ================================================ MODULE Out2; CONST con = 100; TYPE R0 = RECORD x, y : INTEGER END; R1 = RECORD u : INTEGER; v : ARRAY 4 OF R0; v2 : ARRAY 4 OF ARRAY 6 OF R0; w : INTEGER; r0 : R0 END; R2 = RECORD r1 : R1 END; VAR i, j: INTEGER; s : ARRAY 2 OF R1; a : R0; b : R2; BEGIN a.x := 10; WriteInt(a.x); b.r1.r0.x := 11; WriteInt(b.r1.r0.x); i := 1; j := 2; s[i].u := 12; WriteInt(s[i].u); s[1].w := 13; WriteInt(s[1].w); s[i].v[j].x := 14; WriteInt(s[i].v[j].x); s[1].v[2].x := 15; WriteInt(s[1].v[2].x); s[0].v[i].y := 16; WriteInt(s[0].v[i].y); s[0].r0.y := 17; WriteInt(s[0].r0.y); s[0].v2[i][j].y := 18; WriteInt(s[0].v2[i][j].y); END Out2. ================================================ FILE: tests/base/Out2.txt ================================================ 10 11 12 13 14 15 16 17 18 ================================================ FILE: tests/base/Out3.Mod ================================================ MODULE Out3; CONST con = 100; VAR i, j, k : INTEGER; o, x : BOOLEAN; PROCEDURE gdc(m, n : INTEGER) : INTEGER; BEGIN WHILE m > n DO m := m - n ELSIF n > m DO n := n - m END; RETURN m END gdc; BEGIN i := 5; j := 5; IF i > j THEN k := 1; WriteInt(k) ELSIF i = j THEN k := 2; WriteInt(k); o := TRUE; IF k >= 1 THEN WHILE (i # j) OR o & (k < 4) DO k := k + 1; WriteInt(k) END END ELSE k := 3; WriteInt(k) END; WHILE (i # j) OR o & (k <= 4) DO k := k + 1; WriteInt(k) END; REPEAT i := i + 1; WriteInt(i) UNTIL (( i = 6) & o) OR ((j = 6) OR ~o); IF i > 0 THEN WriteInt(7) END; i := +12; x := TRUE; o := (8 > 3) & x & (i IN {0..13}); IF o THEN WriteInt(8) END; i := 8; WriteLn; REPEAT i := i + 1; WriteInt(i) UNTIL ( (i = 15) OR (j = 10) & ~o) & ((j # 6) OR ~o); WriteInt(gdc(8, 12)) END Out3. ================================================ FILE: tests/base/Out3.txt ================================================ 2 3 4 5 6 7 8 9 10 11 12 13 14 15 4 ================================================ FILE: tests/base/Out4.Mod ================================================ MODULE Out4; TYPE R0 = RECORD x, y : INTEGER END; R1 = RECORD r0 : R0 END; R8 = RECORD x : ARRAY 2 OF INTEGER END; R9 = ARRAY 3 OF INTEGER; R11 = RECORD v : ARRAY 4 OF R0 END; ARR = ARRAY 2 OF R11; VAR i : INTEGER; PROCEDURE P0(); VAR a : R8; b : R9; j : INTEGER; r1 : R1; s : ARR; PROCEDURE P1(o : BOOLEAN ; VAR z0, z2, z3 : INTEGER; VAR z1 : R9; VAR s : ARR); BEGIN o := TRUE; z0 := 20; z1[2] := 23; z2 := 21; z3 := 22; z0 := s[i].v[3].x + 6; s[i].v[3].x := z0 + 4; END P1; BEGIN i := 1; j := 10; WriteInt(j); a.x[1] := 11; WriteInt(a.x[1]); r1.r0.x := 12; WriteInt(r1.r0.x); b[2] := 13; WriteInt(b[2]); s[i].v[3].x := 14; WriteInt(s[i].v[3].x); P1(TRUE, j, a.x[1], r1.r0.x, b, s); WriteInt(j); WriteInt(a.x[1]); WriteInt(r1.r0.x); WriteInt(b[2]); WriteInt(s[i].v[3].x) END P0; PROCEDURE P9(o : BOOLEAN ; VAR z0 : INTEGER); BEGIN o := FALSE; z0 := z0 + 1; IF z0 # 4 THEN P9(o, z0) END END P9; PROCEDURE P10(VAR z0 : INTEGER); BEGIN z0 := z0 + 10 END P10; PROCEDURE P8(); VAR a, i, j : INTEGER; s : ARR; BEGIN a := 1; WriteInt(a); P9(TRUE, a); WriteInt(a); i := 1; j := 1; s[i*1].v[j-1].x := 90; P10(s[i*1].v[j-1].x); WriteInt(s[i*1].v[j-1].x) END P8; BEGIN P8(); P0() END Out4. ================================================ FILE: tests/base/Out4.txt ================================================ 1 4 100 10 11 12 13 14 20 21 22 23 24 ================================================ FILE: tests/base/Out5.Mod ================================================ MODULE Out5; TYPE A = RECORD x : INTEGER END; VAR i: INTEGER; v : ARRAY 20 OF INTEGER; a : A; BEGIN i := 1; v[i] := 10; WriteInt(v[i]); i := v[i] + 1; WriteInt(i); v[i] := i + 1; WriteInt(v[i]); i := v[i] + v[i] - 4; WriteInt(i); a.x := 21; WriteInt(a.x); i := a.x + 1; WriteInt(i); a.x := i + 1; WriteInt(a.x); i := a.x + a.x - 22; WriteInt(i); END Out5. ================================================ FILE: tests/base/Out5.txt ================================================ 10 11 12 20 21 22 23 24 ================================================ FILE: tests/base/Out6.Mod ================================================ MODULE Out6; TYPE R0 = RECORD x : INTEGER END; R1 = RECORD r0 : RECORD x : INTEGER END END; R2 = RECORD r0 : RECORD x : RECORD y : R0 END END END; VAR a : R0; b : R1; c : R2; BEGIN a.x := 10; WriteInt(a.x + a.x); b.r0.x := 11; WriteInt(b.r0.x + b.r0.x); c.r0.x.y.x := 12; WriteInt(c.r0.x.y.x + c.r0.x.y.x); END Out6. ================================================ FILE: tests/base/Out6.txt ================================================ 20 22 24 ================================================ FILE: tests/base/OutTest.Mod ================================================ MODULE OutTest; IMPORT Out; VAR str: ARRAY 3 OF CHAR; BEGIN Out.Int(10, 0); Out.Ln; Out.String("Hello"); Out.Ln; str[0] := "A"; str[1] := "B"; str[2] := "C"; Out.String(str); Out.Ln; str[0] := "A"; str[1] := "B"; str[2] := 0X; Out.String(str); Out.Ln; str[0] := "A"; str[1] := 0X; str[2] := "C"; Out.String(str); Out.Ln; str[0] := 0X; str[1] := "B"; str[2] := "C"; Out.String(str); END OutTest. ================================================ FILE: tests/base/OutTest.txt ================================================ 10 Hello ABC AB A ================================================ FILE: tests/base/Pattern1.Mod ================================================ MODULE Pattern1; IMPORT SYSTEM; VAR ch: CHAR; k,j: INTEGER; x: REAL; s: SET; BEGIN ch := "0"; WriteInt(ORD(ch)); k := 10; WriteInt(k); k := -65536; WriteInt(k); k := -65537; WriteInt(k); k := 65535; WriteInt(k); k := 65536; WriteInt(k); k := 65537; WriteInt(k); x := 1.0; WriteReal(x); s := {0, 4, 8}; WriteInt(SYSTEM.VAL(INTEGER, s)); s := {3..5}; WriteInt(SYSTEM.VAL(INTEGER, s)); k := 5; s := {3..k}; WriteInt(SYSTEM.VAL(INTEGER, s)); k := 18; s := {16..k}; WriteInt(SYSTEM.VAL(INTEGER, s)); k := 3; s := {k..5}; WriteInt(SYSTEM.VAL(INTEGER, s)); k := 3; s := {k..15}; WriteInt(SYSTEM.VAL(INTEGER, s)); j := 5; s := {k..j}; WriteInt(SYSTEM.VAL(INTEGER, s)); END Pattern1. ================================================ FILE: tests/base/Pattern1.txt ================================================ 48 10 -65536 -65537 65535 65536 65537 1.000000 273 56 56 458752 56 65528 56 ================================================ FILE: tests/base/Pattern2a.Mod ================================================ MODULE Pattern2a; VAR i, j, k, n: INTEGER; x, y: REAL; BEGIN i := 1+7; WriteInt(i); j := 7; i := 1+j; WriteInt(i); k := 1; i := j+k; WriteInt(i); i := j+1; WriteInt(i); i := j+0; WriteInt(i); i := 0+j; WriteInt(i); i := 1-7; WriteInt(i); j := 7; i := 1-j; WriteInt(i); i := j-1; WriteInt(i); i := j-0; WriteInt(i); i := 0-j; WriteInt(i); i := j-k; WriteInt(i); i := 3*7; WriteInt(i); j := 7; i := 3*j; WriteInt(i); i := j*3; WriteInt(i); i := 16*j; WriteInt(i); i := j*16; WriteInt(i); k := 3; i := k*j; WriteInt(i); i := 8 DIV 3; WriteInt(i); j := 8; i := j DIV 3; WriteInt(i); i := j DIV 4; WriteInt(i); k := 4; i := j DIV k; WriteInt(i); i := (-5) DIV 3; WriteInt(i); j := -5; i := j DIV 3; WriteInt(i); i := j DIV 4; WriteInt(i); k := 4; i := j DIV k; WriteInt(i); i := 8 MOD 3; WriteInt(i); j := 8; i := j MOD 3; WriteInt(i); i := j MOD 4; WriteInt(i); k := 4; i := j MOD k; WriteInt(i); i := (-5) MOD 3; WriteInt(i); j := -5; i := j MOD 3; WriteInt(i); i := j MOD 4; WriteInt(i); k := 4; i := j MOD k; WriteInt(i); j := 65539; i := j MOD 65536; WriteInt(i); j := 131075; i := j MOD 131072; WriteInt(i); i := 8; i := (i + 1) * (i - 1); WriteInt(i); k := 20; k := k DIV 17; WriteInt(k); n := 3; k := 8*n; WriteInt(k); k := n DIV 2; WriteInt(k); k := n MOD 16; WriteInt(k); y := 10.0; x := 6.0; x := -y / (x - 1.0); WriteReal(x); END Pattern2a. ================================================ FILE: tests/base/Pattern2a.txt ================================================ 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 ================================================ FILE: tests/base/Pattern2b.Mod ================================================ MODULE Pattern2b; IMPORT SYSTEM; VAR i, j: INTEGER; x, y: REAL; s, t: SET; BEGIN x := 1.0+7.0; WriteReal(x); y := 7.0; x := 1.0+y; WriteReal(x); y := 9.0; x := y-1.0; WriteReal(x); y := 4.0; x := y*2.0; WriteReal(x); y := 16.0; x := y/2.0; WriteReal(x); i := -8; WriteInt(i); j := 8; i := -j; WriteInt(i); x := -8.0; WriteReal(x); y := 8.0; x := -y; WriteReal(x); s := -{1, 3..31}; WriteInt(SYSTEM.VAL(INTEGER, s)); t := {1, 3..31}; s := -t; WriteInt(SYSTEM.VAL(INTEGER, s)); END Pattern2b. ================================================ FILE: tests/base/Pattern2b.txt ================================================ 8.000000 8.000000 8.000000 8.000000 8.000000 -8 -8 -8.000000 -8.000000 5 5 ================================================ FILE: tests/base/Pattern2c.Mod ================================================ MODULE Pattern2c; IMPORT SYSTEM; VAR s, t, u: SET; BEGIN s := {1, 5} + {2, 7, 4}; WriteInt(SYSTEM.VAL(INTEGER, s)); s := {1, 5} * {7, 1, 2}; WriteInt(SYSTEM.VAL(INTEGER, s)); s := {1, 5} - {7, 1, 2}; WriteInt(SYSTEM.VAL(INTEGER, s)); s := {1, 5, 2} / {7, 1, 2}; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5}; s := u + {2, 7, 4}; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5}; s := u * {7, 1, 2}; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5}; s := u - {7, 1, 2}; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5, 2}; s := u / {7, 1, 2}; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5}; t := {2, 7, 4}; s := u + t; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5}; t := {7, 1, 2}; s := u * t; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5}; t := {7, 1, 2}; s := u - t; WriteInt(SYSTEM.VAL(INTEGER, s)); u := {1, 5, 2}; t := {7, 1, 2}; s := u / t; WriteInt(SYSTEM.VAL(INTEGER, s)); END Pattern2c. ================================================ FILE: tests/base/Pattern2c.txt ================================================ 182 2 32 160 182 2 32 160 182 2 32 160 ================================================ FILE: tests/base/Permutations.Mod ================================================ MODULE Permutations; (*NW 22.1.2013 for Oberon-0*) VAR m, n: INTEGER; a: ARRAY 10 OF INTEGER; PROCEDURE perm(k: INTEGER); VAR i, x: INTEGER; BEGIN IF k = 0 THEN i := 0; WHILE i < n DO WriteInt(a[i]); i := i+1 END ; WriteLn ELSE perm(k-1); i := 0; WHILE i < k-1 DO x := a[i]; a[i] := a[k-1]; a[k-1] := x; perm(k-1); x := a[i]; a[i] := a[k-1]; a[k-1] := x; i := i+1 END END END perm; BEGIN n := 0; m := ReadInt(); WHILE ~eot() DO a[n] := m; n := n+1; m:= ReadInt() END ; perm(n) END Permutations. ================================================ FILE: tests/base/Permutations.txt ================================================ 3 7 11 7 3 11 11 7 3 7 11 3 3 11 7 11 3 7 ================================================ FILE: tests/base/Powers.Mod ================================================ MODULE Powers; (*NW 25.1.2013 fo Oberon-07; Tabulate positive and negative powers of 2*) CONST N = 32; M = 11; (*M ~ N*log2*) PROCEDURE Go; VAR i, k, n, exp: INTEGER; c, r, t: INTEGER; d: ARRAY M OF INTEGER; f: ARRAY N OF INTEGER; BEGIN n := ReadInt(); d[0] := 1; k := 1; exp := 1; WHILE exp < n DO (*compute d = 2^exp*) c := 0; (*carry*) i := 0; WHILE i < k DO t := 2*d[i] + c; IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ; i := i+1 END ; IF c = 1 THEN d[k] := 1; k := k+1 END ; (*write d*) i := M; WHILE i > k DO i := i-1; WriteChar(" ") END ; WHILE i > 0 DO i := i-1; WriteChar(CHR(d[i] + 48)) END ; WriteInt(exp); (*compute f = 2^-exp*) WriteChar(CHR(9)); WriteChar("0"); WriteChar("."); r := 0; i := 1; WHILE i < exp DO r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2; WriteChar(CHR(f[i] + 48)); i := i+1 END ; f[exp] := 5; WriteChar("5"); WriteLn; exp := exp + 1 END END Go; BEGIN Go END Powers. ================================================ FILE: tests/base/Powers.txt ================================================ 2 1 0.5 4 2 0.25 8 3 0.125 16 4 0.0625 32 5 0.03125 64 6 0.015625 128 7 0.0078125 256 8 0.00390625 512 9 0.001953125 1024 10 0.0009765625 2048 11 0.00048828125 4096 12 0.000244140625 8192 13 0.0001220703125 16384 14 0.00006103515625 32768 15 0.000030517578125 65536 16 0.0000152587890625 131072 17 0.00000762939453125 262144 18 0.000003814697265625 524288 19 0.0000019073486328125 1048576 20 0.00000095367431640625 2097152 21 0.000000476837158203125 4194304 22 0.0000002384185791015625 8388608 23 0.00000011920928955078125 16777216 24 0.000000059604644775390625 33554432 25 0.0000000298023223876953125 67108864 26 0.00000001490116119384765625 134217728 27 0.000000007450580596923828125 268435456 28 0.0000000037252902984619140625 536870912 29 0.00000000186264514923095703125 1073741824 30 0.000000000931322574615478515625 2147483648 31 0.0000000004656612873077392578125 ================================================ FILE: tests/base/PrimeNumbers.Mod ================================================ MODULE PrimeNumbers; (*NW 6.9.07; Tabulate prime numbers; for Oberon-07 NW 25.1.2013*) VAR n: INTEGER; p: ARRAY 400 OF INTEGER; v: ARRAY 20 OF INTEGER; PROCEDURE Primes(n: INTEGER); VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN; BEGIN x := 1; inc := 4; lim := 1; sqr := 4; m := 0; i := 3; WHILE i <= n DO REPEAT x := x + inc; inc := 6 - inc; IF sqr <= x THEN (*sqr = p[lim]^2*) v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim] END ; k := 2; prim := TRUE; WHILE prim & (k < lim) DO k := k+1; IF v[k] < x THEN v[k] := v[k] + p[k] END ; prim := x # v[k] END UNTIL prim; p[i] := x; WriteInt(x); IF m = 10 THEN WriteLn; m := 0 ELSE m := m+1 END ; i := i+1 END ; IF m > 0 THEN WriteLn END END Primes; BEGIN n:= ReadInt(); WriteInt(n); WriteLn; Primes(n) END PrimeNumbers. ================================================ FILE: tests/base/PrimeNumbers.txt ================================================ 20 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 ================================================ FILE: tests/base/ProcComparisons.Mod ================================================ MODULE ProcComparisons; VAR x: BOOLEAN; PROCEDURE P2(i : INTEGER): INTEGER; BEGIN RETURN 2 END P2; PROCEDURE P1(i : INTEGER): INTEGER; BEGIN RETURN 1 END P1; BEGIN IF P2 = P1 THEN WriteInt(0) END; IF P2 = P2 THEN WriteInt(1) END; IF P2 # P1 THEN WriteInt(2) END; IF P2 # NIL THEN WriteInt(3) END; IF P2 = NIL THEN WriteInt(4) END; x := P2 = P2; x := P2 = NIL END ProcComparisons. ================================================ FILE: tests/base/ProcComparisons.txt ================================================ 1 2 3 ================================================ FILE: tests/base/ProcType.Mod ================================================ MODULE ProcType; TYPE P = PROCEDURE(x: INTEGER); VAR p : P; PROCEDURE I(x: INTEGER); BEGIN WriteInt(x) END I; PROCEDURE callP(p: P); BEGIN p(9) END callP; BEGIN (* p := P; illegal assignment *) (* callP(P); illegal value parameter *) p := I; p(8); (* 8 *) callP(I); (* 9 *) END ProcType. ================================================ FILE: tests/base/ProcType.txt ================================================ 8 9 ================================================ FILE: tests/base/ProcVariables0.Mod ================================================ MODULE ProcVariables0; TYPE MyFun = PROCEDURE() : INTEGER; R = RECORD i : INTEGER END; P = POINTER TO R; VAR a: MyFun; b : PROCEDURE(r : R) : P; c : PROCEDURE(f : R) : P; r : R; p : P; PROCEDURE getNum8() : INTEGER; RETURN 8 END getNum8; PROCEDURE getNum7() : INTEGER; RETURN 7 END getNum7; PROCEDURE getPtr0(x : R) : P; VAR y : P; BEGIN NEW(y); y.i := x.i; RETURN y END getPtr0; PROCEDURE getPtr1(x : R) : P; VAR y : P; BEGIN NEW(y); y.i := x.i+1; RETURN y END getPtr1; PROCEDURE Run; VAR a0: MyFun; b0 : PROCEDURE(r : R) : P; c0 : PROCEDURE(f : R) : P; r0: R; p0 : P; BEGIN a0 := getNum8; WriteInt(a0()); a0 := getNum7; WriteInt(a0()); r0.i := 1; b0 := getPtr0; p0 := b0(r0); WriteInt(p0.i); b0 := getPtr1; p0 := b0(r0); WriteInt(p0.i); c0 := b0; p0 := c0(r0); WriteInt(p0.i) END Run; BEGIN Run; WriteLn; a := getNum8; WriteInt(a()); a := getNum7; WriteInt(a()); r.i := 1; b := getPtr0; p := b(r); WriteInt(p.i); b := getPtr1; p := b(r); WriteInt(p.i); c := b; p := c(r); WriteInt(p.i) END ProcVariables0. ================================================ FILE: tests/base/ProcVariables0.txt ================================================ 8 7 1 2 2 8 7 1 2 2 ================================================ FILE: tests/base/ProcVariables1.Mod ================================================ MODULE ProcVariables1; TYPE R = RECORD i : INTEGER END; MyFun = PROCEDURE(r : R) : INTEGER; VAR a : ARRAY 2 OF MyFun; i : INTEGER; r : R; PROCEDURE F1(x : R) : INTEGER; RETURN x.i+1 END F1; PROCEDURE F2(x : R) : INTEGER; RETURN x.i+2 END F2; PROCEDURE Run; VAR a0 : ARRAY 2 OF MyFun; BEGIN r.i := 1; a0[0] := F1; a0[1] := F2; FOR i := 0 TO 1 DO WriteInt(a0[i](r)) END END Run; BEGIN Run; WriteLn; r.i := 1; a[0] := F1; a[1] := F2; FOR i := 0 TO 1 DO WriteInt(a[i](r)) END END ProcVariables1. ================================================ FILE: tests/base/ProcVariables1.txt ================================================ 2 3 2 3 ================================================ FILE: tests/base/ProcVariables2.Mod ================================================ MODULE ProcVariables2; TYPE MyFun = PROCEDURE(x : INTEGER) : INTEGER; R = RECORD i : INTEGER; p : ARRAY 2 OF PROCEDURE(x : INTEGER) : INTEGER END; R1 = RECORD(R) j : CHAR END; VAR r : R; k : R1; i : BYTE; f : MyFun; PROCEDURE F1(x : INTEGER) : INTEGER; RETURN x+1 END F1; PROCEDURE F2(x : INTEGER) : INTEGER; RETURN x+2 END F2; PROCEDURE P1(x : INTEGER; y : MyFun) : INTEGER; RETURN y(x) END P1; PROCEDURE P2(x : INTEGER; VAR y : MyFun) : INTEGER; RETURN y(x) END P2; PROCEDURE Run; VAR r0 : R; k0 : R1; f0 : MyFun; BEGIN k0.i := 1; k0.p[0] := F1; k0.p[1] := F2; r0 := k0; FOR i := 0 TO 1 DO WriteInt(r0.p[i](r0.i)) END; WriteLn; WriteInt(P1(1, F1)); f0 := F2; WriteInt(P2(1, f0)) END Run; BEGIN Run; WriteLn; k.i := 1; k.p[0] := F1; k.p[1] := F2; r := k; FOR i := 0 TO 1 DO WriteInt(r.p[i](r.i)) END; WriteLn; WriteInt(P1(1, F1)); f := F2; WriteInt(P2(1, f)) END ProcVariables2. ================================================ FILE: tests/base/ProcVariables2.txt ================================================ 2 3 2 3 2 3 2 3 ================================================ FILE: tests/base/ProcVariables3.Mod ================================================ MODULE ProcVariables3; TYPE PT = PROCEDURE (m, n: INTEGER); Object = POINTER TO RECORD w: INTEGER; p: PT END ; VAR obj: Object; a: ARRAY 4 OF PT; PROCEDURE P(m, n: INTEGER; q: PT; VAR obj: Object); BEGIN q(m, n); obj.p(m+1, n); a[m](m+2, n) END P; PROCEDURE X( x1,x2 : INTEGER); BEGIN WriteInt(x1); WriteInt(x2); WriteLn; END X; BEGIN NEW(obj); obj.p := X; a[1] := X; P(1, 8, X, obj) END ProcVariables3. ================================================ FILE: tests/base/ProcVariables3.txt ================================================ 1 8 2 8 3 8 ================================================ FILE: tests/base/ProcVariables4.Mod ================================================ MODULE ProcVariables4; TYPE P0 = PROCEDURE(VAR x : REAL) : INTEGER; P1 = PROCEDURE(VAR x : REAL; VAR y : P0) : INTEGER; P2 = PROCEDURE(VAR x : REAL; y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER; P3 = PROCEDURE(VAR x : REAL; VAR y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER; VAR v: P0; v1: P1; v2: P2; v3: P3; f: REAL; PROCEDURE Floor(VAR x : REAL) : INTEGER; RETURN FLOOR(x) END Floor; PROCEDURE Floor1(VAR x : REAL; VAR y : P0) : INTEGER; RETURN y(x) END Floor1; PROCEDURE Floor2(VAR x : REAL; y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER; RETURN y(x) END Floor2; PROCEDURE Floor3(VAR x : REAL; VAR y : PROCEDURE(VAR x : REAL) : INTEGER) : INTEGER; RETURN y(x) END Floor3; BEGIN f := 8.5; v := Floor; (* WriteInt(Floor(8.0)); ERROR: read-only *) WriteInt(v(f)); (* 8 *) f := 9.5; v1 := Floor1; WriteInt(v1(f, v)); (* 9 *) f := 10.5; v2 := Floor2; WriteInt(v2(f, v)); (* 10 *) v3 := Floor3; (* WriteInt(v3(f, v)); ERROR: incompatible parameters (see rule E)) *) END ProcVariables4. ================================================ FILE: tests/base/ProcVariables4.txt ================================================ 8 9 10 ================================================ FILE: tests/base/ProcVariables5.Mod ================================================ MODULE ProcVariables5; TYPE T = PROCEDURE (x, y: INTEGER; z: BYTE); VAR v: T; i,j: INTEGER; PROCEDURE P (x, y: INTEGER; z: BYTE); BEGIN WriteInt(x+y+z) END P; PROCEDURE P1 (p: PROCEDURE (x, y: INTEGER; z: BYTE)); BEGIN IF i = 0 THEN INC(i); v := p; p(1, 2, 3); (* 6 *) v(1, 2, 4); (* 7 *) P1(p); P1(v) END; END P1; PROCEDURE P2 (p: T); BEGIN IF j = 0 THEN INC(j); v := p; p(1, 2, 3); (* 6 *) v(1, 2, 4); (* 7 *) P1(p); P1(v); P2(p); P2(v) END; END P2; BEGIN i := 0; j := 0; v := P; P1(P); P2(P) END ProcVariables5. ================================================ FILE: tests/base/ProcVariables5.txt ================================================ 6 7 6 7 ================================================ FILE: tests/base/ProcVariables6.Mod ================================================ MODULE ProcVariables6; TYPE Q = PROCEDURE (c: CHAR); VAR q: Q; PROCEDURE P0(VAR j: Q); PROCEDURE P1(c: CHAR); BEGIN WriteChar(c); WriteLn END P1; BEGIN j := P1 END P0; BEGIN P0(q); q("a") END ProcVariables6. ================================================ FILE: tests/base/ProcVariables6.txt ================================================ a ================================================ FILE: tests/base/ProcVariables7.Mod ================================================ MODULE ProcVariables7; TYPE ProcA = PROCEDURE; ProcB = PROCEDURE; VAR a: ProcA; PROCEDURE A; BEGIN WriteChar("A") END A; PROCEDURE B; BEGIN WriteChar("B") END B; PROCEDURE C(x: PROCEDURE(b: BYTE; c: CHAR; r: REAL)); BEGIN WriteChar("C") END C; BEGIN a := NIL; a := A; a(); a := B; a; C(NIL) END ProcVariables7. ================================================ FILE: tests/base/ProcVariables7.txt ================================================ ABC ================================================ FILE: tests/base/RealExpressions.Mod ================================================ MODULE RealExpressions; CONST NaN* = 0.0/0.0; PROCEDURE One() : REAL; RETURN 1.0 END One; PROCEDURE Arithmetic; VAR r, x, y : REAL; BEGIN x := 3.0; y := 2.0; r := x + y + One(); WriteReal(r); WriteLn; r := x - y; WriteReal(r); WriteLn; r := x * y; WriteReal(r); WriteLn; r := x / y; WriteReal(r); WriteLn; WriteReal(3.5 + 10.0 * 2.0); WriteLn END Arithmetic; PROCEDURE Relations; VAR x, y : REAL; BEGIN x := 3.0; y := NaN; IF x = y THEN WriteInt(1) END; IF x <= y THEN WriteInt(1) END; IF x < y THEN WriteInt(1) END; IF x >= y THEN WriteInt(1) END; IF x > y THEN WriteInt(1) END; y := 1.E0; IF x = y THEN WriteInt(1) END; IF x <= y THEN WriteInt(2) END; IF x < y THEN WriteInt(3) END; IF x >= y THEN WriteInt(4) END; IF x > y THEN WriteInt(5) END; WriteLn END Relations; BEGIN Arithmetic; Relations END RealExpressions. ================================================ FILE: tests/base/RealExpressions.txt ================================================ 6.000000 1.000000 6.000000 1.500000 23.500000 4 5 ================================================ FILE: tests/base/RecordAndTypeExtension.Mod ================================================ MODULE RecordAndTypeExtension; TYPE A = RECORD x : INTEGER; next : POINTER TO A; next2 : POINTER TO RECORD y : REAL END; END; B = RECORD(A) b : INTEGER END; C = RECORD(A) c : BOOLEAN END; PTRA = POINTER TO A; PTRB = POINTER TO B; PTRC = POINTER TO C; VAR pa : PTRA; pb : POINTER TO B; a : A; b : B; k : INTEGER; PROCEDURE PrintBool(x : BOOLEAN); BEGIN IF x THEN WriteInt(1) ELSE WriteInt(0) END; WriteLn END PrintBool; PROCEDURE testRelation; VAR a, b : PTRA; BEGIN NEW(a); b := NIL; PrintBool(NIL = b); PrintBool(b = NIL); PrintBool(NIL # b); PrintBool(b # NIL); PrintBool(a = b); PrintBool(a # b); b := a; PrintBool(a = b); PrintBool(a # b); END testRelation; PROCEDURE typeTest(VAR a3 : A); VAR pa2 : POINTER TO A; pa2T : PTRA; pb2 : POINTER TO B; b2 : B; BEGIN b2 := a3(B); WriteInt(b2.b); (* 8 *) NEW(pb2); pb2.x := 9; pb2.b := 15; pa2 := pb2; WriteInt(pa2.x); (* 9 *) pa2.x := 10; WriteInt(pb2.x); (* 10 *) pa2T := pb2; WriteInt(pa2T.x); (* 10 *) k := a3(B).b; WriteInt(k); (* 8 *) (* k := pa2(B).b; incompatible types *) (* k := pa2T(B).b; incompatible types *) k := a3(A).x; WriteInt(k); (* 7 *) (* k := pa2(A).x; incompatible types *) (* k := pa2T(A).x; incompatible types *) (* PrintBool(i IS INTEGER); incompatible types *) (* k := a3(PTRB).b; incompatible types *) k := pa2(PTRB).b; WriteInt(k); (* 15 *) k := pa2T(PTRB).b; WriteInt(k); (* 15 *) (* k := a3(PTRA).x; incompatible types *) k := pa2(PTRA).x; (* Todo: here we generate an unnecessary CHECKCAST *) WriteInt(k); (* 10 *) k := pa2T(PTRA).x; WriteInt(k); (* 10 *) PrintBool(a3 IS B); (* PrintBool(pa2 IS B); incompatible types *) (*PrintBool(pa2T IS B); incompatible types *) PrintBool(a3 IS A); (* PrintBool(pa2 IS A); incompatible types *) (* PrintBool(pa2T IS A); incompatible types *) (* PrintBool(a3 IS PTRB); incompatible types *) PrintBool(pa2 IS PTRB); PrintBool(pa2T IS PTRB); (* PrintBool(a3 IS PTRA); incompatible types *) PrintBool(pa2 IS PTRA); PrintBool(pa2T IS PTRA); PrintBool(pa2T IS PTRC); END typeTest; PROCEDURE localPointer; VAR pa2 : POINTER TO A; pb2 : POINTER TO B; a2 : A; b2 : B; arr2 : ARRAY 1 OF POINTER TO A; mulArr2 : ARRAY 1,3 OF POINTER TO A; BEGIN pa2 := NIL; NEW(pa2); pa2.x := 10; a2 := pa2^; WriteInt(a2.x); (* 10 *) pa2.x := 11; a2.x := pa2^.x; WriteInt(a2.x); (* 11 *) a2.x := pa2.x; WriteInt(a2.x); (* 11 *) a := pa2^; NEW(arr2[0]); NEW(mulArr2[0][2]); mulArr2[0][2].x := 12; NEW(a2.next2); NEW(pb2); pb2.x := 99; b2.x := 13; a2 := b2; WriteInt(a2.x); (* 13 *) pa2 := pb2; WriteInt(pa2.x); (* 99 *) END localPointer; PROCEDURE NewPar(VAR x : PTRA); BEGIN NEW(x) END NewPar; BEGIN WriteInt(a.x); (* 0 *) localPointer; WriteInt(a.x); (* 11 *) WriteLn; (* varRuntimeCheck(b); this fails with an ArrayStoreException as expected. Maybe we should use our own Trap instead: 'type guard failure'*) b.b := 8; b.x := 7; typeTest(b); NewPar(pa); testRelation; NEW(pb); pa := pb; PrintBool(pa = pb) END RecordAndTypeExtension. ================================================ FILE: tests/base/RecordAndTypeExtension.txt ================================================ 0 10 11 11 13 99 11 8 9 10 10 8 7 15 15 10 10 1 1 1 1 1 1 0 1 1 0 0 0 1 1 0 1 ================================================ FILE: tests/base/RecordAssignment.Mod ================================================ MODULE RecordAssignment; TYPE A = RECORD x : INTEGER; y : ARRAY 1, 2 OF INTEGER; END; D = RECORD d : REAL END; C = RECORD c : INTEGER; d : ARRAY 1, 1 OF D; END; B = RECORD(C) a : A; r : REAL; cArr : ARRAY 1 OF C; END; VAR a1 : ARRAY 1 OF A; a2 : RECORD a : A END; c1, c2 : C; b1, b2 : B; PROCEDURE initA(VAR x : A); BEGIN x.x := 1; x.y[0][0] := 2; x.y[0][1] := 3; END initA; PROCEDURE initD(VAR x : D); BEGIN x.d := 20.0 END initD; PROCEDURE initC(VAR x : C); BEGIN x.c := 79; x.d[0][0].d := 99.0; END initC; BEGIN initA(a1[0]); a2.a := a1[0]; a2.a.x := 11; a2.a.y[0][1] := 33; WriteInt(a1[0].x); WriteInt(a2.a.x); WriteInt(a1[0].y[0][1]); WriteInt(a2.a.y[0][1]); WriteLn; initC(c1); c2 := c1; c2.c := 80; c2.d[0][0].d := 100.0; WriteInt(c1.c); WriteInt(c2.c); WriteReal(c1.d[0][0].d); WriteReal(c2.d[0][0].d); WriteLn; b1.r := 4.0; initA(b1.a); initC(b1.cArr[0]); b1.c := 71; b1.d[0][0].d := 72.0; b2 := b1; b2.r := 44.0; b2.a.x := 11; b2.a.y[0][1] := 33; b2.cArr[0].c := 80; b2.cArr[0].d[0][0].d := 100.0; b2.c := 75; b2.d[0][0].d := 76.0; WriteReal(b1.r); WriteReal(b2.r); WriteInt(b1.a.x ); WriteInt(b2.a.x ); WriteInt(b1.a.y[0][1]); WriteInt(b2.a.y[0][1]); WriteInt(b1.cArr[0].c); WriteInt(b2.cArr[0].c); WriteReal(b1.cArr[0].d[0][0].d); WriteReal(b2.cArr[0].d[0][0].d); WriteInt(b1.c); WriteInt(b2.c); WriteReal(b1.d[0][0].d); WriteReal(b2.d[0][0].d); b2 := b2; END RecordAssignment. ================================================ FILE: tests/base/RecordAssignment.txt ================================================ 1 11 3 33 79 80 99.000000 100.000000 4.000000 44.000000 1 11 3 33 79 80 99.000000 100.000000 71 75 72.000000 76.000000 ================================================ FILE: tests/base/RecordAssignment2.Mod ================================================ MODULE RecordAssignment2; TYPE RP = POINTER TO R; R = RECORD i: INTEGER; a: ARRAY 10 OF RP; p: RP; END; VAR gbl0, gbl1 : RP; PROCEDURE Init(VAR x: R; i: INTEGER); BEGIN x.i := i; NEW(x.a[2]); x.a[2].i := i; NEW(x.p); x.p.i := i; END Init; PROCEDURE Print(x: R); BEGIN WriteInt(x.i); WriteInt(x.a[2].i); WriteInt(x.p.i); WriteLn END Print; PROCEDURE Run(local: RP; x: R); VAR y: R; BEGIN Init(y, 1); y := x; Print(y); (* 8 8 8 *) Init(gbl0^, 2); gbl0^ := x; Print(gbl0^); (* 8 8 8 *) Init(gbl0^, 3); gbl0^ := local^; Print(gbl0^); (* 8 8 8 *) Init(gbl0^.a[2]^, 4); gbl0^.a[2]^ := local^; Print(gbl0^.a[2]^); (* 8 8 8 *) Init(gbl0^.p^, 5); gbl0^.p^ := local^; Print(gbl0^.p^); (* 8 8 8 *) Init(gbl0^.p^.p^, 6); gbl0^.p^.p^ := local^; Print(gbl0^.p^.p^) (* 8 8 6 *) END Run; BEGIN NEW(gbl0); NEW(gbl1); Init(gbl1^, 8); Run(gbl1, gbl1^) END RecordAssignment2. ================================================ FILE: tests/base/RecordAssignment2.txt ================================================ 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 6 ================================================ FILE: tests/base/RecordParam.Mod ================================================ MODULE RecordParam; TYPE RP = POINTER TO R; R = RECORD i: INTEGER; p: RP; END; VAR g0, g1, g2: RP; PROCEDURE Print(x: RP); BEGIN WriteInt(x.i); IF x.p = NIL THEN WriteInt(0) ELSE WriteInt(x.p.i) END; WriteLn END Print; PROCEDURE Init0(VAR x: RP; i: INTEGER); BEGIN x.i := i; NEW(x.p); x.p.i := i; END Init0; PROCEDURE Init1(x: RP; i: INTEGER); BEGIN x.i := i; NEW(x.p); x.p.i := i; END Init1; PROCEDURE Init2(VAR x: R; i: INTEGER); BEGIN x.i := i; NEW(x.p); x.p.i := i; END Init2; PROCEDURE Run*; BEGIN NEW(g0); g0.p := g0; Init0(g0.p, 8); Print(g0.p); (* 8 8 *) NEW(g1); g1.p := g1; Init1(g1.p, 8); Print(g1.p); (* 8 0 *) NEW(g2); g2.p := g2; Init2(g2.p^, 8); Print(g2.p); (* 8 0 *) END Run; BEGIN Run END RecordParam. ================================================ FILE: tests/base/RecordParam.txt ================================================ 8 8 8 0 8 0 ================================================ FILE: tests/base/Samples0.Mod ================================================ MODULE Samples0; VAR n: INTEGER; PROCEDURE Multiply; VAR x, y, z: INTEGER; BEGIN x := ReadInt(); y := ReadInt(); z := 0; WHILE x > 0 DO IF x MOD 2 = 1 THEN z := z + y END ; y := 2*y; x := x DIV 2 END ; WriteInt(x); WriteInt(y); WriteInt(z); WriteLn END Multiply; PROCEDURE Divide; VAR x, y, r, q, w: INTEGER; BEGIN x := ReadInt(); y := ReadInt(); r := x; q := 0; w := y; WHILE w <= r DO w := 2*w END ; WHILE w > y DO q := 2*q; w := w DIV 2; IF w <= r THEN r := r - w; q := q + 1 END END ; WriteInt(x); WriteInt(y); WriteInt(q); WriteInt(r); WriteLn END Divide; PROCEDURE BinSearch; VAR i, j, k, n, x: INTEGER; a: ARRAY 32 OF INTEGER; BEGIN x := ReadInt(); k := 0; WHILE ~eot() DO a[k] := ReadInt(); k := k + 1 END ; i := 0; j := n; WHILE i < j DO k := (i+j) DIV 2; IF x < a[k] THEN j := k ELSE i := k+1 END END ; WriteInt(i); WriteInt(j); WriteInt(a[j]); WriteLn END BinSearch; BEGIN n := ReadInt(); IF n = 0 THEN Multiply ELSIF n = 1 THEN Divide ELSE BinSearch END END Samples0. ================================================ FILE: tests/base/Samples0.txt ================================================ 0 80 40 ================================================ FILE: tests/base/Samples1.Mod ================================================ MODULE Samples1; VAR n: INTEGER; PROCEDURE Multiply; VAR x, y, z: INTEGER; BEGIN x := ReadInt(); y := ReadInt(); z := 0; WHILE x > 0 DO IF x MOD 2 = 1 THEN z := z + y END ; y := 2*y; x := x DIV 2 END ; WriteInt(x); WriteInt(y); WriteInt(z); WriteLn END Multiply; PROCEDURE Divide; VAR x, y, r, q, w: INTEGER; BEGIN x := ReadInt(); y := ReadInt(); r := x; q := 0; w := y; WHILE w <= r DO w := 2*w END ; WHILE w > y DO q := 2*q; w := w DIV 2; IF w <= r THEN r := r - w; q := q + 1 END END ; WriteInt(x); WriteInt(y); WriteInt(q); WriteInt(r); WriteLn END Divide; PROCEDURE BinSearch; VAR i, j, k, n, x: INTEGER; a: ARRAY 32 OF INTEGER; BEGIN x := ReadInt(); k := 0; WHILE ~eot() DO a[k] := ReadInt(); k := k + 1 END ; i := 0; j := n; WHILE i < j DO k := (i+j) DIV 2; IF x < a[k] THEN j := k ELSE i := k+1 END END ; WriteInt(i); WriteInt(j); WriteInt(a[j]); WriteLn END BinSearch; BEGIN n := ReadInt(); IF n = 0 THEN Multiply ELSIF n = 1 THEN Divide ELSE BinSearch END END Samples1. ================================================ FILE: tests/base/Samples1.txt ================================================ 80 5 16 0 ================================================ FILE: tests/base/Samples2.Mod ================================================ MODULE Samples2; VAR n: INTEGER; PROCEDURE Multiply; VAR x, y, z: INTEGER; BEGIN x := ReadInt(); y := ReadInt(); z := 0; WHILE x > 0 DO IF x MOD 2 = 1 THEN z := z + y END ; y := 2*y; x := x DIV 2 END ; WriteInt(x); WriteInt(y); WriteInt(z); WriteLn END Multiply; PROCEDURE Divide; VAR x, y, r, q, w: INTEGER; BEGIN x := ReadInt(); y := ReadInt(); r := x; q := 0; w := y; WHILE w <= r DO w := 2*w END ; WHILE w > y DO q := 2*q; w := w DIV 2; IF w <= r THEN r := r - w; q := q + 1 END END ; WriteInt(x); WriteInt(y); WriteInt(q); WriteInt(r); WriteLn END Divide; PROCEDURE BinSearch; VAR i, j, k, n, x: INTEGER; a: ARRAY 32 OF INTEGER; BEGIN x := ReadInt(); k := 0; WHILE ~eot() DO a[k] := ReadInt(); k := k + 1 END ; i := 0; j := n; WHILE i < j DO k := (i+j) DIV 2; IF x < a[k] THEN j := k ELSE i := k+1 END END ; WriteInt(i); WriteInt(j); WriteInt(a[j]); WriteLn END BinSearch; BEGIN n := ReadInt(); IF n = 0 THEN Multiply ELSIF n = 1 THEN Divide ELSE BinSearch END END Samples2. ================================================ FILE: tests/base/Samples2.txt ================================================ 0 0 2 ================================================ FILE: tests/base/SetTest.Mod ================================================ MODULE SetTest; IMPORT SYSTEM; CONST eight = 8; c0 = {6..eight}; c1 = {0..4, 10, 30..31}; six = {6}; VAR s : SET; x,y : INTEGER; b : BOOLEAN; PROCEDURE PrintSet(x : SET); VAR i : INTEGER; BEGIN FOR i:= 0 TO 31 DO IF i IN x THEN WriteInt(i) END END; WriteLn END PrintSet; PROCEDURE PrintBool(x : BOOLEAN); BEGIN IF x THEN WriteInt(1) ELSE WriteInt(0) END; END PrintBool; PROCEDURE testRelation; VAR a : ARRAY 1 OF SET; b: SET; BEGIN a[0] := {4, 5, 3}; b := {4, 5, 1, 8}; IF a[0] = b THEN WriteInt(3) END; IF a[0] # b THEN WriteInt(4) END; WriteLn; a[0] := {4, 5, 3}; b := {1..8}; IF a[0] = b THEN WriteInt(3) END; IF a[0] # b THEN WriteInt(4) END; WriteLn; a[0] := {1..8}; b := {3, 8, 1}; IF a[0] = b THEN WriteInt(3) END; IF a[0] # b THEN WriteInt(4) END; WriteLn; a[0] := {1..3}; b := {3, 2, 1}; IF a[0] = b THEN WriteInt(3) END; IF a[0] # b THEN WriteInt(4) END; WriteLn; END testRelation; PROCEDURE testSetAndArrayAndField; TYPE V = RECORD s : SET; END; VAR i : INTEGER; f : ARRAY 2 OF SET; m : ARRAY 2 OF INTEGER; s, k : SET; b : BOOLEAN; d : V; BEGIN s := {9}; m[0] := 5; m[1] := 15; k := {8..m[1]} - s; PrintSet(k); (* {8, 10..15} *) i := 31; k := {8..10, i } - s; PrintSet(k); (* {8, 10, 31} *) k := {8..10, m[1] } - s; PrintSet(k); (* {8, 10, 15} *) k := {8..10, 12..15 } - s; PrintSet(k); (* {8, 10, 12..15} *) k := {8..10, 12..m[1] } - s; PrintSet(k); (* {8, 10, 12..15} *) k := {8..10, m[0]..12 } - s; PrintSet(k); (* {5..8, 10..12} *) k := {8..10, m[0]..m[1] } - s; PrintSet(k); (* {5..8, 10..15} *) k := {m[0]..10, 12..m[1] } - s; PrintSet(k); (* {5..8, 10, 12..15} *) k := {8..m[1], 12..m[1] } - s; PrintSet(k); (* {8, 10..15} *) s := {3..20}; k := s - {8..m[1], 12..m[1] }; PrintSet(k); (* {3..7, 16..20} *) s := {9}; k := {m[0]..m[1]} - s; PrintSet(k); (* {5..8, 10..15} *) k := {m[0]..13} - s; PrintSet(k); (* {5..8, 10..13} *) k := {8} - s; PrintSet(k); (* {8} *) k := s - {8}; PrintSet(k); (* {9} *) k := {1..3} - {8}; PrintSet(k); (* {1..3} *) k := s - s; PrintSet(k); (* {} *) s := {9}; m[0] := 5; m[1] := 15; f[0] := {1..3}; f[1] := {5}; d.s := {1..10}; k := {4, 1} - f[0]; PrintSet(k); (* {4} *) k := f[0] - {2}; PrintSet(k); (* {1, 3} *) k := {1..3} + {8}; PrintSet(k); (* {1..3, 8} *) k := s - f[0]; PrintSet(k); (* {9} *) k := f[0] - f[0]; PrintSet(k); (* {} *) b := m[0] IN {1..3}; PrintBool(b); (* 0 *) b := m[0] IN f[0]; PrintBool(b); (* 0 *) b := m[0] IN d.s; PrintBool(b); (* 1 *) b := 1 IN {1..3}; PrintBool(b); (* 1 *) b := 1 IN f[0]; PrintBool(b); (* 1 *) b := 1 IN d.s; PrintBool(b); (* 1 *) END testSetAndArrayAndField; BEGIN x := 5; s:= {3..x}; PrintSet(s); s:= {3..x, 20}; PrintSet(s); y := 20; s:= {3..x, y}; PrintSet(s); y := 20; s:= {y, 3..x}; PrintSet(s); b := (4 IN s) OR (x > 10); PrintBool(b); WriteLn; s := s + c0; (* {3..8, 20} *) PrintSet(s); s := {1..20, 22} - c1; (* {5..9, 11..20, 22} *) PrintSet(s); s := s * {6..8, 20}; (* {6..8, 20} *) PrintSet(s); s := s / {1..20, 23..31}; (* {1..5, 9..19, 23..31} *) PrintSet(s); s := {1, 2, 3} / {3, 4}; (* {1 2 4} *) PrintSet(s); x := 30; s:= {x..3}; (* this is wrong as x > 3, maybe we should put a check at runtime *) PrintSet(s); PrintBool(31 IN {0..2}); x := 31; PrintBool(x IN {0..2}); x := -100; PrintBool(x IN {0..2}); x := 33; PrintBool(x IN {0..2}); (* this is wrong as x >= 32, maybe we should put a check at runtime *) WriteLn; PrintSet(-{3..6, eight..31}); s := {3..6, eight..31}; PrintSet(-s); b := 1 IN {1..3}; (* this could be computed at compile-time*); PrintBool(b); testSetAndArrayAndField; testRelation; PrintSet({5, 6, 7} * six); PrintSet({5..7} / six); WriteInt(SYSTEM.VAL(INTEGER, {9..1})) END SetTest. ================================================ FILE: tests/base/SetTest.txt ================================================ 3 4 5 3 4 5 20 3 4 5 20 3 4 5 20 1 3 4 5 6 7 8 20 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 22 6 7 8 20 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 1 2 4 4 30 31 0 0 0 1 0 1 2 7 0 1 2 7 1 8 10 11 12 13 14 15 8 10 31 8 10 15 8 10 12 13 14 15 8 10 12 13 14 15 5 6 7 8 10 11 12 5 6 7 8 10 11 12 13 14 15 5 6 7 8 10 12 13 14 15 8 10 11 12 13 14 15 3 4 5 6 7 16 17 18 19 20 5 6 7 8 10 11 12 13 14 15 5 6 7 8 10 11 12 13 8 9 1 2 3 4 1 3 1 2 3 8 9 0 0 1 1 1 1 4 4 4 3 6 5 7 0 ================================================ FILE: tests/base/Strings0.Mod ================================================ MODULE Strings0; CONST baobab = "BAOBAB"; C = "C"; TYPE Arr = ARRAY 10 OF CHAR; VAR a : CHAR; b : ARRAY 10 OF CHAR; c : ARRAY 10 OF CHAR; PROCEDURE P(VAR x : ARRAY OF CHAR); BEGIN x := baobab; c := "BAOBAB" END P; PROCEDURE Init(VAR x : ARRAY OF CHAR); VAR i : INTEGER; BEGIN FOR i := 0 TO LEN(x)-1 DO x[i] := "-"; END; END Init; PROCEDURE Print(x : ARRAY OF CHAR); VAR i : INTEGER; BEGIN FOR i := 0 TO LEN(x)-1 DO IF x[i] = 0X THEN WriteChar("$") ELSE WriteChar(x[i]) END; END; WriteLn END Print; PROCEDURE Print2(x : Arr); VAR i : INTEGER; BEGIN FOR i := 0 TO LEN(x)-1 DO IF x[i] = 0X THEN WriteChar("$") ELSE WriteChar(x[i]) END; END; WriteLn END Print2; BEGIN Init(b); b := "BAOBAB"; Print(b); a := "C"; WriteChar(a); a := C; WriteChar(a); WriteLn; P(b); Print2(b); END Strings0. ================================================ FILE: tests/base/Strings0.txt ================================================ BAOBAB$--- CC BAOBAB$--- ================================================ FILE: tests/base/Strings1.Mod ================================================ MODULE Strings1; CONST y = "A"; VAR a: ARRAY 10 OF CHAR; x : CHAR; s0 : ARRAY 5 OF ARRAY 5 OF CHAR; s1 : ARRAY 5 OF CHAR; i : INTEGER; PROCEDURE PrintMid(x : ARRAY OF CHAR); BEGIN WriteChar(x[LEN(x) DIV 2]) END PrintMid; PROCEDURE Cmp(x, y : ARRAY OF CHAR); BEGIN IF x = y THEN WriteInt(-1) END; IF y = x THEN WriteInt(-2) END; IF x # y THEN WriteInt(-3) END; IF y # x THEN WriteInt(-4) END; IF x > y THEN WriteInt(-5) END; IF y > x THEN WriteInt(-6) END; IF x < y THEN WriteInt(-7) END; IF y < x THEN WriteInt(-8) END; IF x >= y THEN WriteInt(-9) END; IF y >= x THEN WriteInt(-10) END; IF x <= y THEN WriteInt(-11) END; IF y <= x THEN WriteInt(-12) END; END Cmp; PROCEDURE Comparisons; VAR a, b : ARRAY 15 OF CHAR; c : ARRAY 0 OF CHAR; PROCEDURE replace0x(VAR str: ARRAY OF CHAR); VAR i: INTEGER; found: BOOLEAN; BEGIN found := FALSE; FOR i := 0 TO LEN(str)-1 DO IF (str[i] = 0X) OR found THEN str[i] := "X"; found := TRUE END; END; END replace0x; BEGIN a := "Hello"; b := "World"; Cmp(a, b); WriteLn; a := "Hello"; b := "Hello"; Cmp(a, b); WriteLn; a := "HelloWorld"; b := "Hello"; Cmp(a, b); WriteLn; a := "Hello"; b := "HelloWorld"; Cmp(a, b); WriteLn; a := "Hello"; b := ""; Cmp(a, b); WriteLn; a := ""; b := "Hello"; Cmp(a, b); WriteLn; a := "Hello"; Cmp(a, c); WriteLn; a := "Hello"; Cmp(c, a); WriteLn; a := "Hello"; b := "World"; replace0x(a); replace0x(b); Cmp(a, b); WriteLn; a := "Hello"; b := "Hello"; replace0x(a); replace0x(b); Cmp(a, b); WriteLn; a := "HelloWorld"; b := "Hello"; replace0x(a); Cmp(a, b); WriteLn; a := "Hello"; b := "HelloWorld"; replace0x(a); replace0x(b); Cmp(a, b); WriteLn; a := "Hello"; b := ""; replace0x(a); Cmp(a, b); WriteLn; a := ""; b := "Hello"; replace0x(a); replace0x(b); Cmp(a, b); WriteLn; a := "Hello"; replace0x(a); Cmp(a, c); WriteLn; a := "Hello"; replace0x(a); Cmp(c, a); WriteLn; END Comparisons; BEGIN PrintMid("Hello"); WriteLn; IF a = "Hello" THEN WriteInt(0) END; IF "Hello" = "Hello" THEN WriteInt(1) END; IF "Hello" = a THEN WriteInt(2) END; IF a # "Hello" THEN WriteInt(3) END; IF "Hello" # "Hello" THEN WriteInt(4) END; IF "Hello" # a THEN WriteInt(5) END; IF a > "Hello" THEN WriteInt(6) END; IF "Hello" > "Hello" THEN WriteInt(7) END; IF "Hello" > a THEN WriteInt(8) END; IF a < "Hello" THEN WriteInt(9) END; IF "Hello" < "Hello" THEN WriteInt(10) END; IF "Hello" < a THEN WriteInt(11) END; IF a >= "Hello" THEN WriteInt(12) END; IF "Hello" >= "Hello" THEN WriteInt(13) END; IF "Hello" >= a THEN WriteInt(14) END; IF a <= "Hello" THEN WriteInt(15) END; IF "Hello" <= "Hello" THEN WriteInt(16) END; IF "Hello" <= a THEN WriteInt(17) END; IF "HELL" = "HELLO" THEN WriteInt(18) END; WriteLn; Comparisons; WriteLn; x := "A"; IF x = "A" THEN WriteInt(1) END; IF "A" = x THEN WriteInt(2) END; IF "A" = y THEN WriteInt(3) END; s0[0] := "ZAB"; i := -1; IF "ABC" < s0[1+i] THEN WriteInt(4) END; IF s0[1+i] > "ABC" THEN WriteInt(5) END; IF "ABC" < "ZBC" THEN WriteInt(6) END; IF "A" < "Z" THEN WriteInt(7) END; s1[0] := "A"; IF s1[1+i] = "A" THEN WriteInt(8) END; IF "A" = s1[1+i] THEN WriteInt(9) END; IF "A" = y THEN WriteInt(10) END; END Strings1. ================================================ FILE: tests/base/Strings1.txt ================================================ l 1 3 5 8 9 13 14 15 16 -3 -4 -6 -7 -10 -11 -1 -2 -9 -10 -11 -12 -3 -4 -5 -8 -9 -12 -3 -4 -6 -7 -10 -11 -3 -4 -5 -8 -9 -12 -3 -4 -6 -7 -10 -11 -3 -4 -5 -8 -9 -12 -3 -4 -6 -7 -10 -11 -3 -4 -6 -7 -10 -11 -1 -2 -9 -10 -11 -12 -3 -4 -5 -8 -9 -12 -3 -4 -5 -8 -9 -12 -3 -4 -5 -8 -9 -12 -3 -4 -5 -8 -9 -12 -3 -4 -5 -8 -9 -12 -3 -4 -6 -7 -10 -11 1 2 3 4 5 6 7 8 9 10 ================================================ FILE: tests/base/Strings2.Mod ================================================ MODULE Strings2; CONST a = "a"; abcd = "abcd"; VAR s4: ARRAY 4 OF CHAR; s5: ARRAY 5 OF CHAR; f: ARRAY 20 OF CHAR; PROCEDURE P(x: ARRAY OF CHAR); VAR i : INTEGER; BEGIN FOR i := 0 TO LEN(x)-1 DO IF x[i] = 0X THEN WriteChar("$") ELSE WriteChar(x[i]) END; END; WriteLn END P; PROCEDURE K; VAR f: ARRAY 20 OF CHAR; BEGIN f := "Hello"; IF f = "" THEN WriteInt(1) END; f := ""; IF f = "" THEN WriteInt(2) END; f[0] := 0X; IF f = "" THEN WriteInt(3) END END K; BEGIN s4 := a; P(s4); s4 := "a"; P(s4); s4 := "ab"; P(s4); P(a); P("a"); P("ab"); (* s4 := abcd; String too long *) (*s4 := "abcd"; String too long *) s5 := abcd; P(s5); s5 := "abcd"; P(s5); s5 := ""; P(s5); f := "Hello"; IF f = "" THEN WriteInt(1) END; f := ""; IF f = "" THEN WriteInt(2) END; f[0] := 0X; IF f = "" THEN WriteInt(3) END; K END Strings2. ================================================ FILE: tests/base/Strings2.txt ================================================ a$$$ a$$$ ab$$ a$ a$ ab$ abcd$ abcd$ $bcd$ 2 3 2 3 ================================================ FILE: tests/base/TestABS.Mod ================================================ MODULE TestABS; CONST r = -1.2; i = -2; VAR x, y : INTEGER; a, b : REAL; z : BYTE; BEGIN b := r; y := i; a := ABS(r); WriteReal(a); a := ABS(b); WriteReal(a); x := ABS(i); WriteInt(x); x := ABS(y); WriteInt(x); WriteLn; b := 7.3; y := 8; WriteReal(ABS(b)); WriteInt(ABS(y)); z := 10; WriteInt(ABS(z)) END TestABS. ================================================ FILE: tests/base/TestABS.txt ================================================ 1.200000 1.200000 2 2 7.300000 8 10 ================================================ FILE: tests/base/TestAnonymousName.Mod ================================================ MODULE TestAnonymousName; TYPE Anonymous0 = RECORD i :CHAR END; VAR x : RECORD i :INTEGER END; y : Anonymous0; c : CHAR; BEGIN y.i := "A"; c := y.i; x.i := 0; WriteChar(c) END TestAnonymousName. ================================================ FILE: tests/base/TestAnonymousName.txt ================================================ A ================================================ FILE: tests/base/TestAssert.Mod ================================================ MODULE TestAssert; VAR x : INTEGER; BEGIN x := 2; ASSERT(TRUE); ASSERT(x > 0); ASSERT((x > 0) & (x > 5) OR (x < 8) & (x # 3)); WriteInt(1) END TestAssert. ================================================ FILE: tests/base/TestAssert.txt ================================================ 1 ================================================ FILE: tests/base/TestAssignmentMix.Mod ================================================ MODULE TestAssignmentMix; TYPE A = RECORD i : INTEGER END; B = RECORD(A) j : REAL END; TA = ARRAY 1 OF A; TB = ARRAY 1 OF B; VAR (*ta : TA; tb : TB;*) a : A; b : B; pa : POINTER TO A; pb : POINTER TO B; (*ta2 : ARRAY 1 OF A; tb2 : ARRAY 1 OF B;*) BEGIN (*b := a; illegal assignment *) a := b; (* pb := pa; illegal assignment *) pa := pb; (* tb := ta; illegal assignment *) (* tb2 := ta2; illegal assignment *) (* ta := tb; illegal assignment *) (* ta2 := tb2; illegal assignment *) END TestAssignmentMix. ================================================ FILE: tests/base/TestAssignmentMix.txt ================================================ ================================================ FILE: tests/base/TestByteType.Mod ================================================ MODULE TestByteType; VAR x : INTEGER; y : BYTE; r : RECORD y : BYTE END; ar : ARRAY 1 OF BYTE; PROCEDURE P1(i : BYTE): INTEGER; BEGIN RETURN i + 1 END P1; PROCEDURE P2(i : INTEGER): BYTE; BEGIN RETURN i + 1 END P2; PROCEDURE Par1(b : BYTE); BEGIN WriteInt(b) END Par1; PROCEDURE Par2(b : INTEGER); BEGIN WriteInt(b) END Par2; PROCEDURE Ret1(): BYTE; BEGIN RETURN 8 END Ret1; PROCEDURE Ret2(): INTEGER; BEGIN RETURN 800 END Ret2; PROCEDURE P3; VAR x : INTEGER; y : BYTE; r : RECORD y : BYTE END; ar : ARRAY 1 OF BYTE; BEGIN WriteInt(P1(255)); WriteInt(P2(256)); WriteLn; y := 255; WriteInt(y); x := 129; WriteInt(x); y := x; x := y + 1; WriteInt(x); x := y; WriteInt(x); WriteLn; r.y := 255; WriteInt(r.y); x := 129; WriteInt(x); r.y := x; x := r.y + 1; WriteInt(x); x := r.y; WriteInt(x); WriteLn; ar[0] := 255; WriteInt(ar[0]); x := 129; WriteInt(x); ar[0] := x; x := ar[0] + 1; WriteInt(x); x := ar[0]; WriteInt(x); x := y; IF x = y THEN WriteInt(1) END END P3; BEGIN WriteInt(P1(255)); WriteInt(P2(256)); WriteLn; y := 255; WriteInt(y); x := 129; WriteInt(x); y := x; x := y + 1; WriteInt(x); x := y; WriteInt(x); WriteLn; r.y := 255; WriteInt(r.y); x := 129; WriteInt(x); r.y := x; x := r.y + 1; WriteInt(x); x := r.y; WriteInt(x); WriteLn; ar[0] := 255; WriteInt(ar[0]); x := 129; WriteInt(x); ar[0] := x; x := ar[0] + 1; WriteInt(x); x := ar[0]; WriteInt(x); x := y; IF x = y THEN WriteInt(1) END; WriteLn; P3; WriteLn; WriteInt(Ret1()); WriteInt(Ret2()); Par1(8); Par2(800); y := 8; WriteInt(y); x := 800; WriteInt(x) END TestByteType. ================================================ FILE: tests/base/TestByteType.txt ================================================ 256 1 255 129 130 129 255 129 130 129 255 129 130 129 1 256 1 255 129 130 129 255 129 130 129 255 129 130 129 1 8 800 8 800 8 800 ================================================ FILE: tests/base/TestCPS.Mod ================================================ MODULE TestCPS; TYPE F = PROCEDURE(i: INTEGER); PROCEDURE log(i : INTEGER); BEGIN WriteInt(i) END log; PROCEDURE tailFact(n,a : INTEGER; ret : F); BEGIN IF n = 0 THEN ret(a) ELSE tailFact(n-1, n*a, ret) END END tailFact; BEGIN tailFact(6, 1, log) END TestCPS. ================================================ FILE: tests/base/TestCPS.txt ================================================ 720 ================================================ FILE: tests/base/TestCmdLineArgs.Mod ================================================ MODULE TestCmdLineArgs; VAR x: INTEGER; y: ARRAY 10 OF CHAR; PROCEDURE Print(x: ARRAY OF CHAR); VAR i,j : INTEGER; BEGIN i := 0; j := LEN(x)-1; WHILE (i < j) & (x[i] # 0X) DO WriteChar(x[i]); INC(i) END; WriteLn END Print; PROCEDURE P(x: ARRAY OF CHAR); BEGIN ARGS(0, x) END P; PROCEDURE Main(); VAR buf0: ARRAY 0 OF CHAR; buf1: ARRAY 1 OF CHAR; buf2: ARRAY 2 OF CHAR; buf: ARRAY 10 OF CHAR; i: INTEGER; r: RECORD a: INTEGER END; g: ARRAY 2 OF RECORD buf: ARRAY 2 OF CHAR END; BEGIN ARGS(1, buf0); Print(buf0); ARGS(1, buf1); Print(buf1); ARGS(10, buf); Print(buf); ARGS(1, buf2); Print(buf2); r.a := 1; ARGS(r.a, g[1+i].buf); Print(buf2); P(buf); Print(buf); FOR i := 0 TO ARGNUM()-1 DO ARGS(i, buf); Print(buf) END END Main; BEGIN WriteInt(ARGNUM()); WriteLn; FOR x := 0 TO ARGNUM()-1 DO ARGS(x, y); Print(y) END END TestCmdLineArgs. ================================================ FILE: tests/base/TestCmdLineArgs.txt ================================================ 0 W W Hello Hello World! ================================================ FILE: tests/base/TestConstFunc.Mod ================================================ MODULE TestConstFunc; IMPORT SYSTEM; CONST negReal = -2.5; posReal = 3.2; posInt = 2; a = "A"; intA = 65; abs = ABS(negReal); odd = ODD(posInt); floor = FLOOR(posReal); flt = FLT(posInt); ord = ORD(a); chr = CHR(intA); lsl = LSL(intA, posInt); asr = ASR(intA, posInt); ror = ROR(intA, posInt); and = AND(intA, posInt); bor = BOR(intA, posInt); not = NOT(intA); set = {5}; int = SYSTEM.VAL(INTEGER, set); TYPE arr5 = ARRAY 5 OF INTEGER; ARR = ARRAY 3 OF INTEGER; VAR r: REAL; i, j: INTEGER; c: CHAR; z: ARRAY 5 OF INTEGER; s: SET; y: ARRAY 4 OF ARR; PROCEDURE WriteBool(b: BOOLEAN); BEGIN WriteInt(ORD(b)) END WriteBool; PROCEDURE LenP(a0: ARRAY OF INTEGER; a1: arr5; VAR a2: ARRAY OF ARR); CONST (* len0 = LEN(a0); ERROR expression not constant *) len1 = LEN(a1); len2 = LEN(a2[0]); len3 = AND(LEN(a2[0]), 1); VAR u: INTEGER; BEGIN u := 1; a2[0][u] := 1; WriteInt(len1); WriteInt(LEN(a1)); WriteInt(len2); WriteInt(LEN(a2[0])); WriteInt(len3); WriteInt(AND(LEN(a2[0]), a2[0][u])) END LenP; PROCEDURE P; CONST negReal = -2.5; posReal = 3.2; posInt = 2; a = "A"; intA = 65; abs = ABS(negReal); odd = ODD(posInt); floor = FLOOR(posReal); flt = FLT(posInt); ord = ORD(a); chr = CHR(intA); lsl = LSL(intA, posInt); asr = ASR(intA, posInt); ror = ROR(intA, posInt); and = AND(intA, posInt); bor = BOR(intA, posInt); not = NOT(intA); set = {5}; int = SYSTEM.VAL(INTEGER, set); TYPE arr5 = ARRAY 5 OF INTEGER; ARR = ARRAY 3 OF INTEGER; VAR r: REAL; i, j: INTEGER; c: CHAR; z: ARRAY 5 OF INTEGER; s: SET; y: ARRAY 4 OF ARR; BEGIN r := negReal; WriteReal(abs); WriteReal(ABS(r)); WriteLn; i := posInt; WriteBool(odd); WriteBool(ODD(i)); WriteLn; r := posReal; WriteInt(floor); WriteInt(FLOOR(r)); WriteLn; i := posInt; WriteReal(flt); WriteReal(FLT(i)); WriteLn; c := a; WriteInt(ord); WriteInt(ORD(c)); WriteLn; i := intA; WriteChar(chr); WriteChar(CHR(i)); WriteLn; LenP(z, z, y); WriteLn; i := intA; j := posInt; WriteInt(lsl); WriteInt(LSL(i, j)); WriteLn; WriteInt(asr); WriteInt(ASR(i, j)); WriteLn; WriteInt(ror); WriteInt(ROR(i, j)); WriteLn; WriteInt(and); WriteInt(AND(i, j)); WriteLn; WriteInt(bor); WriteInt(BOR(i, j)); WriteLn; WriteInt(not); WriteInt(NOT(i)); WriteLn; s := set; WriteInt(int); WriteInt(SYSTEM.VAL(INTEGER, s)); WriteLn; END P; BEGIN r := negReal; WriteReal(abs); WriteReal(ABS(r)); WriteLn; i := posInt; WriteBool(odd); WriteBool(ODD(i)); WriteLn; r := posReal; WriteInt(floor); WriteInt(FLOOR(r)); WriteLn; i := posInt; WriteReal(flt); WriteReal(FLT(i)); WriteLn; c := a; WriteInt(ord); WriteInt(ORD(c)); WriteLn; i := intA; WriteChar(chr); WriteChar(CHR(i)); WriteLn; LenP(z, z, y); WriteLn; i := intA; j := posInt; WriteInt(lsl); WriteInt(LSL(i, j)); WriteLn; WriteInt(asr); WriteInt(ASR(i, j)); WriteLn; WriteInt(ror); WriteInt(ROR(i, j)); WriteLn; WriteInt(and); WriteInt(AND(i, j)); WriteLn; WriteInt(bor); WriteInt(BOR(i, j)); WriteLn; WriteInt(not); WriteInt(NOT(i)); WriteLn; s := set; WriteInt(int); WriteInt(SYSTEM.VAL(INTEGER, s)); WriteLn; P END TestConstFunc. ================================================ FILE: tests/base/TestConstFunc.txt ================================================ 2.500000 2.500000 0 0 3 3 2.000000 2.000000 65 65 AA 5 5 3 3 1 1 260 260 16 16 1073741840 1073741840 0 0 67 67 -66 -66 32 32 2.500000 2.500000 0 0 3 3 2.000000 2.000000 65 65 AA 5 5 3 3 1 1 260 260 16 16 1073741840 1073741840 0 0 67 67 -66 -66 32 32 ================================================ FILE: tests/base/TestCyclicImport00A.Mod ================================================ MODULE TestCyclicImport00; TYPE R0* = RECORD k*: INTEGER END; END TestCyclicImport00. ================================================ FILE: tests/base/TestCyclicImport00B.Mod ================================================ MODULE TestCyclicImport00; IMPORT TestCyclicImport01; TYPE R0* = RECORD k*: INTEGER END; VAR r1: TestCyclicImport01.R1; BEGIN r1.x := 1 END TestCyclicImport00. ================================================ FILE: tests/base/TestCyclicImport01A.Mod ================================================ MODULE TestCyclicImport01; IMPORT TestCyclicImport00; TYPE R1* = RECORD x*: INTEGER END; VAR r0: TestCyclicImport00.R0; BEGIN r0.k := 2 END TestCyclicImport01. ================================================ FILE: tests/base/TestCyclicImport01B.Mod ================================================ MODULE TestCyclicImport01; IMPORT TestCyclicImport00; TYPE R1* = RECORD x*: INTEGER END; VAR r0*: TestCyclicImport00.R0; (* re-export R0*) BEGIN r0.k := 2 END TestCyclicImport01. ================================================ FILE: tests/base/TestCyclicImport10A.Mod ================================================ MODULE TestCyclicImport10; TYPE R0* = RECORD k*: INTEGER END; END TestCyclicImport10. ================================================ FILE: tests/base/TestCyclicImport10B.Mod ================================================ MODULE TestCyclicImport10; IMPORT TestCyclicImport11; TYPE R0* = RECORD k*: INTEGER END; VAR j: INTEGER; BEGIN j := TestCyclicImport11.i END TestCyclicImport10. ================================================ FILE: tests/base/TestCyclicImport11.Mod ================================================ MODULE TestCyclicImport11; IMPORT TestCyclicImport12; VAR i*: INTEGER; BEGIN i := TestCyclicImport12.w END TestCyclicImport11. ================================================ FILE: tests/base/TestCyclicImport12.Mod ================================================ MODULE TestCyclicImport12; IMPORT TestCyclicImport10; VAR r0: TestCyclicImport10.R0; w*: INTEGER; BEGIN r0.k := 2; w := 8 END TestCyclicImport12. ================================================ FILE: tests/base/TestEqualSignature00.Mod ================================================ MODULE TestEqualSignature00; TYPE A = RECORD i : INTEGER END; B = RECORD(A) k : CHAR END; P0 = PROCEDURE(x : ARRAY OF B); P1 = PROCEDURE(x : B); PTRB = POINTER TO B; P2 = PROCEDURE(x : PTRB); ARR = ARRAY 10 OF B; P3 = PROCEDURE(x : BYTE; y : CHAR; z : ARRAY OF B) : CHAR; P4 = PROCEDURE(z : ARR; x : PROCEDURE(z : ARR) : CHAR) : CHAR; VAR p0: P0; p1: P1; p2: P2; p3: P3; p4: P4; x : ARRAY 1 OF B; pb : PTRB; y : ARR; PROCEDURE H0(x : ARRAY OF B); BEGIN WriteChar(x[0].k) END H0; PROCEDURE H1(x : B); BEGIN WriteChar(x.k) END H1; PROCEDURE H2(x : PTRB); BEGIN WriteChar(x.k) END H2; PROCEDURE H3(x : BYTE; y : CHAR; z : ARRAY OF B) : CHAR; RETURN CHR(x+ORD(y)+z[0].i) END H3; PROCEDURE H4(z : ARR; x : PROCEDURE(z : ARR) : CHAR) : CHAR; RETURN x(z) END H4; PROCEDURE H5() : CHAR; RETURN "F" END H5; PROCEDURE L(u : ARR) : CHAR; RETURN u[0].k END L; BEGIN p0 := H0; x[0].k := "A"; p0(x); (* A *) p1 := H1; x[0].k := "B"; p1(x[0]); (* B *) p2 := H2; NEW(pb); pb.k := "C"; p2(pb); (* C *) p3 := H3; x[0].i := 2; WriteChar(p3(1, "A", x)); (* D *) p4 := H4; y[0].k := "E"; WriteChar(p4(y, L)); (* E *) WriteChar(H5()) END TestEqualSignature00. ================================================ FILE: tests/base/TestEqualSignature00.txt ================================================ ABCDEF ================================================ FILE: tests/base/TestExprVarPar.Mod ================================================ MODULE TestExprVarPar; VAR a: INTEGER; PROCEDURE G(VAR i: INTEGER); END G; BEGIN G(a+1) END TestExprVarPar. ================================================ FILE: tests/base/TestFor.Mod ================================================ MODULE TestFor; CONST minus1 = -1; TYPE R0 = RECORD x, y : INTEGER END; ARR = ARRAY 5 OF INTEGER; VAR i, x: INTEGER; r0 : R0; v : ARR; PROCEDURE P3(VAR v3 : ARR); BEGIN v3[0] := 1; r0.x := 4; FOR i := r0.x + 3 TO r0.x + 3 + v3[0] + v3[0] DO WriteInt(i) END; END P3; PROCEDURE P2(VAR k : INTEGER); BEGIN v[0] := 1; r0.x := 4; FOR k := r0.x + 3 TO r0.x + 3 + v[0] + v[0] DO WriteInt(k) END; END P2; PROCEDURE P1(j : INTEGER); VAR i1: INTEGER; r1 : R0; v1 : ARRAY 5 OF INTEGER; BEGIN FOR i1 := 0 TO 2 BY 1 DO WriteInt(i1) END; x := 3; FOR i1 := x TO 5 DO WriteInt(i1) END; j := 8; FOR i1 := 6 TO j DO WriteInt(i1) END; FOR i1 := j TO 0 BY minus1 DO WriteInt(i1) END; WriteLn; r1.x := 0; FOR i1 := r1.x TO 2 DO WriteInt(i1) END; r1.x := 2; FOR i1 := 3 TO r1.x + 3 DO WriteInt(i1) END; WriteLn; v1[0] := 1; r1.x := 4; FOR i1 := r1.x + 3 TO r1.x + 3 + v1[0] + v1[0] DO WriteInt(i1) END; END P1; BEGIN FOR i := 0 TO 2 BY 1 DO WriteInt(i) END; x := 3; FOR i := x TO 5 DO WriteInt(i) END; x := 8; FOR i := 6 TO x DO WriteInt(i) END; FOR i := x TO 0 BY minus1 DO WriteInt(i) END; WriteLn; r0.x := 0; FOR i := r0.x TO 2 DO WriteInt(i) END; r0.x := 2; FOR i := 3 TO r0.x + 3 DO WriteInt(i) END; WriteLn; v[0] := 1; r0.x := 4; FOR i := r0.x + 3 TO r0.x + 3 + v[0] + v[0] DO WriteInt(i) END; WriteLn; P1(0); i := 0; WriteLn; P2(i); WriteLn; P3(v); WriteLn; END TestFor. ================================================ FILE: tests/base/TestFor.txt ================================================ 0 1 2 3 4 5 6 7 8 8 7 6 5 4 3 2 1 0 0 1 2 3 4 5 7 8 9 0 1 2 3 4 5 6 7 8 8 7 6 5 4 3 2 1 0 0 1 2 3 4 5 7 8 9 7 8 9 7 8 9 ================================================ FILE: tests/base/TestFor1.Mod ================================================ MODULE TestFor1; VAR v, beg, end : INTEGER; PROCEDURE For0; VAR v, beg, end : INTEGER; BEGIN beg := 3; end := 10; FOR v := beg TO end BY 2 DO WriteInt(v) END; WriteLn END For0; PROCEDURE For1; BEGIN beg := 0; end := 3; FOR v := beg TO end DO WriteInt(v) END; WriteLn END For1; PROCEDURE For2(VAR v1, beg1, end1 : INTEGER; v0, beg0, end0 : INTEGER ); BEGIN FOR v1 := beg1 TO end1 BY 2 DO WriteInt(v1) END; WriteLn; FOR v0 := beg0 TO end0 DO WriteInt(v0) END; WriteLn; FOR v1 := beg TO end0 DO WriteInt(v1) END; WriteLn END For2; PROCEDURE For4; BEGIN beg := 10; end := 3; FOR v := beg TO end BY -1 DO WriteInt(v) END; WriteLn END For4; BEGIN For0; For1; For2(v, beg, end, 0, 3, 10); For4 END TestFor1. ================================================ FILE: tests/base/TestFor1.txt ================================================ 3 5 7 9 0 1 2 3 0 2 3 4 5 6 7 8 9 10 0 1 2 3 4 5 6 7 8 9 10 10 9 8 7 6 5 4 3 ================================================ FILE: tests/base/TestFunction0.Mod ================================================ MODULE TestFunction0; VAR x : INTEGER; PROCEDURE P1(i : INTEGER): INTEGER; PROCEDURE P2(j, z : INTEGER) : INTEGER; VAR k : INTEGER; BEGIN k := z; RETURN k + j END P2; BEGIN RETURN i + P2(i, 2) END P1; BEGIN x := P1(1); WriteInt(x); END TestFunction0. ================================================ FILE: tests/base/TestFunction0.txt ================================================ 4 ================================================ FILE: tests/base/TestINC0.Mod ================================================ MODULE TestINC0; VAR xg : INTEGER; yg : BYTE; ig : ARRAY 2 OF INTEGER; jg : RECORD x : INTEGER END; PROCEDURE P0(VAR i : INTEGER; VAR j : BYTE); BEGIN INC(i); WriteInt(i); (* 2 *) INC(i, 130); WriteInt(i); (* 132 *) INC(i, -128); WriteInt(i); (* 4 *) DEC(j); WriteInt(j); (* 255 *) DEC(j, 130); WriteInt(j); (* 125 *) INC(j, 4); WriteInt(j); (* 129 *) DEC(j, -128); WriteInt(j) (* 1 *) END P0; PROCEDURE P2; VAR i : INTEGER; j : BYTE; BEGIN i := 1; j := 0; INC(i); WriteInt(i); (* 2 *) INC(i, 130); WriteInt(i); (* 132 *) INC(i, -128); WriteInt(i); (* 4 *) DEC(j); WriteInt(j); (* 255 *) DEC(j, 130); WriteInt(j); (* 125 *) INC(j, 4); WriteInt(j); (* 129 *) DEC(j, -128); WriteInt(j) (* 1 *) END P2; PROCEDURE P3(VAR a0 : INTEGER; VAR a1 : ARRAY OF INTEGER); VAR i : ARRAY 2 OF INTEGER; j : RECORD x : INTEGER END; x : INTEGER; b : ARRAY 2 OF BYTE; BEGIN x := 0; i[0] := 2; i[1] := 3; INC(i[0]); WriteInt(i[0]); (* 3 *) INC(i[x+1]); WriteInt(i[x+1]); (* 4 *) j.x := 3; INC(j.x); WriteInt(j.x); (* 4 *) INC(a0); WriteInt(a0); (* 2 *) x := 0; INC(a1[x+1]); WriteInt(a1[x+1]); (* 4 *) INC(ig[0]); WriteInt(ig[0]); (* 3 *) INC(ig[x+1]); WriteInt(ig[x+1]); (* 5 *) xg := 0; INC(ig[xg+1]); WriteInt(ig[xg+1]); (* 6 *) jg.x := 6; INC(jg.x); WriteInt(jg.x); (* 7 *) INC(a1[xg+1]); WriteInt(a1[xg+1]); (* 7 *) b[1] := 10; INC(b[x+1]); WriteInt(b[x+1]); (* 11 *) i[0] := 2; i[1] := 3; INC(i[0], 7); WriteInt(i[0]); (* 9 *) INC(i[x+1], 7); WriteInt(i[x+1]); (* 10 *) j.x := 3; INC(j.x, 2); WriteInt(j.x); (* 5 *) x := 98; a0 := 1; INC(a0, x); WriteInt(a0); (* 99 *) x := 0; a1[x+1] := 80; xg := 20; INC(a1[x+1], xg); WriteInt(a1[x+1]); (* 100 *) x := 3; DEC(x, -1); WriteInt(x); (* 4 *) END P3; PROCEDURE P4(VAR a0 : INTEGER; VAR a1 : ARRAY OF INTEGER); VAR i : ARRAY 2 OF INTEGER; j : RECORD x : INTEGER END; x, r : INTEGER; b : ARRAY 2 OF BYTE; BEGIN x := 0; r := 0; i[0] := 2; i[1] := 3; INC(r, i[0]); WriteInt(r); (* 2 *) INC(r, i[x+1]); WriteInt(r); (* 5 *) j.x := 3; INC(r, j.x); WriteInt(r); (* 8 *) INC(r, a0); WriteInt(r); (* 9 *) x := 0; INC(r, a1[x+1]); WriteInt(r); (* 12 *) INC(r, ig[0]); WriteInt(r); (* 14 *) INC(r, ig[x+1]); WriteInt(r); (* 17 *) xg := 0; INC(r, ig[xg+1]); WriteInt(r); (* 20 *) jg.x := 6; INC(r, jg.x); WriteInt(r); (* 26 *) INC(r, a1[xg+1]); WriteInt(r); (* 29 *) b[1] := 10; INC(r, b[x+1]); WriteInt(r); (* 39 *) INC(r, 1+b[x+1]); WriteInt(r); (* 50 *) INC(r, b[x+1]+1); WriteInt(r); (* 61 *) END P4; BEGIN xg := 1; yg := 0; P0(xg, yg); WriteLn; P2; WriteLn; xg := 1; ig[0] := 2; ig[1] := 3; P3(xg, ig); WriteLn; xg := 1; ig[0] := 2; ig[1] := 3; P4(xg, ig) END TestINC0. ================================================ FILE: tests/base/TestINC0.txt ================================================ 2 132 4 255 125 129 1 2 132 4 255 125 129 1 3 4 4 2 4 3 5 6 7 7 11 9 10 5 99 100 4 2 5 8 9 12 14 17 20 26 29 39 50 61 ================================================ FILE: tests/base/TestINC1.Mod ================================================ MODULE TestINC1; VAR k: INTEGER; i: ARRAY 2 OF RECORD b : BYTE END; j: ARRAY 20 OF BYTE; x: BYTE; PROCEDURE Effect(VAR x : BYTE) : INTEGER; BEGIN WriteInt(x); (* 7 *) INC(k); RETURN 0 END Effect; PROCEDURE CallMe(VAR x : BYTE) : INTEGER; BEGIN RETURN x END CallMe; PROCEDURE P; VAR i: ARRAY 2 OF RECORD b : BYTE END; j: ARRAY 20 OF BYTE; x: BYTE; BEGIN i[0].b := 6; x := 10; k := 0; j[x+5] := 7; INC(i[Effect(j[x+5])].b, 2); WriteInt(k); (* 1 *) WriteInt(i[0].b); (* 8 *) INC(i[0].b, j[x+5]); WriteInt(i[0].b); (* 15 *) INC(j[x+5], i[0].b); WriteInt(j[x+5]); (* 22 *) INC(x, CallMe(i[0].b)); WriteInt(x); (* 25 *) END P; BEGIN P; WriteLn; i[0].b := 6; x := 10; k := 0; j[x+5] := 7; INC(i[Effect(j[x+5])].b, 2); WriteInt(k); (* 1 *) WriteInt(i[0].b); (* 8 *) INC(i[0].b, j[x+5]); WriteInt(i[0].b); (* 15 *) INC(j[x+5], i[0].b); WriteInt(j[x+5]); (* 22 *) INC(x, CallMe(i[0].b)); WriteInt(x) (* 25 *) END TestINC1. ================================================ FILE: tests/base/TestINC1.txt ================================================ 7 1 8 15 22 25 7 1 8 15 22 25 ================================================ FILE: tests/base/TestINCLAndEXCL.Mod ================================================ MODULE TestINCLAndEXCL; CONST K = {1, 2, 3}; VAR y : SET; j,f : INTEGER; b : ARRAY 2 OF SET; r: RECORD a: ARRAY 2 OF RECORD b: INTEGER END END; PROCEDURE PrintSet(x : SET); VAR i : INTEGER; BEGIN FOR i:= 0 TO 31 DO IF i IN x THEN WriteInt(i) END END; WriteLn END PrintSet; PROCEDURE P0(a0 : SET; VAR a1 : ARRAY OF SET); VAR i : ARRAY 2 OF SET; z : RECORD x : SET END; x : BYTE; BEGIN x := 0; i[0] := K; i[1] := K + {8}; INCL(i[0], 8); PrintSet(i[0]); (* {1 2 3 8} *) EXCL(i[x+1], 1); PrintSet(i[x+1]); (* {2 3 8} *) z.x := K; EXCL(z.x, 2); PrintSet(z.x); (* {1 3} *) EXCL(a0, 2); PrintSet(a0); (* {1 3} *) EXCL(a1[x+1], 3); PrintSet(a1[x+1]); (* {1 2} *) j := 0; INCL(a1[j+1], 3); PrintSet(a1[j+1]); (* {1 2 3} *) INCL(a0, 8+x); PrintSet(a0); (* {1 3 8} *) END P0; PROCEDURE Effect(VAR x : BYTE) : INTEGER; BEGIN WriteInt(x); (* 7 *) INC(f); RETURN 0 END Effect; PROCEDURE P1; VAR i : ARRAY 2 OF RECORD b : SET END; j : ARRAY 20 OF BYTE; z : ARRAY 20 OF BYTE; x : BYTE; BEGIN i[0].b := K; x := 10; f := 0; j[x+5] := 7; EXCL(i[Effect(j[x+5])].b, 2); WriteInt(f); (* 1 *) PrintSet(i[0].b); (* {1 3} *) z[x+1] := 8; INCL(i[Effect(j[x+5])].b, z[x+1]); WriteInt(f); (* 2 *) PrintSet(i[0].b); (* {1 3 8} *) z[2+x] := 10; INCL(i[Effect(j[x+5])].b, z[x+1] + z[2+x]); WriteInt(f); (* 3 *) PrintSet(i[0].b); (* {1 3 8 18} *) END P1; PROCEDURE P2(VAR a0 : SET); VAR x : BYTE; BEGIN x := 1; INCL(a0, 8+x); PrintSet(a0); (* {2 9} *) END P2; BEGIN y := K; EXCL(y, 2); (* {1 3} *) PrintSet(y); y := K; j := 1; r.a[-1+j].b := 2; EXCL(y, r.a[-1+j].b); (* {1 3} *) PrintSet(y); j := 2; y := K; EXCL(y, j); PrintSet(y); (* {1 3} *) b[j - 1] := K; EXCL(b[j - 1], j); (* {1 3} *) PrintSet(b[j - 1]); y := K; b[1] := K; P0(y, b); P1; y := {2}; P2(y) END TestINCLAndEXCL. ================================================ FILE: tests/base/TestINCLAndEXCL.txt ================================================ 1 3 1 3 1 3 1 3 1 2 3 8 2 3 8 1 3 1 3 1 2 1 2 3 1 3 8 7 1 1 3 7 2 1 3 8 7 3 1 3 8 18 2 9 ================================================ FILE: tests/base/TestImport00.Mod ================================================ MODULE TestImport00; CONST N* = 100; TYPE Ptr* = POINTER TO Rec; Rec* = RECORD n*: INTEGER; p: Ptr END ; Rec2 = RECORD o*: INTEGER; p: Ptr END ; VAR k*: INTEGER; a*: ARRAY N OF INTEGER; b0*: ARRAY N OF RECORD t* : Rec2 END; b1*: ARRAY N OF Rec; PROCEDURE P*(x: INTEGER): INTEGER; RETURN 3 END P; BEGIN k := 1; a[2] := 2; b0[1].t.o := 10; b1[1].n := 20 END TestImport00. ================================================ FILE: tests/base/TestImport00.txt ================================================ ================================================ FILE: tests/base/TestImport01.Mod ================================================ MODULE TestImport01; IMPORT TestImport00; VAR k1: INTEGER; a1: ARRAY TestImport00.N OF INTEGER; p: TestImport00.Ptr; BEGIN p := NIL; k1 := TestImport00.k; WriteInt(TestImport00.N); WriteInt(k1); a1 := TestImport00.a; WriteInt(a1[2]); k1 := TestImport00.P(TestImport00.k); WriteInt(k1); k1 := TestImport00.b0[1].t.o; WriteInt(k1); k1 := TestImport00.b1[1].n; WriteInt(k1); END TestImport01. ================================================ FILE: tests/base/TestImport01.txt ================================================ 100 1 2 3 10 20 ================================================ FILE: tests/base/TestImport10.Mod ================================================ MODULE TestImport10; CONST Ten* = 10; Dollar* = "$"; TYPE R* = RECORD u*: INTEGER; v*: SET END ; S* = RECORD w*: ARRAY 4 OF R END ; P* = POINTER TO R; A* = ARRAY 8 OF INTEGER; B* = ARRAY 4, 5 OF REAL; C* = ARRAY 10 OF S; D* = ARRAY 2 OF CHAR; VAR x*: INTEGER; PROCEDURE Q0*; BEGIN INC(x, 10) END Q0; PROCEDURE Q1*(x, y: INTEGER): INTEGER; BEGIN RETURN x+y END Q1; BEGIN x := 5 END TestImport10. ================================================ FILE: tests/base/TestImport10.txt ================================================ ================================================ FILE: tests/base/TestImport100.Mod ================================================ MODULE TestImport100; IMPORT S := SYSTEM; VAR s: SET; BEGIN s := {1}; WriteInt(S.VAL(INTEGER, s)); END TestImport100. ================================================ FILE: tests/base/TestImport100.txt ================================================ 2 ================================================ FILE: tests/base/TestImport11.Mod ================================================ MODULE TestImport11; IMPORT I := TestImport10; VAR r : I.R; s : I.S; p : I.P; a : I.A; b : I.B; c : I.C; d : I.D; BEGIN WriteInt(I.x); (* 5 *) r.v := {1..9}; IF 6 IN r.v THEN WriteInt(6) END; s.w[2].u := 7; WriteInt(s.w[2].u); (* 7 *) NEW(p); p.u := 8; WriteInt(p.u); (* 8 *) a[4] := 9; WriteInt(a[4]); (* 9 *) b[1, 2] := 20.0-10.0; WriteReal(b[1][2]); (* 10.0 *) c[9].w[2].u := 11; WriteInt(c[9].w[2].u); (* 11 *) WriteLn; d[1] := "A"; WriteChar(d[1]); (* A *) WriteChar(I.Dollar); (* $ *) WriteInt(I.Ten + 1); (* 11, compile time sum *) I.Q0; WriteInt(I.x); (* 15 *) WriteInt(I.Q1(8, 9)) (* 17 *) END TestImport11. ================================================ FILE: tests/base/TestImport11.txt ================================================ 5 6 7 8 9 10.000000 11 A$ 11 15 17 ================================================ FILE: tests/base/TestImport110.Mod ================================================ MODULE TestImport110; CONST TEN* = 10; TYPE X* = RECORD i*: INTEGER END; END TestImport110. ================================================ FILE: tests/base/TestImport110.txt ================================================ ================================================ FILE: tests/base/TestImport111.Mod ================================================ DEFINITION TestImport111; IMPORT TestImport110; CONST TWELVE = TestImport110.TEN + 2; TYPE Y* = BYTE; END TestImport111. ================================================ FILE: tests/base/TestImport112.Mod ================================================ MODULE TestImport112; IMPORT TestImport110, TestImport111; VAR x: TestImport110.X; y: TestImport111.Y; BEGIN y := TestImport111.TWELVE; x.i := y; WriteInt(x.i) END TestImport112. ================================================ FILE: tests/base/TestImport112.txt ================================================ 12 ================================================ FILE: tests/base/TestImport120.Mod ================================================ MODULE TestImport120; TYPE TypeA* = INTEGER; TypeB* = RECORD b: CHAR END; END TestImport120. ================================================ FILE: tests/base/TestImport120.txt ================================================ ================================================ FILE: tests/base/TestImport121.Mod ================================================ MODULE TestImport121; IMPORT I := TestImport120; TYPE TypeC* = I.TypeA; TypeD* = I.TypeB; END TestImport121. ================================================ FILE: tests/base/TestImport121.txt ================================================ ================================================ FILE: tests/base/TestImport122.Mod ================================================ MODULE TestImport122; IMPORT TestImport121, X := TestImport120; VAR a: X.TypeA; b: X.TypeB; c: TestImport121.TypeC; d: TestImport121.TypeD; BEGIN c := a; b := d END TestImport122. ================================================ FILE: tests/base/TestImport122.txt ================================================ ================================================ FILE: tests/base/TestImport130.Mod ================================================ MODULE TestImport130; TYPE TypeC* = RECORD a*: CHAR END; TypeD* = RECORD(TypeC) d*: BYTE END; END TestImport130. ================================================ FILE: tests/base/TestImport130.txt ================================================ ================================================ FILE: tests/base/TestImport131.Mod ================================================ MODULE TestImport131; IMPORT I:=TestImport130, TestImport130; VAR x: I.TypeD; y: TestImport130.TypeD; BEGIN x.a := "@"; x.d := 1; y := x; WriteChar(y.a); WriteInt(y.d) END TestImport131. ================================================ FILE: tests/base/TestImport131.txt ================================================ @ 1 ================================================ FILE: tests/base/TestImport140.Mod ================================================ MODULE TestImport140; TYPE Rec0* = RECORD a*: INTEGER; b*: CHAR; c*: REAL; END ; END TestImport140. ================================================ FILE: tests/base/TestImport140.txt ================================================ ================================================ FILE: tests/base/TestImport141.Mod ================================================ MODULE TestImport141; IMPORT TestImport140; TYPE Rec1* = RECORD(TestImport140.Rec0) d*: ARRAY 2 OF INTEGER; e*: BOOLEAN; f*: BYTE; END ; END TestImport141. ================================================ FILE: tests/base/TestImport141.txt ================================================ ================================================ FILE: tests/base/TestImport142.Mod ================================================ MODULE TestImport142; IMPORT I0 := TestImport140, I1 := TestImport141; TYPE PtrRec1 = POINTER TO I1.Rec1; VAR r0: POINTER TO I0.Rec0; r1: PtrRec1; BEGIN NEW(r1); r0 := r1; IF r0 IS PtrRec1 THEN WriteInt(1) END; r1.a := 2; r1.b := "3"; r1.c := 4.0; r1.d[1] := 5; r1.e := TRUE; r1.f := 6; WriteInt(r1.a); WriteChar(r1.b); WriteReal(r1.c); WriteInt(r1.d[1]); WriteInt(ORD(r1.e)); WriteInt(r1.f) END TestImport142. ================================================ FILE: tests/base/TestImport142.txt ================================================ 1 23 4.000000 5 1 6 ================================================ FILE: tests/base/TestImport150.Mod ================================================ MODULE TestImport150; TYPE Rec150* = RECORD a*: INTEGER; END ; PROCEDURE Two*; BEGIN WriteInt(2); WriteLn END Two; END TestImport150. ================================================ FILE: tests/base/TestImport150.txt ================================================ ================================================ FILE: tests/base/TestImport151.Mod ================================================ MODULE TestImport151; IMPORT X := TestImport150, Y:= TestImport150, TestImport150; TYPE J = TestImport150.Rec150; K = Y.Rec150; VAR a: Y.Rec150; b: X.Rec150; c: J; d: K; BEGIN a := b; c := d; X.Two; Y.Two; TestImport150.Two END TestImport151. ================================================ FILE: tests/base/TestImport151.txt ================================================ 2 2 2 ================================================ FILE: tests/base/TestImport20.Mod ================================================ MODULE TestImport20; TYPE R* = RECORD u*: INTEGER END; END TestImport20. ================================================ FILE: tests/base/TestImport20.txt ================================================ ================================================ FILE: tests/base/TestImport21.Mod ================================================ MODULE TestImport21; IMPORT I := TestImport20; TYPE X* = I.R; END TestImport21. ================================================ FILE: tests/base/TestImport21.txt ================================================ ================================================ FILE: tests/base/TestImport22.Mod ================================================ MODULE TestImport22; IMPORT TestImport20, TestImport21; VAR x : TestImport20.R; y : TestImport21.X; BEGIN x.u := 8; y := x; WriteInt(y.u); END TestImport22. ================================================ FILE: tests/base/TestImport22.txt ================================================ 8 ================================================ FILE: tests/base/TestImport30.Mod ================================================ MODULE TestImport30; TYPE T* = RECORD c* : CHAR END; VAR x* : T; BEGIN x.c := "A" END TestImport30. ================================================ FILE: tests/base/TestImport30.txt ================================================ ================================================ FILE: tests/base/TestImport31.Mod ================================================ MODULE TestImport31; IMPORT TestImport30; VAR y : TestImport30.T; BEGIN y := TestImport30.x; WriteChar(y.c) END TestImport31. ================================================ FILE: tests/base/TestImport31.txt ================================================ A ================================================ FILE: tests/base/TestImport40.Mod ================================================ MODULE TestImport40; TYPE T* = RECORD x*: INTEGER END ; END TestImport40. ================================================ FILE: tests/base/TestImport40.txt ================================================ ================================================ FILE: tests/base/TestImport41.Mod ================================================ MODULE TestImport41; IMPORT TestImport40; PROCEDURE P*(VAR t: TestImport40.T); BEGIN WriteInt(t.x) END P; END TestImport41. ================================================ FILE: tests/base/TestImport41.txt ================================================ ================================================ FILE: tests/base/TestImport42.Mod ================================================ MODULE TestImport42; IMPORT TestImport40, TestImport41; VAR r: TestImport40.T; BEGIN r.x := 8; TestImport41.P(r) END TestImport42. ================================================ FILE: tests/base/TestImport42.txt ================================================ 8 ================================================ FILE: tests/base/TestImport50.Mod ================================================ MODULE TestImport50; TYPE T* = RECORD x*: INTEGER END ; END TestImport50. ================================================ FILE: tests/base/TestImport50.txt ================================================ ================================================ FILE: tests/base/TestImport51.Mod ================================================ MODULE TestImport51; IMPORT TestImport50; TYPE T* = PROCEDURE (VAR u: TestImport50.T); T1* = PROCEDURE (u: TestImport50.T); END TestImport51. ================================================ FILE: tests/base/TestImport51.txt ================================================ ================================================ FILE: tests/base/TestImport52.Mod ================================================ MODULE TestImport52; IMPORT TestImport50; TYPE T* = PROCEDURE (VAR u: TestImport50.T); T1* = PROCEDURE (u: TestImport50.T); END TestImport52. ================================================ FILE: tests/base/TestImport52.txt ================================================ ================================================ FILE: tests/base/TestImport53.Mod ================================================ MODULE TestImport53; IMPORT TestImport51, TestImport52; (*twice hidden import of TestImport50.T*) VAR p0: TestImport51.T; p1: TestImport52.T; p2: TestImport51.T1; p3: TestImport52.T1; BEGIN p0 := p1; p2 := p3; END TestImport53. ================================================ FILE: tests/base/TestImport53.txt ================================================ ================================================ FILE: tests/base/TestImport60.Mod ================================================ MODULE TestImport60; CONST PI* = 3.14; N* = -999999999; TYPE R0* = RECORD x: INTEGER END ; P0* = POINTER TO R0; END TestImport60. ================================================ FILE: tests/base/TestImport60.txt ================================================ ================================================ FILE: tests/base/TestImport61.Mod ================================================ MODULE TestImport61; IMPORT TestImport60; TYPE P1* = POINTER TO R1; R1* = RECORD(TestImport60.R0) y* : CHAR END; END TestImport61. ================================================ FILE: tests/base/TestImport61.txt ================================================ ================================================ FILE: tests/base/TestImport62.Mod ================================================ MODULE TestImport62; IMPORT TestImport60, TestImport61; VAR p1* : TestImport61.P1; BEGIN NEW(p1); p1.y := "A"; WriteChar(p1.y); IF p1 IS TestImport61.P1 THEN WriteChar("Y") END; WriteReal(TestImport60.PI); WriteInt(TestImport60.N) END TestImport62. ================================================ FILE: tests/base/TestImport62.txt ================================================ AY 3.140000 -999999999 ================================================ FILE: tests/base/TestImport70.Mod ================================================ MODULE TestImport70; TYPE Key = BYTE; ItemDesc* = RECORD key*: Key; END; END TestImport70. ================================================ FILE: tests/base/TestImport70.txt ================================================ ================================================ FILE: tests/base/TestImport71.Mod ================================================ MODULE TestImport71; IMPORT Qs := TestImport70; TYPE ActorDesc* = RECORD (Qs.ItemDesc) END; VAR a: POINTER TO ActorDesc; BEGIN NEW(a); a.key := 1; WriteInt(a.key) END TestImport71. ================================================ FILE: tests/base/TestImport71.txt ================================================ 1 ================================================ FILE: tests/base/TestImport80.Mod ================================================ MODULE TestImport80; IMPORT I := TestImport81, TestImport82; VAR b: I.TypeB; c: TestImport82.TypeC; BEGIN c := b END TestImport80. ================================================ FILE: tests/base/TestImport80.txt ================================================ ================================================ FILE: tests/base/TestImport81.Mod ================================================ MODULE TestImport81; TYPE TypeB* = RECORD END; END TestImport81. ================================================ FILE: tests/base/TestImport81.txt ================================================ ================================================ FILE: tests/base/TestImport82.Mod ================================================ MODULE TestImport82; IMPORT I := TestImport81; TYPE TypeC* = I.TypeB; END TestImport82. ================================================ FILE: tests/base/TestImport82.txt ================================================ ================================================ FILE: tests/base/TestImport90.Mod ================================================ MODULE TestImport90; CONST h* = "Hello"; x* = "!"; END TestImport90. ================================================ FILE: tests/base/TestImport90.txt ================================================ ================================================ FILE: tests/base/TestImport91.Mod ================================================ MODULE TestImport91; IMPORT imp := TestImport90; VAR i: INTEGER; str: ARRAY 10 OF CHAR; BEGIN str := imp.h; i := 0; WHILE str[i] # 0X DO WriteChar(str[i]); INC(i) END ; WriteChar(imp.x); WriteLn END TestImport91. ================================================ FILE: tests/base/TestImport91.txt ================================================ Hello! ================================================ FILE: tests/base/TestMath.Mod ================================================ MODULE TestMath; IMPORT Math; VAR x: REAL; BEGIN x := Math.pi; x := Math.e; x := 0.7; WriteReal(Math.sqrt(x)); WriteLn; WriteReal(Math.power(2.0, x)); WriteLn; WriteReal(Math.exp(x)); WriteLn; WriteReal(Math.ln(x)); WriteLn; WriteReal(Math.log(x, 2.0)); WriteLn; WriteReal(Math.round(x)); WriteLn; WriteReal(Math.sin(x)); WriteLn; WriteReal(Math.cos(x)); WriteLn; WriteReal(Math.tan(x)); WriteLn; WriteReal(Math.arcsin(x)); WriteLn; WriteReal(Math.arccos(x)); WriteLn; WriteReal(Math.arctan(x)); WriteLn; WriteReal(Math.arctan2(x, 0.3)); WriteLn; WriteReal(Math.sinh(x)); WriteLn; WriteReal(Math.cosh(x)); WriteLn; WriteReal(Math.tanh(x)); WriteLn; WriteReal(Math.arcsinh(x)); WriteLn; WriteReal(Math.arccosh(1.0 + x)); WriteLn; WriteReal(Math.arctanh(x)); WriteLn END TestMath. ================================================ FILE: tests/base/TestMath.txt ================================================ 0.836660 0.490000 2.013753 -0.356675 -0.514573 1.000000 0.644218 0.764842 0.842288 0.775397 0.795399 0.610726 1.165905 0.758584 1.255169 0.604368 0.652667 1.123231 0.867301 ================================================ FILE: tests/base/TestNestedProcs.Mod ================================================ MODULE TestNestedProcs; PROCEDURE Outer(n: INTEGER); PROCEDURE Inner(n: CHAR); BEGIN Outer(ORD(n)-1) END Inner; BEGIN IF n > 0 THEN Inner(CHR(n)) END; WriteInt(n) END Outer; BEGIN Outer(3) END TestNestedProcs. ================================================ FILE: tests/base/TestNestedProcs.txt ================================================ 0 1 2 3 ================================================ FILE: tests/base/TestODD.Mod ================================================ MODULE TestODD; VAR x: INTEGER; y: SET; BEGIN x := 14; y := {1..20}; IF ODD(8) THEN WriteInt(1) END; IF ODD(9) THEN WriteInt(2) END; IF ~ODD(8) THEN WriteInt(3) END; IF ODD(x) OR (x IN y) & (x > 8) THEN WriteInt(4) END END TestODD. ================================================ FILE: tests/base/TestODD.txt ================================================ 2 3 4 ================================================ FILE: tests/base/TestOOP.Mod ================================================ MODULE TestOOP; CONST PI = 3.13; PROCEDURE oopType0; TYPE Shape = POINTER TO ShapeDesc; Rectangle = POINTER TO RectangleDesc; Circle = POINTER TO CircleDesc; ShapeDesc = RECORD name : CHAR; area : PROCEDURE (s : Shape) : REAL; END; RectangleDesc = RECORD (ShapeDesc) l, w : REAL END; CircleDesc = RECORD (ShapeDesc) r : REAL END; VAR shape : Shape; PROCEDURE RectArea(s : Shape) : REAL; VAR area : REAL; BEGIN CASE s OF Rectangle: area := s.l * s.w; END; RETURN area END RectArea; PROCEDURE CircleArea(s : Shape) : REAL; RETURN s(Circle).r * s(Circle).r * PI END CircleArea; PROCEDURE newRect() : Rectangle; VAR rect : Rectangle; BEGIN NEW(rect); rect.name := "R"; rect.l := 10.0; rect.w := 2.2; rect.area := RectArea; RETURN rect END newRect; PROCEDURE newCircle() : Circle; VAR circ : Circle; BEGIN NEW(circ); circ.name := "C"; circ.r := 8.4; circ.area := CircleArea; RETURN circ END newCircle; BEGIN shape := newRect(); WriteChar(shape.name); WriteChar(" "); WriteReal(shape.area(shape)); WriteLn; shape := newCircle(); WriteChar(shape.name); WriteChar(" "); WriteReal(shape.area(shape)) END oopType0; PROCEDURE oopType1; TYPE Shape1 = POINTER TO ShapeDesc1; Rectangle1 = POINTER TO RectangleDesc1; Circle1 = POINTER TO CircleDesc1; Message = RECORD END; Handler = PROCEDURE (s: Shape1; VAR msg: Message); AreaMsg = RECORD (Message) area : REAL END ; ShapeDesc1 = RECORD name : CHAR; handle : Handler; END; RectangleDesc1 = RECORD (ShapeDesc1) l, w : REAL END; CircleDesc1 = RECORD (ShapeDesc1) r : REAL END; VAR shape : Shape1; area : AreaMsg; PROCEDURE RectHandler(s : Shape1; VAR msg: Message); VAR r : Rectangle1; BEGIN r := s(Rectangle1); CASE msg OF AreaMsg: msg.area := r.l * r.w; END END RectHandler; PROCEDURE CircleHandler(s : Shape1; VAR msg: Message); VAR c : Circle1; BEGIN c := s(Circle1); IF msg IS AreaMsg THEN msg(AreaMsg).area := c.r * c.r * PI END END CircleHandler; PROCEDURE newRect1() : Rectangle1; VAR rect : Rectangle1; BEGIN NEW(rect); rect.name := "R"; rect.l := 10.0; rect.w := 2.2; rect.handle := RectHandler; RETURN rect END newRect1; PROCEDURE newCircle1() : Circle1; VAR circ : Circle1; BEGIN NEW(circ); circ.name := "C"; circ.r := 8.4; circ.handle := CircleHandler; RETURN circ END newCircle1; BEGIN shape := newRect1(); WriteChar(shape.name); WriteChar(" "); shape.handle(shape, area); WriteReal(area.area); WriteLn; shape := newCircle1(); WriteChar(shape.name); WriteChar(" "); shape.handle(shape, area); WriteReal(area.area) END oopType1; PROCEDURE oopType2; TYPE Shape2 = POINTER TO ShapeDesc2; Rectangle2 = POINTER TO RectangleDesc2; Circle2 = POINTER TO CircleDesc2; Method = POINTER TO MethodDesc; MethodDesc = RECORD area: PROCEDURE (s : Shape2) : REAL; END; ShapeDesc2 = RECORD name : CHAR; do : Method; END; RectangleDesc2 = RECORD (ShapeDesc2) l, w : REAL END; CircleDesc2 = RECORD (ShapeDesc2) r : REAL END; VAR shape : Shape2; PROCEDURE RectArea2(s : Shape2) : REAL; VAR r : Rectangle2; BEGIN r := s(Rectangle2); RETURN r.l * r.w END RectArea2; PROCEDURE CircleArea2(s : Shape2) : REAL; VAR c : Circle2; BEGIN c := s(Circle2); RETURN c.r * c.r * PI END CircleArea2; PROCEDURE newRect2() : Rectangle2; VAR rect : Rectangle2; BEGIN NEW(rect); rect.name := "R"; rect.l := 10.0; rect.w := 2.2; (* This should be initialized in the module body so the below 2 statements would be just rect.do := RectMethod, where RectMethod is the initialized global *) NEW(rect.do); rect.do.area := RectArea2; RETURN rect END newRect2; PROCEDURE newCircle2() : Circle2; VAR circ : Circle2; BEGIN NEW(circ); circ.name := "C"; circ.r := 8.4; (* This should be initialized in the module body so the below 2 statements would be just circ.do := CircleMethod, where CircleMethod is the initialized global *) NEW(circ.do); circ.do.area := CircleArea2; RETURN circ END newCircle2; BEGIN shape := newRect2(); WriteChar(shape.name); WriteChar(" "); WriteReal(shape.do.area(shape)); WriteLn; shape := newCircle2(); WriteChar(shape.name); WriteChar(" "); WriteReal(shape.do.area(shape)); END oopType2; BEGIN oopType0; WriteLn; oopType1; WriteLn; oopType2 END TestOOP. ================================================ FILE: tests/base/TestOOP.txt ================================================ R 22.000000 C 220.852783 R 22.000000 C 220.852783 R 22.000000 C 220.852783 ================================================ FILE: tests/base/TestReadOnlyPar.Mod ================================================ MODULE TestReadOnlyPar; TYPE ARR = ARRAY 3 OF INTEGER; PROCEDURE P2(VAR e : ARRAY OF INTEGER); END P2; PROCEDURE P3(VAR e : ARR); END P3; PROCEDURE P1(k : ARR); BEGIN P2(k); (*read-only*) P3(k) (*read-only*) END P1; END TestReadOnlyPar. ================================================ FILE: tests/base/TestReturn0.Mod ================================================ MODULE TestReturn0; VAR x: INTEGER; PROCEDURE P1(): INTEGER; BEGIN RETURN x END P1; PROCEDURE P2(): INTEGER; RETURN x END P2; PROCEDURE P3(): INTEGER; VAR dummy: INTEGER; RETURN x+dummy END P3; BEGIN x := 1; WriteInt(P1()); WriteInt(P2()); WriteInt(P3()); END TestReturn0. ================================================ FILE: tests/base/TestReturn0.txt ================================================ 1 1 1 ================================================ FILE: tests/base/TestShift.Mod ================================================ MODULE TestShift; VAR x : INTEGER; BEGIN x := 8; WriteInt(LSL(x, x DIV 4)); WriteInt(ASR(x, 1)); WriteInt(ROR(65280, x)) END TestShift. ================================================ FILE: tests/base/TestShift.txt ================================================ 32 4 255 ================================================ FILE: tests/base/TestStringsMod.Mod ================================================ MODULE TestStringsMod; IMPORT Strings; VAR l: INTEGER; buf, tmp: ARRAY 30 OF CHAR; buf0, tmp0: ARRAY 0 OF CHAR; buf2: ARRAY 2 OF CHAR; buf3: ARRAY 3 OF CHAR; buf8: ARRAY 8 OF CHAR; PROCEDURE Print(x : ARRAY OF CHAR); VAR i,j : INTEGER; BEGIN i := 0; j := LEN(x); WriteChar("'"); WHILE (i < j) & (x[i] # 0X) DO WriteChar(x[i]); INC(i) END; WriteChar("'"); WriteLn END Print; BEGIN Strings.Append("Hello...", buf); Strings.Append(" World!", buf); Print(buf); Strings.Insert("cruel", 8, buf); Print(buf); Strings.Delete(buf, 8, Strings.Length("cruel")); l := Strings.Pos("Worl", buf, 0); Strings.Extract(buf, l, 5, tmp); Strings.Cap(tmp); Print(tmp); Strings.Replace(tmp, l, buf); Print(buf); buf[0] := 0X; tmp[0] := 0X; Strings.Append("Hello...", buf0); Strings.Append(" World!", buf0); Print(buf0); Strings.Insert("cruel", 8, buf0); Print(buf0); Strings.Delete(buf0, 8, Strings.Length("cruel")); l := Strings.Pos("Worl", buf0, 0); Strings.Extract(buf0, l, 5, tmp); Strings.Cap(tmp); Print(tmp); Strings.Replace(tmp, l, buf0); Print(buf0); Strings.Append("Hello...", buf); Strings.Append(" World!", buf); Print(buf); Strings.Insert("cruel", 8, buf); Print(buf); Strings.Delete(buf, 8, Strings.Length("cruel")); l := Strings.Pos("Worl", buf, 0); Strings.Extract(buf, l, 5, tmp0); Strings.Cap(tmp0); Print(tmp0); Strings.Replace(tmp0, l, buf); Print(buf); Strings.Append("Hello...", buf0); Strings.Append(" World!", buf0); Print(buf0); Strings.Insert("cruel", 8, buf0); Print(buf0); Strings.Delete(buf0, 8, Strings.Length("cruel")); l := Strings.Pos("Worl", buf0, 0); Strings.Extract(buf0, l, 5, tmp0); Strings.Cap(tmp0); Print(tmp0); Strings.Replace(tmp0, l, buf0); Print(buf0); Strings.Copy("House", buf0); Print(buf0); Strings.Copy("House", buf); Print(buf); buf2[0] := "A"; buf2[1] := "B"; Print(buf2); Strings.Copy("House", buf2); Print(buf2); Strings.AppendChar("$", buf0); Print(buf0); Strings.AppendChar("$", buf2); Print(buf2); Strings.AppendChar("$", buf); Print(buf); buf3[0] := 0X; Strings.AppendInt(-2, -1, buf3); Print(buf3); (* '-2' *) buf3[0] := 0X; Strings.AppendInt(-2, 0, buf3); Print(buf3); (* '-2' *) buf3[0] := 0X; Strings.AppendInt(-2, 1, buf3); Print(buf3); (* '-2' *) buf3[0] := 0X; Strings.AppendInt(-2, 2, buf3); Print(buf3); (* '-2' *) buf3[0] := 0X; Strings.AppendInt(2, -1, buf3); Print(buf3); (* '2' *) buf3[0] := 0X; Strings.AppendInt(2, 0, buf3); Print(buf3); (* '2' *) buf3[0] := 0X; Strings.AppendInt(2, 1, buf3); Print(buf3); (* '2' *) buf3[0] := 0X; Strings.AppendInt(2, 2, buf3); Print(buf3); (* ' 2' *) buf3[0] := 0X; Strings.AppendInt(20, -1, buf3); Print(buf3); (* '20' *) buf3[0] := 0X; Strings.AppendInt(20, 0, buf3); Print(buf3); (* '20' *) buf3[0] := 0X; Strings.AppendInt(20, 1, buf3); Print(buf3); (* '20' *) buf3[0] := 0X; Strings.AppendInt(20, 2, buf3); Print(buf3); (* '20' *) buf3[0] := 0X; Strings.AppendInt(-20, -1, buf3); Print(buf3); (* '' *) buf3[0] := 0X; Strings.AppendInt(-20, 0, buf3); Print(buf3); (* '' *) buf3[0] := 0X; Strings.AppendInt(-20, 1, buf3); Print(buf3); (* '' *) buf3[0] := 0X; Strings.AppendInt(-20, 2, buf3); Print(buf3); (* '' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-2, -1, buf8); Print(buf8); (* 'XXXXX-2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-2, 0, buf8); Print(buf8); (* 'XXXXX-2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-2, 1, buf8); Print(buf8); (* 'XXXXX-2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-2, 2, buf8); Print(buf8); (* 'XXXXX-2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(2, -1, buf8); Print(buf8); (* 'XXXXX2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(2, 0, buf8); Print(buf8); (* 'XXXXX2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(2, 1, buf8); Print(buf8); (* 'XXXXX2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(2, 2, buf8); Print(buf8); (* 'XXXXX 2' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(20, -1, buf8); Print(buf8); (* 'XXXXX20' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(20, 0, buf8); Print(buf8); (* 'XXXXX20' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(20, 1, buf8); Print(buf8); (* 'XXXXX20' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(20, 2, buf8); Print(buf8); (* 'XXXXX20' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-20, -1, buf8); Print(buf8); (* 'XXXXX' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-20, 0, buf8); Print(buf8); (* 'XXXXX' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-20, 1, buf8); Print(buf8); (* 'XXXXX' *) Strings.Copy("XXXXX", buf8); Strings.AppendInt(-20, 2, buf8); Print(buf8); (* 'XXXXX' *) Strings.AppendInt(80000000H, 1, buf); Print(buf); l := Strings.Write("Hello", buf, 0); l := Strings.Write("... World!", buf, l); l := Strings.WriteInt(2, 2, buf, l); l := Strings.WriteChar("$", buf, l); Print(buf); (* 'Hello... World! 2$'*) WriteInt(l); WriteLn; l := Strings.WriteInt(2, 2, buf2, 0); WriteInt(l); (* -1 *) l := Strings.WriteChar("$", buf2, 1); WriteInt(l); (* -1 *) WriteLn; l := Strings.Write("Hello", buf2, 0); Print(buf2); WriteInt(l); WriteLn; l := Strings.Write("World", buf2, 2); Print(buf2); WriteInt(l) END TestStringsMod. ================================================ FILE: tests/base/TestStringsMod.txt ================================================ 'Hello... World!' 'Hello...cruel World!' 'WORLD' 'Hello... WORLD!' '' '' '' '' 'Hello... World!' 'Hello...cruel World!' '' 'Hello... World!' '' '' '' '' '' 'House' 'AB' 'H' '' 'H' 'House$' '-2' '-2' '-2' '-2' '2' '2' '2' ' 2' '20' '20' '20' '20' '' '' '' '' 'XXXXX-2' 'XXXXX-2' 'XXXXX-2' 'XXXXX-2' 'XXXXX2' 'XXXXX2' 'XXXXX2' 'XXXXX 2' 'XXXXX20' 'XXXXX20' 'XXXXX20' 'XXXXX20' 'XXXXX' 'XXXXX' 'XXXXX' 'XXXXX' 'House$ -2147483648' 'Hello... World! 2$' 18 -1 -1 'H' -1 'H' -1 ================================================ FILE: tests/base/TestSystemVal.Mod ================================================ MODULE TestSystemVal; IMPORT SYSTEM; TYPE pR0 = POINTER TO R0; pR1 = POINTER TO R1; R0 = RECORD x: INTEGER END; R1 = RECORD(R0) y: INTEGER END; VAR a, b, c, i: INTEGER; r: REAL; p0: pR0; p1, p: pR1; byte, byte1: BYTE; BEGIN (* converting INTEGER to BYTE and vice versa *) c := 257; byte := SYSTEM.VAL(BYTE, c); WriteInt(byte); (* 1 *) byte := 8; c := SYSTEM.VAL(INTEGER, byte); WriteInt(c); (* 8 *) c := 257; i := SYSTEM.VAL(INTEGER, c); WriteInt(i); (* 257 *) byte := 8; byte1 := SYSTEM.VAL(BYTE, byte); WriteInt(byte1); (* 8 *) WriteLn; (* converting SET to INTEGER and vice versa *) b := SYSTEM.VAL(INTEGER, {0, 5}); c := SYSTEM.VAL(INTEGER, {1..4}); a := SYSTEM.VAL(INTEGER, SYSTEM.VAL(SET, b) + SYSTEM.VAL(SET, c)); IF 2 IN SYSTEM.VAL(SET, a) THEN WriteInt(a); (* 63 *) WriteChar(CHR(a)); (* ? *) END; (* converting REAL to INTEGER and back *) i := 8; r := SYSTEM.VAL(REAL, i); WriteReal(r); i := SYSTEM.VAL(INTEGER, r); WriteInt(i); WriteLn; (* converting extension types *) NEW(p1); p1.y := 25; p0 := p1; p := SYSTEM.VAL(pR1, p0); WriteInt(p.y); (* 25 *) NEW(p1); p1.y := 26; p := SYSTEM.VAL(pR1, p1); WriteInt(p.y) (* 26 *) END TestSystemVal. ================================================ FILE: tests/base/TestSystemVal.txt ================================================ 1 8 257 8 63? 0.000000 8 25 26 ================================================ FILE: tests/base/TestTypeConvFun.Mod ================================================ MODULE TestTypeConvFun; CONST c2 = "A"; VAR x : REAL; y : INTEGER; c : CHAR; b : BOOLEAN; s : SET; PROCEDURE stackSize(r: REAL); VAR i: INTEGER; BEGIN i := FLOOR(r) END stackSize; BEGIN x := 8.9; y := 6; c := "A"; b := TRUE; s := {1}; WriteInt(FLOOR(8.9)); WriteInt(FLOOR(x)); WriteReal(FLT(6)); WriteReal(FLT(y)); WriteInt(ORD(c)); WriteInt(ORD(c2)); WriteInt(ORD("A")); WriteInt(ORD(b)); WriteInt(ORD(s)); WriteInt(ORD("A") + 1); WriteChar(CHR(ORD(c) + 1)); c := CHR(ORD(c) + 2); WriteChar(c); END TestTypeConvFun. ================================================ FILE: tests/base/TestTypeConvFun.txt ================================================ 8 8 6.000000 6.000000 65 65 65 1 2 66BC ================================================ FILE: tests/base/TestTypeGuardExt.Mod ================================================ MODULE TestTypeGuardExt; IMPORT ExtTypes; VAR p0: ExtTypes.pR0; p1, p: ExtTypes.pR1; BEGIN NEW(p1); p1.y := 25; p0 := p1; p := p0(ExtTypes.pR1); WriteInt(p.y); (* 25 *) NEW(p1); p1.y := 26; p := p1(ExtTypes.pR1); WriteInt(p.y) (* 26 *) END TestTypeGuardExt. ================================================ FILE: tests/base/TestTypeGuardExt.txt ================================================ 25 26 ================================================ FILE: tests/base/TestTypeTest.Mod ================================================ MODULE TestTypeTest; TYPE G1 = POINTER TO G1Desc; G1Desc = RECORD next: G1; next2: ARRAY 1 OF G1 END; G2 = POINTER TO G2Desc; G2Desc = RECORD(G1Desc) x: CHAR END; VAR g2: G2; g2Desc: G2Desc; PROCEDURE L(g: G1): G1; RETURN g END L; PROCEDURE P1(g: G1); VAR b: BOOLEAN; i: INTEGER; BEGIN i := 0; b := g IS G1; WriteInt(ORD(b)); b := g IS G2; WriteInt(ORD(b)); b := g.next IS G1; WriteInt(ORD(b)); b := g.next IS G2; WriteInt(ORD(b)); b := g.next.next.next IS G1; WriteInt(ORD(b)); b := g.next.next.next IS G2; WriteInt(ORD(b)); b := g.next2[i*3].next.next.next IS G1; WriteInt(ORD(b)); b := g.next2[i*3].next.next.next IS G2; WriteInt(ORD(b)); b := g.next.next.next2[i*3].next IS G1; WriteInt(ORD(b)); b := g.next.next.next2[i*3].next IS G2; WriteInt(ORD(b)); b := g.next.next.next.next2[i*3] IS G1; WriteInt(ORD(b)); b := g.next.next.next.next2[i*3] IS G2; WriteInt(ORD(b)); b := L(g) IS G1; WriteInt(ORD(b)); b := L(g) IS G2; WriteInt(ORD(b)) END P1; PROCEDURE P2(VAR g: G1Desc); VAR b: BOOLEAN; BEGIN b := g IS G1Desc; WriteInt(ORD(b)); b := g IS G2Desc; WriteInt(ORD(b)) END P2; BEGIN NEW(g2); g2.next := g2; g2.next.next2[0] := g2; P1(g2); g2Desc.next := g2; g2Desc.next.next2[0] := g2; P2(g2Desc) END TestTypeTest. ================================================ FILE: tests/base/TestTypeTest.txt ================================================ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ================================================ FILE: tests/base/UTF8String.Mod ================================================ MODULE UTF8String; VAR x : ARRAY 15 OF CHAR; i: INTEGER; (* Comments can contain UTF8 chars: 世 界, and (* can be (* nested *) *) *) BEGIN x := "Hello, 世 界 - Ʉ"; i := 0; WHILE (i < LEN(x)) & (x[i] # 0X) DO WriteChar(x[i]); INC(i) END END UTF8String. ================================================ FILE: tests/base/UTF8String.txt ================================================ Hello, 世 界 - Ʉ ================================================ FILE: tests/base/UniqueTypeAndProcNames.Mod ================================================ MODULE UniqueTypeAndProcNames; TYPE T = RECORD a: INTEGER END; PROCEDURE P1(i: INTEGER); TYPE T = RECORD b: CHAR END; PROCEDURE P2(j: INTEGER); TYPE T2 = RECORD b: ARRAY 2, 2 OF CHAR END; PROCEDURE P3(j: INTEGER); VAR x: T2; BEGIN x.b[1][1] := "F"; WriteChar(x.b[1][1]) END P3; BEGIN WriteChar("E"); P3(3) END P2; BEGIN WriteChar("D"); P2(2) END P1; PROCEDURE P0(i: INTEGER); TYPE T = RECORD b: REAL END; PROCEDURE P2(j: INTEGER); TYPE T2 = RECORD b: ARRAY 3, 3 OF CHAR END; PROCEDURE P3(j: INTEGER); VAR x: T2; BEGIN x.b[2][2] := "C"; WriteChar(x.b[2][2]) END P3; BEGIN WriteChar("B"); P3(3) END P2; BEGIN WriteChar("A"); P2(2) END P0; BEGIN P0(1); WriteLn; P1(1) END UniqueTypeAndProcNames. ================================================ FILE: tests/base/UniqueTypeAndProcNames.txt ================================================ ABC DEF ================================================ FILE: tests/base/VarInit.Mod ================================================ MODULE VarInit; IMPORT SYSTEM; TYPE R = RECORD x : INTEGER END; VAR x0 : INTEGER; x1 : BOOLEAN; x2 : SET; x3 : BYTE; x4 : REAL; x5 : CHAR; x6 : R; y0 : ARRAY 1 OF INTEGER; y1 : ARRAY 1 OF BOOLEAN; y2 : ARRAY 1 OF SET; y3 : ARRAY 1 OF BYTE; y4 : ARRAY 1 OF REAL; y5 : ARRAY 1 OF CHAR; y6 : ARRAY 1 OF R; PROCEDURE P; VAR x0 : INTEGER; x1 : BOOLEAN; x2 : SET; x3 : BYTE; x4 : REAL; x5 : CHAR; x6 : R; y0 : ARRAY 1 OF INTEGER; y1 : ARRAY 1 OF BOOLEAN; y2 : ARRAY 1 OF SET; y3 : ARRAY 1 OF BYTE; y4 : ARRAY 1 OF REAL; y5 : ARRAY 1 OF CHAR; y6 : ARRAY 1 OF R; BEGIN WriteInt(x0); IF ~x1 THEN WriteInt(0) END; WriteInt(SYSTEM.VAL(INTEGER, x2)); WriteInt(x3); WriteReal(x4); WriteInt(ORD(x5)); WriteInt(x6.x); WriteLn; WriteInt(y0[0]); IF ~y1[0] THEN WriteInt(0) END; WriteInt(SYSTEM.VAL(INTEGER, y2[0])); WriteInt(y3[0]); WriteReal(y4[0]); WriteInt(ORD(y5[0])); WriteInt(y6[0].x); WriteLn; x0 := 8; WriteInt(x0); x1 := TRUE; IF x1 THEN WriteInt(1) END; x2 := {8}; WriteInt(SYSTEM.VAL(INTEGER, x2)); x3 := 8; WriteInt(x3); x4 := 8.0; WriteReal(x4); x5 := 8X; WriteInt(ORD(x5)); x6.x := 8; WriteInt(x6.x); WriteLn; y0[0] := 8; WriteInt(y0[0]); y1[0] := TRUE; IF y1[0] THEN WriteInt(1) END; y2[0] := {8}; WriteInt(SYSTEM.VAL(INTEGER, y2[0])); y3[0] := 8; WriteInt(y3[0]); y4[0] := 8.0; WriteReal(y4[0]); y5[0] := 8X; WriteInt(ORD(y5[0])); y6[0].x := 8; WriteInt(y6[0].x); END P; BEGIN x0 := 0; WriteInt(x0); x1 := FALSE; IF ~x1 THEN WriteInt(0) END; x2 := {}; WriteInt(SYSTEM.VAL(INTEGER, x2)); x3 := 0; WriteInt(x3); x4 := 0.0; WriteReal(x4); x5 := 0X; WriteInt(ORD(x5)); x6.x := 0; WriteInt(x6.x); WriteLn; y0[0] := 0; WriteInt(y0[0]); y1[0] := FALSE; IF ~y1[0] THEN WriteInt(0) END; y2[0] := {}; WriteInt(SYSTEM.VAL(INTEGER, y2[0])); y3[0] := 0; WriteInt(y3[0]); y4[0] := 0.0; WriteReal(y4[0]); y5[0] := 0X; WriteInt(ORD(y5[0])); y6[0].x := 0; WriteInt(y6[0].x); WriteLn; P; END VarInit. ================================================ FILE: tests/base/VarInit.txt ================================================ 0 0 0 0 0.000000 0 0 0 0 0 0 0.000000 0 0 0 0 0 0 0.000000 0 0 0 0 0 0 0.000000 0 0 8 1 256 8 8.000000 8 8 8 1 256 8 8.000000 8 8 ================================================ FILE: tests/base/VarParGuard.Mod ================================================ MODULE VarParGuard; TYPE P0 = POINTER TO R0; P1 = POINTER TO R1; R0 = RECORD x: INTEGER END; R1 = RECORD(R0) y: ARRAY 10 OF R0; z: INTEGER; END; VAR p0: P0; p1: P1; PROCEDURE Proc(VAR p1: P1); BEGIN p1.x := p1.x + p1.z END Proc; PROCEDURE ProcInt(VAR c: INTEGER); BEGIN c := 6 END ProcInt; PROCEDURE Proc1(VAR p0: P0); BEGIN Proc(p0(P1)) END Proc1; PROCEDURE Proc2; VAR p0: P0; p1: P1; BEGIN NEW(p1); p0 := p1; p0.x := 1; p0(P1).z := 4; Proc(p0(P1)); WriteInt(p0.x) END Proc2; PROCEDURE Proc3; VAR p0: P0; p1: P1; i: BYTE; BEGIN i := 2; NEW(p1); p0 := p1; p0(P1).y[1+i].x := 1; ProcInt(p0(P1).y[1+i].x); WriteInt(p0(P1).y[1+i].x); END Proc3; PROCEDURE Proc4; VAR p0: ARRAY 5 OF P0; p1: P1; i: BYTE; BEGIN i := 2; NEW(p1); p0[1+i] := p1; p0[1+i].x := 1; p0[1+i](P1).z := 6; Proc(p0[1+i](P1)); WriteInt(p0[1+i].x) END Proc4; PROCEDURE Proc5; VAR r: RECORD a: P0 END; p1: P1; BEGIN NEW(p1); r.a := p1; r.a.x := 1; r.a(P1).z := 7; Proc(r.a(P1)); WriteInt(r.a.x) END Proc5; PROCEDURE Proc6; VAR r: RECORD a: ARRAY 5 OF P0 END; p1: P1; i: BYTE; BEGIN i := 2; NEW(p1); r.a[1+i] := p1; r.a[1+i].x := 1; r.a[1+i](P1).z := 8; Proc(r.a[1+i](P1)); WriteInt(r.a[1+i].x) END Proc6; BEGIN NEW(p1); p0 := p1; p0.x := 1; p0(P1).z := 2; Proc(p0(P1)); WriteInt(p0.x); p0.x := 1; p0(P1).z := 3; Proc1(p0); WriteInt(p0.x); Proc2; Proc3; Proc4; Proc5; Proc6 END VarParGuard. ================================================ FILE: tests/base/VarParGuard.txt ================================================ 3 4 5 6 7 8 9