Showing preview only (448K chars total). Download the full file or copy to clipboard to get everything.
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:
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,
"<init>", "()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, "<init>",
"()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,
"<init>", "()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, "<init>",
"()V");
clearCtx(topCtx);
ClassFormat.putVarInsn(topCtx.m, Opcodes.ALOAD, 0);
internalName(signature, iname);
ClassFormat.putMethodInsn(topCtx.m, Opcodes.INVOKESPECIAL, iname, "<init>",
"()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, "<clinit>",
"()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", "<init>",
"(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, "<clinit>",
"()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;
PROC
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
SYMBOL INDEX (113 symbols across 9 files)
FILE: examples/fern/java/XYplane.java
class XYplane (line 10) | public final class XYplane {
method XYplane (line 20) | private XYplane() {}
method Open (line 22) | public static void Open() {
method Dot (line 34) | public static void Dot(int x, int y, int mode) {
method isDot (line 44) | public static boolean isDot(int x, int y) {
method Key (line 49) | public static char Key() {
method Clear (line 53) | public static void Clear() {
class Viewer (line 57) | private static class Viewer extends JPanel {
method Viewer (line 60) | public Viewer(int width, int height) {
method getPreferredSize (line 67) | public Dimension getPreferredSize() {
method paintComponent (line 71) | public void paintComponent(Graphics g) {
method fillCanvas (line 77) | public void fillCanvas(int color) {
FILE: src/java/Files.java
class Files (line 14) | public final class Files {
method Files (line 22) | private Files() {}
method Status (line 24) | public static int Status(Files_FileDesc file) {
method Rename (line 28) | public static int Rename(char[] from, char[] to) {
method Exists (line 39) | public static boolean Exists(char[] name) {
method Delete (line 49) | public static int Delete(char[] name) {
method Create (line 63) | public static Files_FileDesc Create(char[] name) {
method open (line 67) | private static Files_FileDesc open(char[] name, String mode,
method Open (line 85) | public static Files_FileDesc Open(char[] name) {
method Close (line 89) | public static void Close(Files_FileDesc file) {
method toStr (line 97) | private static String toStr(char[] name) {
method WriteAsciiStr (line 109) | public static void WriteAsciiStr(Files_FileDesc file, char[] str) {
method WriteStr (line 121) | public static void WriteStr(Files_FileDesc file, char[] str) {
method Write (line 133) | public static void Write(Files_FileDesc file, byte b) {
method WriteChar (line 143) | public static void WriteChar(Files_FileDesc file, char c) {
method WriteBytes (line 159) | public static void WriteBytes(Files_FileDesc file, byte[] b) {
method WriteNBytes (line 169) | public static void WriteNBytes(Files_FileDesc file, byte[] b, int len) {
method WriteInt (line 180) | public static void WriteInt(Files_FileDesc file, int x) {
method WriteNum (line 221) | public static void WriteNum(Files_FileDesc file, int x) {
method ReadNum (line 306) | public static int ReadNum(Files_FileDesc file) {
method Read (line 324) | public static byte Read(Files_FileDesc file) {
method ReadChar (line 332) | public static char ReadChar(Files_FileDesc file) {
method read (line 377) | private static int read(Files_FileDesc file) {
method ReadBytes (line 393) | public static void ReadBytes(Files_FileDesc file, byte[] b, int[] n) {
method ReadInt (line 407) | public static int ReadInt(Files_FileDesc file) {
method ReadAsciiStr (line 414) | public static void ReadAsciiStr(Files_FileDesc file, char[] str) {
method ReadStr (line 429) | public static int ReadStr(Files_FileDesc file, char[] str) {
method Seek (line 446) | public static int Seek(Files_FileDesc file, int pos) {
method Size (line 460) | public static int Size(Files_FileDesc file) {
FILE: src/java/Files_FileDesc.java
class Files_FileDesc (line 9) | public class Files_FileDesc {
method Files_FileDesc (line 12) | public Files_FileDesc() {}
method copy (line 14) | public Files_FileDesc copy() {
FILE: src/java/In.java
class In (line 9) | public final class In {
method In (line 15) | private In() {}
method Char (line 23) | static public void Char(char[] ch) {
method String (line 37) | static public void String(char[] str) {
method Real (line 59) | static public void Real(float[] x) {
method Int (line 68) | static public void Int(int[] i) {
FILE: src/java/Math.java
class Math (line 7) | public final class Math {
method Math (line 12) | private Math() {}
method sqrt (line 14) | public static float sqrt(float x) {
method power (line 18) | public static float power(float x, float base) {
method exp (line 22) | public static float exp(float x) {
method ln (line 26) | public static float ln(float x) {
method log (line 30) | public static float log(float x, float b) {
method round (line 34) | public static float round(float x) {
method sin (line 38) | public static float sin(float x) {
method cos (line 42) | public static float cos(float x) {
method tan (line 46) | public static float tan(float x) {
method arcsin (line 50) | public static float arcsin(float x) {
method arccos (line 54) | public static float arccos(float x) {
method arctan (line 58) | public static float arctan(float x) {
method arctan2 (line 62) | public static float arctan2(float x, float y) {
method sinh (line 66) | public static float sinh(float x) {
method cosh (line 70) | public static float cosh(float x) {
method tanh (line 74) | public static float tanh(float x) {
method arcsinh (line 78) | public static float arcsinh(float x) {
method arccosh (line 83) | public static float arccosh(float x) {
method arctanh (line 88) | public static float arctanh(float x) {
FILE: src/java/OberonRuntime.java
class OberonRuntime (line 10) | public final class OberonRuntime {
method OberonRuntime (line 13) | private OberonRuntime() {}
method DIV (line 32) | public static int DIV(int x, int y) {
method MOD (line 45) | public static int MOD(int x, int y) {
method ASR (line 57) | public static int ASR(int x, int n) {
method ROR (line 62) | public static int ROR(int x, int n) {
method StrCmp (line 67) | public static int StrCmp(char[] s0, char[] s1) {
method ARGS (line 85) | public static void ARGS(String[] args, int i, char[] out) {
method ReadInt (line 100) | public static int ReadInt() {
method WriteInt (line 121) | public static void WriteInt(int num) {
method WriteReal (line 129) | public static void WriteReal(float num) {
method WriteChar (line 133) | public static void WriteChar(int c) {
method WriteLn (line 137) | public static void WriteLn() {
method eot (line 141) | public static boolean eot() {
FILE: src/java/Os.java
class Os (line 7) | public final class Os {
method Os (line 12) | private Os() {}
method toString (line 14) | private static String toString(char[] name) {
method GetEnv (line 24) | public static void GetEnv(char[] out, char[] name) {
method CurrentTime (line 42) | public static int CurrentTime() {
method Exit (line 46) | public static void Exit(int status) {
FILE: src/java/Out.java
class Out (line 10) | public final class Out {
method Out (line 13) | private Out() {}
method Char (line 24) | public static void Char(char ch) {
method String (line 28) | public static void String(char[] str) {
method Real (line 37) | public static void Real(float x, int n) {
method Int (line 45) | public static void Int(int x, int n) {
method Ln (line 53) | public static void Ln() {
method Hex (line 57) | public static void Hex(int x) {
FILE: tests/TestRunner.java
class TestRunner (line 8) | public class TestRunner {
method main (line 12) | public static void main(String[] args) {
method check (line 60) | private static void check(int[] tot, int[] successful, int[] failed,
method testImports (line 70) | private static void testImports(int[] tot, int[] successful, int[] fai...
method testCyclicImports (line 105) | private static void testCyclicImports(int[] tot, int[] successful,
method testWithInputs (line 125) | private static void testWithInputs(int[] tot, int[] successful,
method testTypeGuardExt (line 143) | private static void testTypeGuardExt(int[] tot, int[] successful,
method assertEquals (line 149) | private static boolean assertEquals(String name, String expected, Stri...
method compileAndRunArgs (line 160) | private static boolean compileAndRunArgs(String name, String input,
method compile (line 196) | private static int compile(String name, boolean newSym) {
method compileAndRunWithInput (line 202) | private static boolean compileAndRunWithInput(String name, String inpu...
method compileAndRun (line 206) | private static boolean compileAndRun(String name) {
method compileAndFail (line 210) | private static boolean compileAndFail(String name, int errors, String ...
method getExpectedOutput (line 236) | private static String getExpectedOutput(String name) {
Condensed preview — 322 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (429K chars).
[
{
"path": "LICENSE.txt",
"chars": 1068,
"preview": "MIT License\n\nCopyright (c) 2017 Luca Boasso\n\nPermission is hereby granted, free of charge, to any person obtaining a cop"
},
{
"path": "Makefile",
"chars": 1647,
"preview": ".POSIX:\n.SUFFIXES:\n\nJAVA_SOURCES = src/java/Files_FileDesc.java src/java/Files.java \\\n src/java/OberonRunt"
},
{
"path": "README.md",
"chars": 4744,
"preview": "\n# Oberon-07 compiler\n\n`oberonc` is a single pass, self-hosting compiler for the\n[Oberon-07](https://en.wikipedia.org/wi"
},
{
"path": "doc/TypeRules.md",
"chars": 3827,
"preview": "# Type rules\n\n## Same types [A]\nTwo variables *a* and *b* with types *Ta* and *Tb* are of the *same* type if\n1. *Ta* and"
},
{
"path": "doc/oberon07.g",
"chars": 3857,
"preview": "// ANTLR v3 grammar\ngrammar oberon07;\n\n// LL(1) with few ambiguities resolved with the help of the symbol table\noptions "
},
{
"path": "examples/GuessNumber.Mod",
"chars": 1090,
"preview": "MODULE GuessNumber;\n IMPORT In, Out;\n VAR\n name: ARRAY 20 OF CHAR;\n number, left, right, old: INTEGER;\n choic"
},
{
"path": "examples/Hello.Mod",
"chars": 144,
"preview": "MODULE Hello;\n IMPORT Out; (* Import Out to print on the console *)\nBEGIN\n Out.String(\"Hello 世界\");\n Out.Ln (* print a"
},
{
"path": "examples/Powers.Mod",
"chars": 1433,
"preview": "MODULE Powers; (*Tabulate positive and negative powers of 2*)\n IMPORT Out, Util;\n CONST N = 32; M = 11; (*M ~ N*log2"
},
{
"path": "examples/PrimeNumbers.Mod",
"chars": 1121,
"preview": "MODULE PrimeNumbers; (*Tabulate prime numbers*)\n IMPORT Out, Util;\n\n PROCEDURE Primes(n: INTEGER);\n VAR i, k, m, x"
},
{
"path": "examples/Util.Mod",
"chars": 292,
"preview": "MODULE Util;\n\n PROCEDURE strToInt*(str: ARRAY OF CHAR): INTEGER;\n VAR res, i, x: INTEGER;\n BEGIN\n res := 0;\n "
},
{
"path": "examples/fern/IFS.Mod",
"chars": 1848,
"preview": "MODULE IFS;\n IMPORT RandomNumbers, XYplane;\n\n VAR\n a1, b1, c1, d1, e1, f1, p1: REAL; (* IFS parameters *)\n a2"
},
{
"path": "examples/fern/RandomNumbers.Mod",
"chars": 521,
"preview": "MODULE RandomNumbers;\n IMPORT Math;\n\n VAR Z: INTEGER;\n\n PROCEDURE Uniform*(): REAL;\n CONST\n a = 16807; m = 2"
},
{
"path": "examples/fern/XYplane.Mod",
"chars": 234,
"preview": "DEFINITION XYplane; \n CONST erase = 0; draw = 1;\n VAR X, Y, W, H: INTEGER;\n\n PROCEDURE Open;\n PROCEDURE Dot(x, y, m"
},
{
"path": "examples/fern/java/XYplane.java",
"chars": 2148,
"preview": "import java.awt.Color;\nimport java.awt.Dimension;\nimport java.awt.Graphics;\nimport java.awt.Graphics2D;\nimport java.awt."
},
{
"path": "make.bat",
"chars": 1442,
"preview": "@echo off\r\n\r\nset JAVA_SOURCES=src/java/Files_FileDesc.java src/java/Files.java src/java/OberonRuntime.java src/java/Os.j"
},
{
"path": "src/ClassFormat.Mod",
"chars": 23568,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/CpCache.Mod",
"chars": 1664,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/Files.Mod",
"chars": 1526,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/In.Mod",
"chars": 804,
"preview": "(*\n Copyright 2019 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/Math.Mod",
"chars": 2803,
"preview": "(*\n Copyright 2020 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/OJB.Mod",
"chars": 22188,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/OJG.Mod",
"chars": 84095,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/OJP.Mod",
"chars": 52395,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Copyright (C)2013 Niklaus Wirth (NW), Juerg Gutknecht (JG),\n Paul Reed (PR/PDR).\n U"
},
{
"path": "src/OJS.Mod",
"chars": 14660,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Copyright (C)2013 Niklaus Wirth (NW), Juerg Gutknecht (JG),\n Paul Reed (PR/PDR).\n U"
},
{
"path": "src/Opcodes.Mod",
"chars": 2268,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/Os.Mod",
"chars": 442,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/Out.Mod",
"chars": 394,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/Strings.Mod",
"chars": 9199,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/Files.java",
"chars": 12689,
"preview": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/Files_FileDesc.java",
"chars": 412,
"preview": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/In.java",
"chars": 1402,
"preview": "/*\n Copyright 2019 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/Math.java",
"chars": 2226,
"preview": "/*\n Copyright 2020 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/OberonRuntime.java",
"chars": 3209,
"preview": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/Os.java",
"chars": 1069,
"preview": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/java/Out.java",
"chars": 1216,
"preview": "/*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "src/oberonc.Mod",
"chars": 1439,
"preview": "(*\n Copyright 2017 Luca Boasso.\n Use of this source code is governed by a MIT\n license that can be found in the LICEN"
},
{
"path": "tests/TestRunner.java",
"chars": 9818,
"preview": "import java.io.ByteArrayInputStream;\nimport java.io.ByteArrayOutputStream;\nimport java.io.File;\nimport java.io.InputStre"
},
{
"path": "tests/base/ArrayAssignment.Mod",
"chars": 2009,
"preview": "MODULE ArrayAssignment;\n TYPE\n arr2 = ARRAY 2 OF INTEGER;\n multy = ARRAY 2, 4 OF INTEGER;\n R = RECORD\n "
},
{
"path": "tests/base/ArrayAssignment.txt",
"chars": 88,
"preview": " 5 5 7 7 6 8 5 5 10 11 11 12 15 15 16 25 25 26 77 77 66 88"
},
{
"path": "tests/base/ArrayConstantSize.Mod",
"chars": 94,
"preview": "MODULE ArrayConstantSize;\n VAR N: INTEGER;\n e: ARRAY 2*N OF CHAR;\nEND ArrayConstantSize."
},
{
"path": "tests/base/Arrays2.Mod",
"chars": 564,
"preview": "MODULE Arrays2;\n TYPE X = ARRAY 1 OF INTEGER;\n VAR\n a : X;\n b : ARRAY 1 OF INTEGER;\n (*i : ARRAY 3, "
},
{
"path": "tests/base/Arrays2.txt",
"chars": 20,
"preview": " 2 8 9 3 3"
},
{
"path": "tests/base/Arrays3.Mod",
"chars": 1169,
"preview": "MODULE Arrays3;\n TYPE ARR = ARRAY 3 OF INTEGER;\n ARR2 = ARRAY 3, 2 OF INTEGER;\n VAR\n x : ARRAY 3 OF INTEGER;\n"
},
{
"path": "tests/base/Arrays3.txt",
"chars": 20,
"preview": " 88 1 8 8 9"
},
{
"path": "tests/base/BitFunc.Mod",
"chars": 1707,
"preview": "MODULE BitFunc;\n VAR x: ARRAY 18 OF BYTE;\n i: INTEGER;\n ch: CHAR;\n\n PROCEDURE next(in: ARRAY OF BYTE; VAR i:"
},
{
"path": "tests/base/BitFunc.txt",
"chars": 43,
"preview": "A 65\nД 1044\nа 1072\n€ 8364\n世 19990\n界 30028\n"
},
{
"path": "tests/base/CaseChar0.Mod",
"chars": 333,
"preview": "MODULE CaseChar0;\n CONST C = \"C\";\n VAR i, a : CHAR;\nBEGIN\n i := \"B\";\n CASE i OF\n \"A\"..\"C\", \"Z\":\n a := \"1\"; \n"
},
{
"path": "tests/base/CaseChar0.txt",
"chars": 2,
"preview": "15"
},
{
"path": "tests/base/CaseNum0.Mod",
"chars": 856,
"preview": "MODULE CaseNum0;\n VAR i, a : INTEGER;\n \n PROCEDURE P(i : INTEGER);\n VAR a : INTEGER;\n BEGIN\n CASE i OF\n "
},
{
"path": "tests/base/CaseNum0.txt",
"chars": 28,
"preview": " 2 1 2 3 -1 8 9"
},
{
"path": "tests/base/CaseNum1.Mod",
"chars": 847,
"preview": "MODULE CaseNum1;\n TYPE ARR = ARRAY 3 OF RECORD c: CHAR END;\n VAR b: ARR;\n\n PROCEDURE P(i: INTEGER);\n VAR a: INTE"
},
{
"path": "tests/base/CaseNum1.txt",
"chars": 25,
"preview": " 1 2 3 4 5 80P"
},
{
"path": "tests/base/CaseRecord0.Mod",
"chars": 820,
"preview": "MODULE CaseRecord0;\n TYPE\n R = RECORD a: INTEGER END ;\n R0 = RECORD (R) b: REAL END ;\n R1 = RECORD (R) b: INTE"
},
{
"path": "tests/base/CaseRecord0.txt",
"chars": 16,
"preview": " 1 8 9 10"
},
{
"path": "tests/base/CaseRecord1.Mod",
"chars": 423,
"preview": "MODULE CaseRecord1;\n TYPE \n R = RECORD a: INTEGER END ;\n R0 = RECORD (R) b: INTEGER END ;\n R1 = RECORD (R) b: "
},
{
"path": "tests/base/CaseRecord1.txt",
"chars": 8,
"preview": " 1 -1"
},
{
"path": "tests/base/CaseRecord2.Mod",
"chars": 838,
"preview": "MODULE CaseRecord2;\n TYPE \n P = POINTER TO R;\n P0 = POINTER TO R0;\n P1 = POINTER TO R1;\n P2 = POINTER TO R2"
},
{
"path": "tests/base/CaseRecord2.txt",
"chars": 8,
"preview": " 3 1"
},
{
"path": "tests/base/CaseRecord3.Mod",
"chars": 725,
"preview": "MODULE CaseRecord3;\n TYPE\n P = POINTER TO R;\n P0 = POINTER TO R0;\n P1 = POINTER TO R1;\n P2 = POINTER TO R2;"
},
{
"path": "tests/base/CaseRecord3.txt",
"chars": 8,
"preview": " 17 1"
},
{
"path": "tests/base/CaseRecord4.Mod",
"chars": 1021,
"preview": "MODULE CaseRecord4;\n TYPE\n A = POINTER TO ADesc;\n ADesc = RECORD\n next: A\n END;\n\n B = POINTER TO RECOR"
},
{
"path": "tests/base/CaseRecord4.txt",
"chars": 2,
"preview": "B\n"
},
{
"path": "tests/base/CommutativeSwap.Mod",
"chars": 194,
"preview": "MODULE CommutativeSwap;\n VAR i : INTEGER; a : ARRAY 10 OF INTEGER;\nBEGIN\n i := 5;\n a[i+3] := 5;\n WriteInt(1 - "
},
{
"path": "tests/base/CommutativeSwap.txt",
"chars": 8,
"preview": " 11 -3"
},
{
"path": "tests/base/ConstantFoldingAndLoadOp.Mod",
"chars": 1147,
"preview": "MODULE ConstantFoldingAndLoadOp;\n CONST con = 100;\n TYPE\n V = RECORD\n x : ARRAY 10 OF INTEGER;\n END"
},
{
"path": "tests/base/ConstantFoldingAndLoadOp.txt",
"chars": 86,
"preview": " 11 6 8 200 6 8 200\n 1 2 98 1 2 98 100 100\n 1 1 1 1 1 1"
},
{
"path": "tests/base/DivMul.Mod",
"chars": 1618,
"preview": "MODULE DivMul;\n CONST eight = 8;\n\n PROCEDURE PrintDiv(a,b : INTEGER);\n BEGIN\n WriteInt(a);\n WriteInt(b);\n Wr"
},
{
"path": "tests/base/DivMul.txt",
"chars": 249,
"preview": " 8 3 2 2\n 8 -3 -2 2\n -8 3 -3 1\n -8 -3 3 1\n 1 2 0 1\n 1 -2 0 1\n -1 2 -1 1\n "
},
{
"path": "tests/base/EmptyArrayAndRecord.Mod",
"chars": 1258,
"preview": "MODULE EmptyArrayAndRecord;\n TYPE\n EMPTY0 = RECORD END;\n EMPTY2 = RECORD e : RECORD END END;\n EMPTY3 = RECORD"
},
{
"path": "tests/base/EmptyArrayAndRecord.txt",
"chars": 4,
"preview": " 10"
},
{
"path": "tests/base/ExtTypes.Mod",
"chars": 158,
"preview": "MODULE ExtTypes;\n TYPE\n pR0* = POINTER TO R0;\n pR1* = POINTER TO R1;\n R0 = RECORD x: INTEGER END;\n R1 = REC"
},
{
"path": "tests/base/ForwardPointerRef.Mod",
"chars": 580,
"preview": "MODULE ForwardPointerRef;\n TYPE\n P0 = POINTER TO R0;\n R0 = RECORD i: INTEGER END;\n\n R1 = RECORD\n j: "
},
{
"path": "tests/base/ForwardPointerRef.txt",
"chars": 14,
"preview": " 3 4 4C\n"
},
{
"path": "tests/base/Fractions.Mod",
"chars": 760,
"preview": "MODULE Fractions; (*NW 10.10.07; Tabulate fractions 1/n*)\n CONST Base = 10; N = 32;\n \n PROCEDURE Go;\n VAR i, j,"
},
{
"path": "tests/base/Fractions.txt",
"chars": 246,
"preview": " 2\t.5'0\n 3\t.3'3\n 4\t.25'0\n 5\t.2'0\n 6\t.1'6\n 7\t.1'428571\n 8\t.125'0\n 9\t.1'1\n 10\t.1'0\n 11\t.0'90\n 12\t.08'3\n"
},
{
"path": "tests/base/FragileBaseClass.Mod",
"chars": 3513,
"preview": "MODULE FragileBaseClass;\n TYPE\n List = POINTER TO ListDesc;\n Node = POINTER TO NodeDesc;\n List2 = POINTER TO L"
},
{
"path": "tests/base/FragileBaseClass.txt",
"chars": 12,
"preview": " 2 2 4"
},
{
"path": "tests/base/MagicSquares.Mod",
"chars": 664,
"preview": "MODULE MagicSquares; (*for Oberon-0 NW 25.1.2013*)\n\n PROCEDURE Generate; (*magic square of order 3, 5, 7, ... *)\n "
},
{
"path": "tests/base/MagicSquares.txt",
"chars": 39,
"preview": " 3 8 4\n 5 1 9\n 7 6 2\n"
},
{
"path": "tests/base/OpenArrays.Mod",
"chars": 785,
"preview": "MODULE OpenArrays;\n VAR x : ARRAY 1 OF INTEGER;\n y : ARRAY 2 OF INTEGER;\n\n PROCEDURE P2(a : ARRAY OF INTEGER; V"
},
{
"path": "tests/base/OpenArrays.txt",
"chars": 12,
"preview": " 1 2 2"
},
{
"path": "tests/base/OpenArrays2.Mod",
"chars": 340,
"preview": "MODULE OpenArrays2;\n TYPE ARR = ARRAY 3 OF INTEGER;\n VAR\n x : ARR;\n i : INTEGER;\n \n PROCEDURE P1(VAR b : ARRAY"
},
{
"path": "tests/base/OpenArrays2.txt",
"chars": 16,
"preview": " 8 8 8 8"
},
{
"path": "tests/base/OpenArrays3.Mod",
"chars": 977,
"preview": "MODULE OpenArrays3;\n TYPE ARR = ARRAY 3 OF INTEGER;\n R = RECORD i : INTEGER END;\n VAR\n d : ARRAY 10 OF INTEGE"
},
{
"path": "tests/base/OpenArrays3.txt",
"chars": 25,
"preview": " 1 2 3\n 4 5 6"
},
{
"path": "tests/base/Out0.Mod",
"chars": 1043,
"preview": "MODULE Out0;\n CONST con = 100;\n TYPE\n V = RECORD x : ARRAY 10 OF INTEGER END;\n Hello = RECORD world : INTEGER; x"
},
{
"path": "tests/base/Out0.txt",
"chars": 48,
"preview": " 8 9 10 11 12 13 14 15 16 17 200 1"
},
{
"path": "tests/base/Out1.Mod",
"chars": 454,
"preview": "MODULE Out1;\n CONST con = 100;\n VAR \n a : ARRAY 4 OF INTEGER;\n b : ARRAY 3 OF ARRAY 5 OF INTEGER;\n"
},
{
"path": "tests/base/Out1.txt",
"chars": 28,
"preview": " 1 2 3 4 5 6 7"
},
{
"path": "tests/base/Out2.Mod",
"chars": 822,
"preview": "MODULE Out2;\n CONST con = 100;\n TYPE \n R0 = RECORD x, y : INTEGER END; \n R1 = RECORD u : INTEGER; \n "
},
{
"path": "tests/base/Out2.txt",
"chars": 36,
"preview": " 10 11 12 13 14 15 16 17 18"
},
{
"path": "tests/base/Out3.Mod",
"chars": 963,
"preview": "MODULE Out3;\n CONST con = 100;\n VAR \n i, j, k : INTEGER;\n o, x : BOOLEAN;\n PROCEDURE gdc(m, n : INTEG"
},
{
"path": "tests/base/Out3.txt",
"chars": 61,
"preview": " 2 3 4 5 6 7 8\n 9 10 11 12 13 14 15 4"
},
{
"path": "tests/base/Out4.Mod",
"chars": 1461,
"preview": "MODULE Out4;\n TYPE\n R0 = RECORD x, y : INTEGER END;\n R1 = RECORD r0 : R0 END;\n R8 = RECORD x : ARRAY 2 OF INTE"
},
{
"path": "tests/base/Out4.txt",
"chars": 52,
"preview": " 1 4 100 10 11 12 13 14 20 21 22 23 24"
},
{
"path": "tests/base/Out5.Mod",
"chars": 412,
"preview": "MODULE Out5;\n TYPE A = RECORD x : INTEGER END;\n VAR i: INTEGER;\n v : ARRAY 20 OF INTEGER;\n a : A;\nBEGIN \n i"
},
{
"path": "tests/base/Out5.txt",
"chars": 32,
"preview": " 10 11 12 20 21 22 23 24"
},
{
"path": "tests/base/Out6.Mod",
"chars": 498,
"preview": "MODULE Out6;\n TYPE \n R0 = RECORD x : INTEGER END; \n R1 = RECORD\n r0 : RECORD x : INTEGER END \n "
},
{
"path": "tests/base/Out6.txt",
"chars": 12,
"preview": " 20 22 24"
},
{
"path": "tests/base/OutTest.Mod",
"chars": 447,
"preview": "MODULE OutTest;\n IMPORT Out;\n VAR str: ARRAY 3 OF CHAR;\nBEGIN\n Out.Int(10, 0); Out.Ln;\n Out.String(\"Hello\");\n Out.L"
},
{
"path": "tests/base/OutTest.txt",
"chars": 18,
"preview": "10\nHello\nABC\nAB\nA\n"
},
{
"path": "tests/base/Pattern1.Mod",
"chars": 764,
"preview": "MODULE Pattern1;\nIMPORT SYSTEM;\n VAR ch: CHAR;\n k,j: INTEGER;\n x: REAL;\n s: SET;\nBEGIN\n ch := \"0\";\n Wr"
},
{
"path": "tests/base/Pattern1.txt",
"chars": 82,
"preview": " 48 10 -65536 -65537 65535 65536 65537 1.000000 273 56 56 458752 56 65528 56"
},
{
"path": "tests/base/Pattern2a.Mod",
"chars": 1559,
"preview": "MODULE Pattern2a;\n VAR i, j, k, n: INTEGER;\n x, y: REAL;\nBEGIN\n i := 1+7;\n WriteInt(i);\n j := 7;\n i := 1+j;\n "
},
{
"path": "tests/base/Pattern2a.txt",
"chars": 174,
"preview": " 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"
},
{
"path": "tests/base/Pattern2b.Mod",
"chars": 567,
"preview": "MODULE Pattern2b;\nIMPORT SYSTEM;\n VAR i, j: INTEGER;\n x, y: REAL;\n s, t: SET;\nBEGIN \n x := 1.0+7.0;\n WriteR"
},
{
"path": "tests/base/Pattern2b.txt",
"chars": 81,
"preview": " 8.000000 8.000000 8.000000 8.000000 8.000000 -8 -8 -8.000000 -8.000000 5 5"
},
{
"path": "tests/base/Pattern2c.Mod",
"chars": 959,
"preview": "MODULE Pattern2c;\nIMPORT SYSTEM;\n VAR s, t, u: SET;\nBEGIN \n s := {1, 5} + {2, 7, 4};\n WriteInt(SYSTEM.VAL(INTEGER, s)"
},
{
"path": "tests/base/Pattern2c.txt",
"chars": 48,
"preview": " 182 2 32 160 182 2 32 160 182 2 32 160"
},
{
"path": "tests/base/Permutations.Mod",
"chars": 585,
"preview": "MODULE Permutations; (*NW 22.1.2013 for Oberon-0*)\n VAR m, n: INTEGER;\n a: ARRAY 10 OF INTEGER;\n\n PROCEDURE perm(k"
},
{
"path": "tests/base/Permutations.txt",
"chars": 78,
"preview": " 3 7 11\n 7 3 11\n 11 7 3\n 7 11 3\n 3 11 7\n 11 3 7\n"
},
{
"path": "tests/base/Powers.Mod",
"chars": 1143,
"preview": "MODULE Powers; (*NW 25.1.2013 fo Oberon-07; Tabulate positive and negative powers of 2*)\n CONST N = 32; M = 11; (*M "
},
{
"path": "tests/base/Powers.txt",
"chars": 1085,
"preview": " 2 1\t0.5\n 4 2\t0.25\n 8 3\t0.125\n 16 4\t0.0625\n 32 5\t0.03125\n 6"
},
{
"path": "tests/base/PrimeNumbers.Mod",
"chars": 926,
"preview": "MODULE PrimeNumbers; (*NW 6.9.07; Tabulate prime numbers; for Oberon-07 NW 25.1.2013*)\n \n VAR n: INTEGER;\n p: ARR"
},
{
"path": "tests/base/PrimeNumbers.txt",
"chars": 79,
"preview": " 20\n 5 7 11 13 17 19 23 29 31 37 41\n 43 47 53 59 61 67 71\n"
},
{
"path": "tests/base/ProcComparisons.Mod",
"chars": 428,
"preview": "MODULE ProcComparisons;\n VAR x: BOOLEAN;\n \n PROCEDURE P2(i : INTEGER): INTEGER;\n BEGIN \n RETURN 2\n END P2;\n \n "
},
{
"path": "tests/base/ProcComparisons.txt",
"chars": 12,
"preview": " 1 2 3"
},
{
"path": "tests/base/ProcType.Mod",
"chars": 322,
"preview": "MODULE ProcType;\n TYPE\n P = PROCEDURE(x: INTEGER);\n VAR p : P;\n \n PROCEDURE I(x: INTEGER);\n BEGIN WriteInt(x)\n "
},
{
"path": "tests/base/ProcType.txt",
"chars": 8,
"preview": " 8 9"
},
{
"path": "tests/base/ProcVariables0.Mod",
"chars": 1237,
"preview": "MODULE ProcVariables0;\n TYPE \n MyFun = PROCEDURE() : INTEGER;\n R = RECORD i : INTEGER END;\n P = POINTER TO R;\n"
},
{
"path": "tests/base/ProcVariables0.txt",
"chars": 41,
"preview": " 8 7 1 2 2\n 8 7 1 2 2"
},
{
"path": "tests/base/ProcVariables1.Mod",
"chars": 599,
"preview": "MODULE ProcVariables1;\n TYPE \n R = RECORD i : INTEGER END;\n MyFun = PROCEDURE(r : R) : INTEGER;\n VAR\n a : ARR"
},
{
"path": "tests/base/ProcVariables1.txt",
"chars": 17,
"preview": " 2 3\n 2 3"
},
{
"path": "tests/base/ProcVariables2.Mod",
"chars": 1081,
"preview": "MODULE ProcVariables2;\n TYPE \n MyFun = PROCEDURE(x : INTEGER) : INTEGER;\n R = RECORD \n i : INTEGER; \n "
},
{
"path": "tests/base/ProcVariables2.txt",
"chars": 35,
"preview": " 2 3\n 2 3\n 2 3\n 2 3"
},
{
"path": "tests/base/ProcVariables3.Mod",
"chars": 449,
"preview": "MODULE ProcVariables3;\n TYPE PT = PROCEDURE (m, n: INTEGER);\n Object = POINTER TO RECORD w: INTEGER; p: PT END ;\n"
},
{
"path": "tests/base/ProcVariables3.txt",
"chars": 27,
"preview": " 1 8\n 2 8\n 3 8\n"
},
{
"path": "tests/base/ProcVariables4.Mod",
"chars": 1074,
"preview": "MODULE ProcVariables4;\n TYPE P0 = PROCEDURE(VAR x : REAL) : INTEGER;\n P1 = PROCEDURE(VAR x : REAL; VAR y : P0) : "
},
{
"path": "tests/base/ProcVariables4.txt",
"chars": 12,
"preview": " 8 9 10"
},
{
"path": "tests/base/ProcVariables5.Mod",
"chars": 665,
"preview": "MODULE ProcVariables5;\n TYPE\n T = PROCEDURE (x, y: INTEGER; z: BYTE);\n VAR\n v: T;\n i,j: INTEGER;\n\n PROCEDURE"
},
{
"path": "tests/base/ProcVariables5.txt",
"chars": 16,
"preview": " 6 7 6 7"
},
{
"path": "tests/base/ProcVariables6.Mod",
"chars": 260,
"preview": "MODULE ProcVariables6;\n TYPE\n Q = PROCEDURE (c: CHAR);\n VAR\n q: Q;\n\n PROCEDURE P0(VAR j: Q);\n PROCEDURE P1(c"
},
{
"path": "tests/base/ProcVariables6.txt",
"chars": 2,
"preview": "a\n"
},
{
"path": "tests/base/ProcVariables7.Mod",
"chars": 375,
"preview": "MODULE ProcVariables7;\n TYPE\n ProcA = PROCEDURE;\n ProcB = PROCEDURE;\n\n VAR\n a: ProcA;\n\n PROCEDURE A;\n BEGIN"
},
{
"path": "tests/base/ProcVariables7.txt",
"chars": 3,
"preview": "ABC"
},
{
"path": "tests/base/RealExpressions.Mod",
"chars": 956,
"preview": "MODULE RealExpressions;\n CONST NaN* = 0.0/0.0;\n PROCEDURE One() : REAL;\n RETURN 1.0\n END One;\n PROCEDURE Arithmet"
},
{
"path": "tests/base/RealExpressions.txt",
"chars": 60,
"preview": " 6.000000\n 1.000000\n 6.000000\n 1.500000\n 23.500000\n 4 5\n"
},
{
"path": "tests/base/RecordAndTypeExtension.Mod",
"chars": 3459,
"preview": "MODULE RecordAndTypeExtension;\n TYPE\n A = RECORD\n x : INTEGER;\n next : POINTER TO A;\n nex"
},
{
"path": "tests/base/RecordAndTypeExtension.txt",
"chars": 149,
"preview": " 0 10 11 11 13 99 11\n 8 9 10 10 8 7 15 15 10 10 1\n 1\n 1\n 1\n 1\n 1\n 0\n 1\n 1\n 0\n "
},
{
"path": "tests/base/RecordAssignment.Mod",
"chars": 1720,
"preview": "MODULE RecordAssignment;\n TYPE A = RECORD \n x : INTEGER;\n y : ARRAY 1, 2 OF INTEGER;\n "
},
{
"path": "tests/base/RecordAssignment.txt",
"chars": 139,
"preview": " 1 11 3 33\n 79 80 99.000000 100.000000\n 4.000000 44.000000 1 11 3 33 79 80 99.000000 100.000000 71 75 "
},
{
"path": "tests/base/RecordAssignment2.Mod",
"chars": 1074,
"preview": "MODULE RecordAssignment2;\n TYPE RP = POINTER TO R;\n R = RECORD\n i: INTEGER;\n a: ARRAY 10 OF RP;\n "
},
{
"path": "tests/base/RecordAssignment2.txt",
"chars": 78,
"preview": " 8 8 8\n 8 8 8\n 8 8 8\n 8 8 8\n 8 8 8\n 8 8 6\n"
},
{
"path": "tests/base/RecordParam.Mod",
"chars": 870,
"preview": "MODULE RecordParam;\n TYPE RP = POINTER TO R;\n R = RECORD\n i: INTEGER;\n p: RP;\n END;\n VAR\n "
},
{
"path": "tests/base/RecordParam.txt",
"chars": 27,
"preview": " 8 8\n 8 0\n 8 0\n"
},
{
"path": "tests/base/Samples0.Mod",
"chars": 1134,
"preview": "MODULE Samples0;\n VAR n: INTEGER;\n PROCEDURE Multiply;\n VAR x, y, z: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt("
},
{
"path": "tests/base/Samples0.txt",
"chars": 13,
"preview": " 0 80 40\n"
},
{
"path": "tests/base/Samples1.Mod",
"chars": 1134,
"preview": "MODULE Samples1;\n VAR n: INTEGER;\n PROCEDURE Multiply;\n VAR x, y, z: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt("
},
{
"path": "tests/base/Samples1.txt",
"chars": 17,
"preview": " 80 5 16 0\n"
},
{
"path": "tests/base/Samples2.Mod",
"chars": 1134,
"preview": "MODULE Samples2;\n VAR n: INTEGER;\n PROCEDURE Multiply;\n VAR x, y, z: INTEGER;\n BEGIN x := ReadInt(); y := ReadInt("
},
{
"path": "tests/base/Samples2.txt",
"chars": 13,
"preview": " 0 0 2\n"
},
{
"path": "tests/base/SetTest.Mod",
"chars": 4246,
"preview": "MODULE SetTest;\nIMPORT SYSTEM;\n CONST\n eight = 8;\n c0 = {6..eight};\n c1 = {0..4, 10, 30..31};\n "
},
{
"path": "tests/base/SetTest.txt",
"chars": 841,
"preview": " 3 4 5\n 3 4 5 20\n 3 4 5 20\n 3 4 5 20\n 1\n 3 4 5 6 7 8 20\n 5 6 7 8 9 "
},
{
"path": "tests/base/Strings0.Mod",
"chars": 993,
"preview": "MODULE Strings0;\n CONST baobab = \"BAOBAB\";\n C = \"C\";\n TYPE Arr = ARRAY 10 OF CHAR;\n VAR a : CHAR;\n b : "
},
{
"path": "tests/base/Strings0.txt",
"chars": 25,
"preview": "BAOBAB$---\nCC\nBAOBAB$---\n"
},
{
"path": "tests/base/Strings1.Mod",
"chars": 3801,
"preview": "MODULE Strings1;\n CONST y = \"A\";\n VAR a: ARRAY 10 OF CHAR;\n x : CHAR;\n s0 : ARRAY 5 OF ARRAY 5 OF CHAR;\n "
},
{
"path": "tests/base/Strings1.txt",
"chars": 480,
"preview": "l\n 1 3 5 8 9 13 14 15 16\n -3 -4 -6 -7 -10 -11\n -1 -2 -9 -10 -11 -12\n -3 -4 -5 -8 -9 -12\n -3 "
},
{
"path": "tests/base/Strings2.Mod",
"chars": 948,
"preview": "MODULE Strings2;\n\nCONST\n a = \"a\";\n abcd = \"abcd\";\n\nVAR\n s4: ARRAY 4 OF CHAR;\n s5: ARRAY 5 OF CHAR;\n f: ARRAY 20 OF "
},
{
"path": "tests/base/Strings2.txt",
"chars": 59,
"preview": "a$$$\na$$$\nab$$\na$\na$\nab$\nabcd$\nabcd$\n$bcd$\n 2 3 2 3"
},
{
"path": "tests/base/TestABS.Mod",
"chars": 367,
"preview": "MODULE TestABS;\n CONST r = -1.2; i = -2;\n VAR x, y : INTEGER;\n a, b : REAL;\n z : BYTE;\n \nBEGIN\n b := r;\n "
},
{
"path": "tests/base/TestABS.txt",
"chars": 44,
"preview": " 1.200000 1.200000 2 2\n 7.300000 8 10"
},
{
"path": "tests/base/TestAnonymousName.Mod",
"chars": 221,
"preview": "MODULE TestAnonymousName;\n TYPE Anonymous0 = RECORD i :CHAR END;\n \n VAR x : RECORD i :INTEGER END;\n y : Anonymou"
},
{
"path": "tests/base/TestAnonymousName.txt",
"chars": 1,
"preview": "A"
},
{
"path": "tests/base/TestAssert.Mod",
"chars": 170,
"preview": "MODULE TestAssert;\n VAR x : INTEGER;\n \nBEGIN\n x := 2;\n ASSERT(TRUE);\n ASSERT(x > 0);\n ASSERT((x > 0) & (x > 5) OR"
},
{
"path": "tests/base/TestAssert.txt",
"chars": 4,
"preview": " 1"
},
{
"path": "tests/base/TestAssignmentMix.Mod",
"chars": 607,
"preview": "MODULE TestAssignmentMix;\n TYPE A = RECORD i : INTEGER END;\n B = RECORD(A) j : REAL END;\n TA = ARRAY 1 OF A"
},
{
"path": "tests/base/TestAssignmentMix.txt",
"chars": 0,
"preview": ""
},
{
"path": "tests/base/TestByteType.Mod",
"chars": 1885,
"preview": "MODULE TestByteType;\n VAR x : INTEGER;\n y : BYTE;\n r : RECORD y : BYTE END;\n ar : ARRAY 1 OF BYTE;\n\n PR"
},
{
"path": "tests/base/TestByteType.txt",
"chars": 152,
"preview": " 256 1\n 255 129 130 129\n 255 129 130 129\n 255 129 130 129 1\n 256 1\n 255 129 130 129\n 255 129 130 129\n 255 129 130 "
},
{
"path": "tests/base/TestCPS.Mod",
"chars": 272,
"preview": "MODULE TestCPS;\n\nTYPE F = PROCEDURE(i: INTEGER);\n\nPROCEDURE log(i : INTEGER);\nBEGIN \n WriteInt(i)\nEND log;\n\nPROCEDURE t"
},
{
"path": "tests/base/TestCPS.txt",
"chars": 4,
"preview": " 720"
},
{
"path": "tests/base/TestCmdLineArgs.Mod",
"chars": 1020,
"preview": "MODULE TestCmdLineArgs;\n VAR x: INTEGER;\n y: ARRAY 10 OF CHAR;\n \n PROCEDURE Print(x: ARRAY OF CHAR);\n VAR i,"
},
{
"path": "tests/base/TestCmdLineArgs.txt",
"chars": 31,
"preview": " 0\n\n\n\nW\nW\nHello\nHello\nWorld!\n"
},
{
"path": "tests/base/TestConstFunc.Mod",
"chars": 3523,
"preview": "MODULE TestConstFunc;\n IMPORT SYSTEM;\n CONST\n negReal = -2.5;\n posReal = 3.2;\n posInt = 2;\n a = \"A\";\n i"
},
{
"path": "tests/base/TestConstFunc.txt",
"chars": 340,
"preview": " 2.500000 2.500000\n 0 0\n 3 3\n 2.000000 2.000000\n 65 65\nAA\n 5 5 3 3 1 1\n 260 260\n 16 16\n 10737418"
},
{
"path": "tests/base/TestCyclicImport00A.Mod",
"chars": 88,
"preview": "MODULE TestCyclicImport00;\n TYPE R0* = RECORD k*: INTEGER END;\nEND TestCyclicImport00.\n"
},
{
"path": "tests/base/TestCyclicImport00B.Mod",
"chars": 174,
"preview": "MODULE TestCyclicImport00;\n IMPORT TestCyclicImport01;\n\n TYPE R0* = RECORD k*: INTEGER END;\n VAR\n r1: TestCyclicI"
},
{
"path": "tests/base/TestCyclicImport01A.Mod",
"chars": 174,
"preview": "MODULE TestCyclicImport01;\n IMPORT TestCyclicImport00;\n\n TYPE R1* = RECORD x*: INTEGER END;\n VAR\n r0: TestCyclicI"
},
{
"path": "tests/base/TestCyclicImport01B.Mod",
"chars": 193,
"preview": "MODULE TestCyclicImport01;\n IMPORT TestCyclicImport00;\n\n TYPE R1* = RECORD x*: INTEGER END;\n VAR\n r0*: TestCyclic"
},
{
"path": "tests/base/TestCyclicImport10A.Mod",
"chars": 89,
"preview": "MODULE TestCyclicImport10;\n TYPE R0* = RECORD k*: INTEGER END;\n\nEND TestCyclicImport10.\n"
},
{
"path": "tests/base/TestCyclicImport10B.Mod",
"chars": 175,
"preview": "MODULE TestCyclicImport10;\n IMPORT TestCyclicImport11;\n\n TYPE R0* = RECORD k*: INTEGER END;\n VAR\n j: INTEGER;\nBEG"
},
{
"path": "tests/base/TestCyclicImport11.Mod",
"chars": 138,
"preview": "MODULE TestCyclicImport11;\n IMPORT TestCyclicImport12;\n VAR\n i*: INTEGER;\nBEGIN\n i := TestCyclicImport12.w\nEND Te"
},
{
"path": "tests/base/TestCyclicImport12.Mod",
"chars": 164,
"preview": "MODULE TestCyclicImport12;\n IMPORT TestCyclicImport10;\n VAR\n r0: TestCyclicImport10.R0;\n w*: INTEGER;\nBEGIN\n "
},
{
"path": "tests/base/TestEqualSignature00.Mod",
"chars": 1309,
"preview": "MODULE TestEqualSignature00;\n TYPE\n A = RECORD i : INTEGER END;\n B = RECORD(A) k : CHAR END;\n P0 = PROCEDURE(x"
},
{
"path": "tests/base/TestEqualSignature00.txt",
"chars": 6,
"preview": "ABCDEF"
},
{
"path": "tests/base/TestExprVarPar.Mod",
"chars": 116,
"preview": "MODULE TestExprVarPar;\n VAR a: INTEGER;\n\n PROCEDURE G(VAR i: INTEGER); END G;\n\nBEGIN\n G(a+1)\nEND TestExprVarPar.\n"
},
{
"path": "tests/base/TestFor.Mod",
"chars": 1702,
"preview": "MODULE TestFor;\n CONST minus1 = -1;\n TYPE R0 = RECORD x, y : INTEGER END;\n ARR = ARRAY 5 OF INTEGER;\n VAR i, x"
},
{
"path": "tests/base/TestFor.txt",
"chars": 248,
"preview": " 0 1 2 3 4 5 6 7 8 8 7 6 5 4 3 2 1 0\n 0 1 2 3 4 5\n 7 8 9\n 0 1 "
},
{
"path": "tests/base/TestFor1.Mod",
"chars": 813,
"preview": "MODULE TestFor1;\n VAR v, beg, end : INTEGER;\n \n PROCEDURE For0;\n VAR v, beg, end : INTEGER;\n BEGIN\n beg := 3;\n"
},
{
"path": "tests/base/TestFor1.txt",
"chars": 154,
"preview": " 3 5 7 9\n 0 1 2 3\n 0 2\n 3 4 5 6 7 8 9 10\n 0 1 2 3 4 5 6 7 8 9 10"
},
{
"path": "tests/base/TestFunction0.Mod",
"chars": 302,
"preview": "MODULE TestFunction0;\n VAR x : INTEGER;\n \n PROCEDURE P1(i : INTEGER): INTEGER;\n PROCEDURE P2(j, z : INTEGER) : IN"
},
{
"path": "tests/base/TestFunction0.txt",
"chars": 4,
"preview": " 4"
},
{
"path": "tests/base/TestINC0.Mod",
"chars": 3244,
"preview": "MODULE TestINC0;\n VAR xg : INTEGER;\n yg : BYTE;\n ig : ARRAY 2 OF INTEGER; \n jg : RECORD x : INTEGER END;"
},
{
"path": "tests/base/TestINC0.txt",
"chars": 179,
"preview": " 2 132 4 255 125 129 1\n 2 132 4 255 125 129 1\n 3 4 4 2 4 3 5 6 7 7 11 9 10 5 99 1"
},
{
"path": "tests/base/TestINC1.Mod",
"chars": 1077,
"preview": "MODULE TestINC1;\n VAR k: INTEGER;\n i: ARRAY 2 OF RECORD b : BYTE END;\n j: ARRAY 20 OF BYTE;\n x: BYTE;\n "
},
{
"path": "tests/base/TestINC1.txt",
"chars": 49,
"preview": " 7 1 8 15 22 25\n 7 1 8 15 22 25"
},
{
"path": "tests/base/TestINCLAndEXCL.Mod",
"chars": 2120,
"preview": "MODULE TestINCLAndEXCL;\n CONST K = {1, 2, 3};\n VAR y : SET;\n j,f : INTEGER;\n b : ARRAY 2 OF SET;\n r: RE"
},
{
"path": "tests/base/TestINCLAndEXCL.txt",
"chars": 191,
"preview": " 1 3\n 1 3\n 1 3\n 1 3\n 1 2 3 8\n 2 3 8\n 1 3\n 1 3\n 1 2\n 1 2 3\n 1 3 8\n "
},
{
"path": "tests/base/TestImport00.Mod",
"chars": 397,
"preview": "MODULE TestImport00;\nCONST N* = 100;\nTYPE\n Ptr* = POINTER TO Rec;\n Rec* = RECORD n*: INTEGER; p: Ptr END ;\n Rec2 = RE"
},
{
"path": "tests/base/TestImport00.txt",
"chars": 0,
"preview": ""
}
]
// ... and 122 more files (download for full content)
About this extraction
This page contains the full source code of the lboasso/oberonc GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 322 files (386.4 KB), approximately 137.0k tokens, and a symbol index with 113 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.