+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*)
+
+MODULE XYplaneTest;
+
+ IMPORT XYplane;
+(*
+ PROCEDURE TestPosition(x, y: INTEGER);
+ VAR withinBounds: BOOLEAN;
+ BEGIN
+ withinBounds := (x >= 0) & (x < XYplane.W)
+ & (y >= 0) & (y < XYplane.H);
+ XYplane.Clear;
+ XYplane.Dot(x, y, XYplane.draw);
+ ASSERT(withinBounds & XYplane.IsDot(x, y)
+ OR ~withinBounds & ~XYplane.IsDot(x, y));
+ XYplane.Dot(x, y, XYplane.erase);
+ ASSERT(~XYplane.IsDot(x, y))
+ END TestPosition;
+
+
+ PROCEDURE Run;
+ VAR x, y, w, h: INTEGER;
+ BEGIN
+ x := XYplane.X;
+ y := XYplane.Y;
+ w := XYplane.W;
+ h := XYplane.H;
+
+ XYplane.Open;
+
+ XYplane.Open; (*reopening test*)
+
+ (*corners*)
+
+ TestPosition(x, y);
+ TestPosition(x, y + h - 1);
+ TestPosition(x + w - 1, y + h - 1);
+ TestPosition(x, y + h - 1);
+
+ (*just outside the corners*)
+
+ TestPosition(x - 1, y);
+ TestPosition(x - 1, y - 1);
+ TestPosition(x, y - 1);
+
+ TestPosition(x - 1, y + h - 1);
+ TestPosition(x - 1, y + h);
+ TestPosition(x, y + h);
+
+ TestPosition(x + w - 1, y + h);
+ TestPosition(x + w, y + h);
+ TestPosition(x + w, y + h - 1);
+
+ TestPosition(x + w, y);
+ TestPosition(x + w, y - 1);
+ TestPosition(x + w - 1, y - 1);
+ END Run;
+
+BEGIN
+ Run
+*)
+END XYplaneTest.
diff --git a/share/doc/obnc/oberon-report.html b/share/doc/obnc/oberon-report.html
new file mode 100644
index 0000000..a2743f3
--- /dev/null
+++ b/share/doc/obnc/oberon-report.html
@@ -0,0 +1,1672 @@
+
+
+
+
+
+
+ The Programming Language Oberon
+
+
+
+
+
+
+ Table of Contents
+
+
+ - History and introduction
+ - Syntax
+ - Vocabulary
+ - Declarations and scope rules
+ - Constant declarations
+ - Type declarations
+ - Variable declarations
+ - Expressions
+ - Statements
+ - Procedure declarations
+ - Modules
+
+
+ Appendix: The Syntax of Oberon
+
+
+
+ Oberon is a general-purpose programming language that evolved from Modula-2. Its principal new feature is the concept of type extension. It permits the construction of new data types on the basis of existing ones and to relate them.
+
+ This report is not intended as a programmer's tutorial. It is intentionally kept concise. Its function is to serve as a reference for programmers, implementors, and manual writers. What remains unsaid is mostly left so intentionally, either because it is derivable from stated rules of the language, or because it would unnecessarily restrict the freedom of implementors.
+
+ This document describes the language defined in 1988/90 as revised in 2007 / 2016.
+
+
+
+ A language is an infinite set of sentences, namely the sentences well formed according to its syntax. In Oberon, these sentences are called compilation units. Each unit is a finite sequence of symbols from a finite vocabulary. The vocabulary of Oberon consists of identifiers, numbers, strings, operators, delimiters, and comments. They are called lexical symbols and are composed of sequences of characters. (Note the distinction between symbols and characters.)
+
+ To describe the syntax, an extended Backus-Naur Formalism called EBNF is used. Brackets [ and ] denote optionality of the enclosed sentential form, and braces { and } denote its repetition (possibly 0 times). Syntactic entities (non-terminal symbols) are denoted by English words expressing their intuitive meaning. Symbols of the language vocabulary (terminal symbols) are denoted by strings enclosed in quote marks or by words in capital letters.
+
+
+
+ The following lexical rules must be observed when composing symbols. Blanks and line breaks must not occur within symbols (except in comments, and blanks in strings). They are ignored unless they are essential to separate two consecutive symbols. Capital and lower-case letters are considered as being distinct.
+
+ Identifiers are sequences of letters and digits. The first character must be a letter.
+
+
+ident = letter {letter | digit}.
+
+
+ Examples:
+
+
+x scan Oberon GetSymbol firstLetter
+
+
+ Numbers are (unsigned) integers or real numbers. Integers are sequences of digits and may be followed by a suffix letter. If no suffix is specified, the representation is decimal. The suffix H indicates hexadecimal representation.
+
+ A real number always contains a decimal point. Optionally it may also contain a decimal scale factor. The letter E is pronounced as “times ten to the power of”.
+
+
+number = integer | real.
+integer = digit {digit} | digit {hexDigit} "H".
+real = digit {digit} "." {digit} [ScaleFactor].
+ScaleFactor = "E" ["+" | "-"] digit {digit}.
+hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".
+digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".
+
+
+ Examples:
+
+
+
+
+ | 1987 |
+ |
+
+
+ | 100H |
+ = 256 |
+
+
+ | 12.3 |
+ |
+
+
+ | 4.567E8 |
+ = 456700000 |
+
+
+
Strings are sequences of characters enclosed in quote marks ("). A string cannot contain the delimiting quote mark. Alternatively, a single-character string may be specified by the ordinal number of the character in hexadecimal notation followed by an "X". The number of characters in a string is called the length of the string.
+
+
+string = """ {character} """ | digit {hexdigit} "X" .
+
+
+ Examples:
+
+
+"OBERON" "Don't worry!" 22X
+
+
+ Operators and delimiters are the special characters, character pairs, or reserved words listed below. These reserved words consist exclusively of capital letters and cannot be used in the role of identifiers.
+
+
+
+
+ | + |
+ := |
+ ARRAY |
+ IMPORT |
+ THEN |
+
+
+ | - |
+ ^ |
+ BEGIN |
+ IN |
+ TO |
+
+
+ | * |
+ = |
+ BY |
+ IS |
+ TRUE |
+
+
+ | / |
+ # |
+ CASE |
+ MOD |
+ TYPE |
+
+
+ | ~ |
+ < |
+ CONST |
+ MODULE |
+ UNTIL |
+
+
+ | & |
+ > |
+ DIV |
+ NIL |
+ VAR |
+
+
+ | . |
+ <= |
+ DO |
+ OF |
+ WHILE |
+
+
+ | , |
+ >= |
+ ELSE |
+ OR |
+
+
+ | ; |
+ .. |
+ ELSIF |
+ POINTER |
+
+
+ | | |
+ : |
+ END |
+ PROCEDURE |
+
+
+ | ( |
+ ) |
+ FALSE |
+ RECORD |
+
+
+ | [ |
+ ] |
+ FOR |
+ REPEAT |
+
+
+ | { |
+ } |
+ IF |
+ RETURN |
+
+
+
Comments may be inserted between any two symbols in a program. They are arbitrary character sequences opened by the bracket (* and closed by *). Comments do not affect the meaning of a program. They may be nested.
+
+
+
+ Every identifier occurring in a program must be introduced by a declaration, unless it is a predefined identifier. Declarations also serve to specify certain permanent properties of an object, such as whether it is a constant, a type, a variable, or a procedure.
+
+ The identifier is then used to refer to the associated object. This is possible in those parts of a program only which are within the scope of the declaration. No identifier may denote more than one object within a given scope. The scope extends textually from the point of the declaration to the end of the block (procedure or module) to which the declaration belongs and hence to which the object is local.
+
+ In its declaration, an identifier in the module's scope may be followed by an export mark (*) to indicate that it be exported from its declaring module. In this case, the identifier may be used in other modules, if they import the declaring module. The identifier is then prefixed by the identifier designating its module (see Ch. 11). The prefix and the identifier are separated by a period and together are called a qualified identifier.
+
+
+qualident = [ident "."] ident.
+identdef = ident ["*"].
+
+
+ The following identifiers are predefined; their meaning is defined in section 6.1 (types) or 10.2 (procedures):
+
+
+
+
+ | ABS |
+ ASR |
+ ASSERT |
+ BOOLEAN |
+ BYTE |
+
+
+ | CHAR |
+ CHR |
+ DEC |
+ EXCL |
+ FLOOR |
+
+
+ | FLT |
+ INC |
+ INCL |
+ INTEGER |
+ LEN |
+
+
+ | LSL |
+ NEW |
+ ODD |
+ ORD |
+ PACK |
+
+
+ | REAL |
+ ROR |
+ SET |
+ UNPK |
+
+
+
A constant declaration associates an identifier with a constant value.
+
+
+ConstDeclaration = identdef "=" ConstExpression.
+ConstExpression = expression.
+
+
+ A constant expression can be evaluated by a mere textual scan without actually executing the program. Its operands are constants (see Ch. 8). Examples of constant declarations are:
+
+
+N = 100
+
+
+
+limit = 2*N - 1
+
+
+
+all = {0 .. WordSize - 1}
+
+
+
+name = "Oberon"
+
+
+
+
+ A data type determines the set of values which variables of that type may assume, and the operators that are applicable. A type declaration is used to associate an identifier with a type. The types define the structure of variables of this type and, by implication, the operators that are applicable to components. There are two different data structures, namely arrays and records, with different component selectors.
+
+
+TypeDeclaration = identdef "=" type.
+type = qualident | ArrayType | RecordType | PointerType | ProcedureType.
+
+
+ Examples:
+
+
+Table = ARRAY N OF REAL
+
+
+
+Tree = POINTER TO Node
+
+
+
+Node = RECORD key: INTEGER;
+ left, right: Tree
+END
+
+
+
+CenterNode = RECORD (Node)
+ name: ARRAY 32 OF CHAR;
+ subnode: Tree
+END
+
+
+
+Function = PROCEDURE (x: INTEGER): INTEGER
+
+
+
+
+ The following basic types are denoted by predeclared identifiers. The associated operators are defined in 8.2, and the predeclared function procedures in 10.2. The values of a given basic type are the following:
+
+
+
+ - BOOLEAN
+ - the truth values TRUE and FALSE
+
+ - CHAR
+ - the characters of a standard character set
+
+ - INTEGER
+ - the integers
+
+ - REAL
+ - real numbers
+
+ - BYTE
+ - the integers between 0 and 255
+
+ - SET
+ - the sets of integers between 0 and an implementation-dependent limit
+
+
The type BYTE is compatible with the type INTEGER, and vice-versa.
+
+
+
+ An array is a structure consisting of a fixed number of elements which are all of the same type, called the element type. The number of elements of an array is called its length. The elements of the array are designated by indices, which are integers between 0 and the length minus 1.
+
+
+ArrayType = ARRAY length {"," length} OF type.
+length = ConstExpression.
+
+
+ A declaration of the form
+
+
+ARRAY N0, N1, ... , Nk OF T
+
+
+ is understood as an abbreviation of the declaration
+
+
+ARRAY N0 OF
+ ARRAY N1 OF
+ ...
+ ARRAY Nk OF T
+
+
+ Examples of array types:
+
+
+ARRAY N OF INTEGER
+
+
+
+ARRAY 10, 20 OF REAL
+
+
+
+
+ A record type is a structure consisting of a fixed number of elements of possibly different types. The record type declaration specifies for each element, called field, its type and an identifier which denotes the field. The scope of these field identifiers is the record definition itself, but they are also visible within field designators (see 8.1) referring to elements of record variables.
+
+
+RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.
+BaseType = qualident.
+FieldListSequence = FieldList {";" FieldList}.
+FieldList = IdentList ":" type.
+IdentList = identdef {"," identdef}.
+
+
+ If a record type is exported, field identifiers that are to be visible outside the declaring module must be marked. They are called public fields; unmarked fields are called private fields.
+
+ Record types are extensible, i.e. a record type can be defined as an extension of another record type. In the examples above, CenterNode (directly) extends Node, which is the (direct) base type of CenterNode. More specifically, CenterNode extends Node with the fields name and subnode.
+
+ Definition: A type T extends a type T0, if it equals T0, or if it directly extends an extension of T0. Conversely, a type T0 is a base type of T, if it equals T, or if it is the direct base type of a base type of T.
+
+ Examples of record types:
+
+
+RECORD day, month, year: INTEGER
+END
+
+
+
+RECORD
+ name, firstname: ARRAY 32 OF CHAR;
+ age: INTEGER;
+ salary: REAL
+END
+
+
+
+
+ Variables of a pointer type P assume as values pointers to variables of some type T. It must be a record type. The pointer type P is said to be bound to T, and T is the pointer base type of P. Pointer types inherit the extension relation of their base types, if there is any. If a type T is an extension of T0 and P is a pointer type bound to T, then P is also an extension of P0, the pointer type bound to T0.
+
+
+PointerType = POINTER TO type.
+
+
+ If a type P is defined as POINTER TO T, the identifier T can be declared textually following the declaration of P, but [if so] it must lie within the same scope.
+
+ If p is a variable of type P = POINTER TO T, then a call of the predefined procedure NEW(p) has the following effect (see 10.2): A variable of type T is allocated in free storage, and a pointer to it is assigned to p. This pointer p is of type P and the referenced variable p^ is of type T. Failure of allocation results in p obtaining the value NIL. Any pointer variable may be assigned the value NIL, which points to no variable at all.
+
+
+
+ Variables of a procedure type T have a procedure (or NIL) as value. If a procedure P is assigned to a procedure variable of type T, the (types of the) formal parameters of P must be the same as those indicated in the formal parameters of T. The same holds for the result type in the case of a function procedure (see 10.1). P must not be declared local to another procedure, and neither can it be a standard procedure.
+
+
+ProcedureType = PROCEDURE [FormalParameters].
+
+
+
+
+ Variable declarations serve to introduce variables and associate them with identifiers that must be unique within the given scope. They also serve to associate fixed data types with the variables.
+
+
+VariableDeclaration = IdentList ":" type.
+
+
+ Variables whose identifiers appear in the same list are all of the same type. Examples of variable declarations (refer to examples in Ch. 6):
+
+
+i, j, k: INTEGER
+
+
+
+x, y: REAL
+
+
+
+p, q: BOOLEAN
+
+
+s: SET
+
+
+
+f: Function
+
+
+
+a: ARRAY 100 OF REAL
+
+
+
+w: ARRAY 16 OF
+ RECORD ch: CHAR;
+ count: INTEGER
+ END
+
+
+
+t: Tree
+
+
+
+
+ Expressions are constructs denoting rules of computation whereby constants and current values of variables are combined to derive other values by the application of operators and function procedures. Expressions consist of operands and operators. Parentheses may be used to express specific associations of operators and operands.
+
+
+
+ With the exception of sets and literal constants, i.e. numbers and strings, operands are denoted by designators. A designator consists of an identifier referring to the constant, variable, or procedure to be designated. This identifier may possibly be qualified by module identifiers (see Ch. 4 and 11), and it may be followed by selectors, if the designated object is an element of a structure.
+
+ If A designates an array, then A[E] denotes that element of A whose index is the current value of the expression E. The type of E must be of type INTEGER. A designator of the form A[E1, E2, ... , En] stands for A[E1][E2] ... [En]. If p designates a pointer variable, p^ denotes the variable which is referenced by p. If r designates a record, then r.f denotes the field f of r. If p designates a pointer, p.f denotes the field f of the record p^, i.e. the dot implies dereferencing and p.f stands for p^.f.
+
+ The typeguard v(T0) asserts that v is of type T0 , i.e. it aborts program execution, if it is not of type T0 . The guard is applicable, if
+
+
+ - T0 is an extension of the declared type T of v, and if
+ - v is a variable parameter of record type, or v is a pointer.
+
+
+
+designator = qualident {selector}.
+selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".
+ExpList = expression {"," expression}.
+
+
+ If the designated object is a variable, then the designator refers to the variable's current value. If the object is a procedure, a designator without parameter list refers to that procedure. If it is followed by a (possibly empty) parameter list, the designator implies an activation of the procedure and stands for the value resulting from its execution. The (types of the) actual parameters must correspond to the formal parameters as specified in the procedure's declaration (see Ch. 10).
+
+ Examples of designators (see examples in Ch. 7):
+
+
+
+
+ | i |
+ (INTEGER) |
+
+
+ | a[i] |
+ (REAL) |
+
+
+ | w[3].ch |
+ (CHAR) |
+
+
+ | t.key |
+ (INTEGER) |
+
+
+ | t.left.right |
+ (Tree) |
+
+
+ | t(CenterNode).subnode |
+ (Tree) |
+
+
+
The syntax of expressions distinguishes between four classes of operators with different precedences (binding strengths). The operator ~ has the highest precedence, followed by multiplication operators, addition operators, and relations. Operators of the same precedence associate from left to right. For example, x − y − z stands for (x − y) − z.
+
+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.
+set = "{" [element {"," element}] "}".
+element = expression [".." expression].
+ActualParameters = "(" [ExpList] ")" .
+
+
+ The set {m .. n} denotes {m, m+1, … , n-1, n}, and if m > n, the empty set. The available operators are listed in the following tables. In some instances, several different operations are designated by the same operator symbol. In these cases, the actual operation is identified by the type of the operands.
+
+
+
+
+
+
+
+ These operators apply to BOOLEAN operands and yield a BOOLEAN result.
+
+
+
+
+ | p OR q |
+ stands for |
+ “if p then TRUE, else q” |
+
+
+ | p & q |
+ stands for |
+ “if p then q, else FALSE” |
+
+
+ | ~ p |
+ stands for |
+ “not p” |
+
+
+
+
+
+
+ The operators +, −, *, and / apply to operands of numeric types. Both operands must be of the same type, which is also the type of the result. When used as unary operators, − denotes sign inversion and + denotes the identity operation.
+
+ The operators DIV and MOD apply to integer operands only. Let q = x DIV y, and r = x MOD y. Then quotient q and remainder r are defined by the equation
+
+
+x = q*y + r 0 <= r < y
+
+
+
+
+
+
+
+
+ When used with a single operand of type SET, the minus sign denotes the set complement.
+
+
+
+
+
+
+
+ Relations are Boolean. The ordering relations <, <=, >, >= apply to the numeric types, CHAR, and character arrays. The relations = and # also apply to the types BOOLEAN, SET, and to pointer and procedure types.
+
+ x IN s stands for “x is an element of s”. x must be of type INTEGER, and s of type SET.
+
+ v IS T stands for “v is of type T” and is called a type test. It is applicable, if
+
+
+ - T is an extension of the declared type T0 of v, and if
+ - v is a variable parameter of record type or v is a pointer.
+
+
+ Assuming, for instance, that T is an extension of T0 and that v is a designator declared of type T0, then the test v IS T determines whether the actually designated variable is (not only a T0, but also) a T. The value of NIL IS T is undefined.
+
+ Examples of expressions (refer to examples in Ch. 7):
+
+
+
+
+ | 1987 |
+ (INTEGER) |
+
+
+ | i DIV 3 |
+ (INTEGER) |
+
+
+ | ~p OR q |
+ (BOOLEAN) |
+
+
+ | (i+j) * (i-j) |
+ (INTEGER) |
+
+
+ | s - {8, 9, 13} |
+ (SET) |
+
+
+ | a[i+j] * a[i-j] |
+ (REAL) |
+
+
+ | (0<=i) & (i<100) |
+ (BOOLEAN) |
+
+
+ | t.key = 0 |
+ (BOOLEAN) |
+
+
+ | k IN {i .. j-1} |
+ (BOOLEAN) |
+
+
+ | t IS CenterNode |
+ (BOOLEAN) |
+
+
+
Statements denote actions. There are elementary and structured statements. Elementary statements are not composed of any parts that are themselves statements. They are the assignment and the procedure call. Structured statements are composed of parts that are themselves statements. They are used to express sequencing and conditional, selective, and repetitive execution. A statement may also be empty, in which case it denotes no action. The empty statement is included in order to relax punctuation rules in statement sequences.
+
+
+statement = [assignment | ProcedureCall | IfStatement | CaseStatement |
+ WhileStatement | RepeatStatement | ForStatement].
+
+
+
+
+ The assignment serves to replace the current value of a variable by a new value specified by an expression. The assignment operator is written as “:=” and pronounced as becomes.
+
+
+assignment = designator ":=" expression.
+
+
+ If a value parameter is structured (of array or record type), no assignment to it or to its elements are permitted. Neither may assignments be made to imported variables.
+
+ The type of the expression must be the same as that of the designator. The following exceptions hold:
+
+
+ - The constant NIL can be assigned to variables of any pointer or procedure type.
+ - Strings can be assigned to any array of characters, provided the number of characters in the string is less than that of the array. (A null character is appended). Single-character strings can also be assigned to variables of type CHAR.
+ - In the case of records, the type of the source must be an extension of the type of the destination.
+ - An open array may be assigned to an array of equal base type.
+
+
+ Examples of assignments (see examples in Ch. 7):
+
+
+i := 0
+
+
+
+p := i = j
+
+
+
+x := FLT(i + 1)
+
+
+
+k := (i + j) DIV 2
+
+
+
+f := log2
+
+
+
+s := {2, 3, 5, 7, 11, 13}
+
+
+
+a[i] := (x+y) * (x-y)
+
+
+
+t.key := i
+
+
+
+w[i+1].ch := "A"
+
+
+
+
+ A procedure call serves to activate a procedure. The procedure call may contain a list of actual parameters which are substituted in place of their corresponding formal parameters defined in the procedure declaration (see Ch. 10). The correspondence is established by the positions of the parameters in the lists of actual and formal parameters respectively. There exist two kinds of parameters: variable and value parameters.
+
+ In the case of variable parameters, the actual parameter must be a designator denoting a variable. If it designates an element of a structured variable, the selector is evaluated when the formal/actual parameter substitution takes place, i.e. before the execution of the procedure. If the parameter is a value parameter, the corresponding actual parameter must be an expression. This expression is evaluated prior to the procedure activation, and the resulting value is assigned to the formal parameter which now constitutes a local variable (see also 10.1.).
+
+
+ProcedureCall = designator [ActualParameters].
+
+
+ Examples of procedure calls:
+
+
+
+
+ | ReadInt(i) |
+ (see Ch. 10) |
+
+
+ | WriteInt(2*j + 1, 6) |
+ |
+
+
+ | INC(w[k].count) |
+ |
+
+
+
Statement sequences denote the sequence of actions specified by the component statements which are separated by semicolons.
+
+
+StatementSequence = statement {";" statement}.
+
+
+
+
+
+IfStatement = IF expression THEN StatementSequence
+ {ELSIF expression THEN StatementSequence}
+ [ELSE StatementSequence]
+ END.
+
+
+ If statements specify the conditional execution of guarded statements. The Boolean expression preceding a statement is called its guard. The guards are evaluated in sequence of occurrence, until one evaluates to TRUE, whereafter its associated statement sequence is executed. If no guard is satisfied, the statement sequence following the symbol ELSE is executed, if there is one.
+
+ Example:
+
+
+IF (ch >= "A") & (ch <= "Z") THEN ReadIdentifier
+ELSIF (ch >= "0") & (ch <= "9") THEN ReadNumber
+ELSIF ch = 22X THEN ReadString
+END
+
+
+
+
+ Case statements specify the selection and execution of a statement sequence according to the value of an expression. First the case expression is evaluated, then the statement sequence is executed whose case label list contains the obtained value. If the case expression is of type INTEGER or CHAR, all labels must be integers or single-character strings, respectively.
+
+
+CaseStatement = CASE expression OF case {"|" case} END.
+case = [CaseLabelList ":" StatementSequence].
+CaseLabelList = LabelRange {"," LabelRange}.
+LabelRange = label [".." label].
+label = integer | string | qualident.
+
+
+ Example:
+
+
+CASE k OF
+ 0: x := x + y
+ | 1: x := x − y
+ | 2: x := x * y
+ | 3: x := x / y
+END
+
+
+ The type T of the case expression (case variable) may also be a record or pointer type. Then the
+case labels must be extensions of T, and in the statements Si labelled by Ti, the case variable is considered as of type Ti.
+
+ Example:
+
+
+TYPE R = RECORD a: INTEGER END;
+ R0 = RECORD (R) b: INTEGER END;
+ R1 = RECORD (R) b: REAL END;
+ R2 = RECORD (R) b: SET END;
+ P = POINTER TO R;
+ P0 = POINTER TO R0;
+ P1 = POINTER TO R1;
+ P2 = POINTER TO R2;
+VAR p: P;
+
+
+
+CASE p OF
+ P0: p.b := 10 |
+ P1: p.b := 2.5 |
+ P2: p.b := {0, 2}
+END
+
+
+
+
+ While statements specify repetition. If any of the Boolean expressions (guards) yields TRUE, the corresponding statement sequence is executed. The expression evaluation and the statement execution are repeated until none of the Boolean expressions yields TRUE.
+
+
+WhileStatement = WHILE expression DO StatementSequence
+ {ELSIF expression DO StatementSequence} END.
+
+
+ Examples:
+
+
+WHILE j > 0 DO
+ j := j DIV 2; i := i+1
+END
+
+
+
+WHILE (t # NIL) & (t.key # i) DO
+ t := t.left
+END
+
+
+
+WHILE m > n DO m := m - n
+ELSIF n > m DO n := n - m
+END
+
+
+
+
+ A repeat statement specifies the repeated execution of a statement sequence until a condition is satisfied. The statement sequence is executed at least once.
+
+
+RepeatStatement = REPEAT StatementSequence UNTIL expression.
+
+
+
+
+ A for statement specifies the repeated execution of a statement sequence for a given number of times, while a progression of values is assigned to an integer variable called the control variable of the for statement.
+
+
+ForStatement =
+ FOR ident ":=" expression TO expression [BY ConstExpression] DO
+ StatementSequence END.
+
+
+ The for statement
+
+
+FOR v := beg TO end BY inc DO S END
+
+
+ is, if inc > 0, equivalent to
+
+
+v := beg;
+WHILE v <= end DO S; v := v + inc END
+
+
+ and if inc < 0 it is equivalent to
+
+
+v := beg;
+WHILE v >= end DO S; v := v + inc END
+
+
+ The types of v, beg and end must be INTEGER, and inc must be an integer (constant expression). If the step is not specified, it is assumed to be 1.
+
+
+
+ Procedure declarations consist of a procedure heading and a procedure body. The heading specifies the procedure identifier, the formal parameters, and the result type (if any). The body contains declarations and statements. The procedure identifier is repeated at the end of the procedure declaration.
+
+ There are two kinds of procedures, namely proper procedures and function procedures. The latter are activated by a function designator as a constituent of an expression, and yield a result that is an operand in the expression. Proper procedures
+are activated by a procedure call. A function procedure is distinguished in the declaration by indication of the type of its result following the parameter list. Its body must end with a RETURN clause which defines the result of the function procedure.
+
+ All constants, variables, types, and procedures declared within a procedure body are local to the procedure. The values of local variables are undefined upon entry to the procedure. Since procedures may be declared as local objects too, procedure declarations may be nested.
+
+ In addition to its formal parameters and locally declared objects, the objects declared globally are also visible in the procedure.
+
+ The use of the procedure identifier in a call within its declaration implies recursive activation of the procedure.
+
+
+ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.
+ProcedureHeading = PROCEDURE identdef [FormalParameters].
+ProcedureBody = DeclarationSequence [BEGIN StatementSequence]
+ [RETURN expression] END.
+DeclarationSequence = [CONST {ConstDeclaration ";"}]
+ [TYPE {TypeDeclaration ";"}] [VAR {VariableDeclaration ";"}]
+ {ProcedureDeclaration ";"}.
+
+
+
+
+ Formal parameters are identifiers which denote actual parameters specified in the procedure call. The correspondence between formal and actual parameters is established when the procedure is called. There are two kinds of parameters, namely
+value and variable parameters. A variable parameter corresponds to an actual parameter that is a variable, and it stands for that variable. A value parameter corresponds to an actual parameter that is an expression, and it stands for its value, which cannot be changed by assignment. However, if a value parameter is of a basic type, it represents a local variable to which the value of the actual expression is initially assigned.
+
+ The kind of a parameter is indicated in the formal parameter list: Variable parameters are denoted by the symbol VAR and value parameters by the absence of a prefix.
+
+ A function procedure without parameters must have an empty parameter list. It must be called by a function designator whose actual parameter list is empty too.
+
+ Formal parameters are local to the procedure, i.e. their scope is the program text which constitutes the procedure declaration.
+
+
+FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].
+FPSection = [VAR] ident {"," ident} ":" FormalType.
+FormalType = {ARRAY OF} qualident.
+
+
+ The type of each formal parameter is specified in the parameter list. For variable parameters, it must be identical to the corresponding actual parameter's type, except in the case of a record, where it must be a base type of the corresponding actual parameter's type.
+
+ If the formal parameter's type is specified as
+
+
+ARRAY OF T
+
+
+ the parameter is said to be an open array, and the corresponding actual parameter may be of arbitrary length.
+
+ If a formal parameter specifies a procedure type, then the corresponding actual parameter must be either a procedure declared globally, or a variable (or parameter) of that procedure type. It cannot be a predefined procedure. The result type of a procedure can be neither a record nor an array.
+
+ Examples of procedure declarations:
+
+
+PROCEDURE ReadInt(VAR x: INTEGER);
+ VAR i: INTEGER; ch: CHAR;
+BEGIN i := 0; Read(ch);
+ WHILE ("0" <= ch) & (ch <= "9") DO
+ i := 10*i + (ORD(ch) - ORD("0")); Read(ch)
+ END;
+ x := i
+END ReadInt
+
+
+
+PROCEDURE WriteInt(x: INTEGER); (* 0 <= x < 10^5 *)
+ VAR i: INTEGER;
+ buf: ARRAY 5 OF INTEGER;
+BEGIN i := 0;
+ REPEAT buf[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;
+ REPEAT DEC(i); Write(CHR(buf[i] + ORD("0"))) UNTIL i = 0
+END WriteInt
+
+
+
+PROCEDURE log2(x: INTEGER): INTEGER;
+ VAR y: INTEGER; (*assume x>0*)
+BEGIN y := 0;
+ WHILE x > 1 DO x := x DIV 2; INC(y) END;
+ RETURN y
+END log2
+
+
+
+
+ The following table lists the predefined procedures. Some are generic procedures, i.e. they apply to several types of operands. v stands for a variable, x and n for expressions, and T for a type.
+
+ Function procedures:
+
+
+
+
+
+ Type conversion functions:
+
+
+
+
+
+ Proper procedures:
+
+
+
+
+
+ The function FLOOR(x) yields the largest integer not greater than x.
+
+
+FLOOR(1.5) = 1 FLOOR(-1.5) = -2
+
+
+ The parameter n of PACK represents the exponent of x. PACK(x, y) is equivalent to x := x * 2y. UNPK is the reverse operation. The resulting x is normalized, such that 1.0 <= x < 2.0.
+
+
+
+ A module is a collection of declarations of constants, types, variables, and procedures, and a sequence of statements for the purpose of assigning initial values to the variables. A module typically constitutes a text that is compilable as a unit.
+
+
+module = MODULE ident ";" [ImportList] DeclarationSequence
+ [BEGIN StatementSequence] END ident "." .
+ImportList = IMPORT import {"," import} ";" .
+Import = ident [":=" ident].
+
+
+ The import list specifies the modules of which the module is a client. If an identifier x is exported from a module M, and if M is listed in a module's import list, then x is referred to as M.x. If the form “M := M1” is used in the import list, an exported object x declared within M1 is referenced in the importing module as M.x .
+
+ Identifiers that are to be visible in client modules, i.e. which are to be exported, must be marked by an asterisk (export mark) in their declaration. Variables are always exported in read-only mode.
+
+ The statement sequence following the symbol BEGIN is executed when the module is added to a system (loaded). Individual (parameterless) procedures can thereafter be activated from the system, and these procedures serve as commands.
+
+ Example:
+
+
+MODULE Out; (*exported procedures: Write, WriteInt, WriteLn*)
+ IMPORT Texts, Oberon;
+ VAR W: Texts.Writer;
+
+ PROCEDURE Write*(ch: CHAR);
+ BEGIN Texts.Write(W, ch)
+ END;
+
+ PROCEDURE WriteInt*(x, n: INTEGER);
+ VAR i: INTEGER; a: ARRAY 16 OF CHAR;
+ BEGIN i := 0;
+ IF x < 0 THEN Texts.Write(W, "-"); x := -x END ;
+ REPEAT a[i] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(i) UNTIL x = 0;
+ REPEAT Texts.Write(W, " "); DEC(n) UNTIL n <= i;
+ REPEAT DEC(i); Texts.Write(W, a[i]) UNTIL i = 0
+ END WriteInt;
+
+ PROCEDURE WriteLn*;
+ BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+ END WriteLn;
+
+BEGIN Texts.OpenWriter(W)
+END Out.
+
+
+
+
+ The optional module SYSTEM contains definitions that are necessary to program low-level operations referring directly to resources particular to a given computer and/or implementation. These include for example facilities for accessing devices that are controlled by the computer, and perhaps facilities to break the data type compatibility rules otherwise imposed by the language definition.
+
+ There are two reasons for providing facilities in Module SYSTEM; (1) Their value is implementation-dependent, that is, it is not derivable from the language's definition, and (2) they may corrupt a system (e.g. PUT). It is strongly recommended to restrict their use to specific low-level modules, as such modules are inherently non-portable and not “type-safe”. However, they are easily recognized due to the identifier SYSTEM appearing in the module's import lists. The subsequent definitions are generally applicable. However, individual implementations may include in their module SYSTEM additional definitions that are particular to the specific, underlying computer. In the following, v stands for a variable, x, a, and n for expressions.
+
+ Function procedures:
+
+
+
+
+
+ Proper procedures:
+
+
+
+
+
+ The following are additional procedures accepted by the compiler for the RISC processor:
+
+ Function procedures:
+
+
+
+
+
+ Proper procedures:
+
+
+
+
+
+
+
+ The Syntax of Oberon
+
+
+letter = "A" | "B" | ... | "Z" | "a" | "b" | ... | "z".
+digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".
+hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".
+
+
+
+ident = letter {letter | digit}.
+qualident = [ident "."] ident.
+identdef = ident ["*"].
+
+
+
+integer = digit {digit} | digit {hexDigit} "H".
+real = digit {digit} "." {digit} [ScaleFactor].
+ScaleFactor = "E" ["+" | "-"] digit {digit}.
+number = integer | real.
+string = """ {character} """ | digit {hexDigit} "X".
+
+
+
+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.
+
+
+
+module = MODULE ident ";" [ImportList] DeclarationSequence
+ [BEGIN StatementSequence] END ident "." .
+ImportList = IMPORT import {"," import} ";".
+import = ident [":=" ident].
+
+
+
diff --git a/share/man/man1/obnc-compile.1 b/share/man/man1/obnc-compile.1
new file mode 100644
index 0000000..91e1fe1
--- /dev/null
+++ b/share/man/man1/obnc-compile.1
@@ -0,0 +1,37 @@
+.TH OBNC-COMPILE 1
+.SH NAME
+obnc-compile \- compile an Oberon module to C
+.SH SYNOPSIS
+.B obnc-compile
+[\fB\-e\fR | \fB\-l\fR]
+.IR MODULE.obn
+.br
+.B obnc-compile
+(\fB\-h\fR | \fB\-v\fR)
+.SH DESCRIPTION
+.B obnc-compile
+compiles an Oberon module to C. All output files (C implementation file, C header file, symbol file and import list file) are stored in the subdirectory
+.IR .obnc .
+.P
+The compiler accepts the Oberon language as defined in "The Programming Language Oberon", revision 2013-10-01 / 2016-05-03 (Oberon-07). The target language is ANSI C (C89).
+.SH OPTIONS
+.TP
+.BR \-e
+Create an entry point function (main).
+.TP
+.BR \-h
+Display help and exit.
+.TP
+.BR \-l
+Print names of imported modules to standard output and exit.
+.TP
+.BR \-v
+Display version and exit.
+.SH ENVIRONMENT
+.IP OBNC_IMPORT_PATH
+See
+.BR obnc-path (1)
+.SH AUTHOR
+Written by Karl Landstr\[:o]m
+.SH "SEE ALSO"
+.BR obnc (1), obnc-path (1)
diff --git a/share/man/man1/obnc-path.1 b/share/man/man1/obnc-path.1
new file mode 100644
index 0000000..d006ddb
--- /dev/null
+++ b/share/man/man1/obnc-path.1
@@ -0,0 +1,35 @@
+.TH OBNC-PATH 1
+.SH NAME
+obnc-path \- print directory path for Oberon module
+.SH SYNOPSIS
+.B obnc-path
+MODULE
+.br
+.B obnc-path
+(\fB\-h\fR | \fB\-v\fR)
+.SH DESCRIPTION
+.B obnc-path
+prints the directory path for an Oberon module. For a module M, the printed path is the first directory found which contains either
+.I M.obn
+,
+.IR .obnc/M.sym
+or
+.IR M.sym .
+.P
+First the current directory is searched. Then paths in OBNC_IMPORT_PATH are searched. Finally the default library directory in the OBNC installation path is searched.
+.P
+For each path P, modules are searched both in P and in first-level subdirectories of P. Subdirectories represent individual libraries and are expected to be in lowercase. For the modules in a subdirectory L, only modules prefixed with L followed by an uppercase letter are searched. The other modules in L are considered local to the library.
+.SH OPTIONS
+.TP
+.BR \-h
+Display help and exit.
+.TP
+.BR \-v
+Display version and exit.
+.SH ENVIRONMENT
+.IP OBNC_IMPORT_PATH
+Colon-separated list of paths to search for Oberon modules.
+.SH AUTHOR
+Written by Karl Landstr\[:o]m
+.SH "SEE ALSO"
+.BR obnc (1), obnc-compile (1)
diff --git a/share/man/man1/obnc.1 b/share/man/man1/obnc.1
new file mode 100644
index 0000000..be7398b
--- /dev/null
+++ b/share/man/man1/obnc.1
@@ -0,0 +1,127 @@
+.TH OBNC 1
+.SH NAME
+obnc \- build an executable for an Oberon module
+.SH SYNOPSIS
+.B obnc
+[\fB\-v\fR | \fB\-V\fR]
+.IR MODULE.obn
+.br
+.B obnc
+(\fB\-h\fR | \fB\-v\fR)
+.SH DESCRIPTION
+.B obnc
+builds an executable file for an Oberon module. Before the module is compiled, object files for imported modules are recursively created or updated as needed. Oberon modules are first compiled to C with
+.BR obnc-compile .
+Each C file is then compiled to object code with an external C compiler. Finally, the object files are linked into an executable program. All output files except the final executable are stored in the subdirectory
+.IR .obnc .
+.P
+If for any module M there exists a file named
+.I M.c
+in the same directory as
+.I M.obn
+then
+.I M.c
+will be used as the input to the C compiler instead of the generated C file. This provides a mechanism to implement a module in C.
+.P
+For any module M, environment variables for the C compiler specific to M and environment variables for the linker can be defined in a file named
+.IR M.env ,
+located in the same directory as
+.IR M.obn .
+.SH OPTIONS
+.TP
+.BR \-h
+Display help and exit.
+.TP
+.BR \-v
+Without argument, display version and exit. Otherwise, output progress of compiled modules.
+.TP
+.BR \-V
+Output progress of compiled modules with compiler and linker subcommands.
+.SH ENVIRONMENT
+.IP CC
+Specifies the C compiler to use (default is cc).
+.IP CFLAGS
+Options for the C compiler.
+.IP LDFLAGS
+Additional options for the linker.
+.IP LDLIBS
+Additional libraries to link with.
+.IP OBNC_IMPORT_PATH
+See
+.BR obnc-path (1)
+.SH EXAMPLES
+.SS Getting Started
+In Oberon, the program to print "hello, world" is
+.P
+.RS
+MODULE hello;
+.P
+.RS
+IMPORT Out;
+.P
+.RE
+BEGIN
+.RS
+Out.String("hello, world");
+.br
+Out.Ln
+.RE
+END hello.
+.RE
+.P
+Save the above module to a file named
+.IR hello.obn
+and compile it with the command
+.P
+.RS
+obnc hello.obn
+.RE
+.P
+This will create an executable file named
+.IR hello .
+When you run
+.IR hello
+with the command
+.P
+.RS
+\[char46]/hello
+.RE
+.P
+it should print
+.P
+.RS
+hello, world
+.RE
+.SS Interfacing to C
+To implement a module M in C:
+.IP 1. 3
+Create a file named
+.I M.obn
+with the the exported declarations
+.IP 2. 3
+Create a file named
+.I MTest.obn
+which imports M (and preferably write unit tests for M)
+.IP 3. 3
+Build MTest with the command
+.P
+.RS
+obnc MTest.obn
+.RE
+.P
+.IP 4. 3
+Copy the generated file
+.IR .obnc/M.c
+to the current directory. Delete the generator comment on the first line and change the path in the include directive from
+.IR M.h
+to
+.IR .obnc/M.h .
+.IP 5. 3
+Implement
+.IR M.c .
+.P
+Note: The initialization function M_Init is called each time a client module imports M. Its statements should therefore be guarded with an initialization flag to make sure they are executed only once.
+.SH AUTHOR
+Written by Karl Landstr\[:o]m
+.SH "SEE ALSO"
+.BR obnc-compile (1), obnc-path (1)
diff --git a/share/man/man1/obncdoc.1 b/share/man/man1/obncdoc.1
new file mode 100644
index 0000000..5faf219
--- /dev/null
+++ b/share/man/man1/obncdoc.1
@@ -0,0 +1,26 @@
+.TH OBNCDOC 1
+.SH NAME
+obncdoc \- extract exported features from Oberon modules
+.SH SYNOPSIS
+.B obncdoc
+[\fB\-h\fR | \fB\-v\fR]
+.SH DESCRIPTION
+.B obncdoc
+creates HTML definitions and index from Oberon source files in the current directory. Each definition contains the exported declarations and the exported comments (start with an asterisk) for the corresponding module. The definition files are created, updated or deleted only as needed. A default style file,
+.IR style.css ,
+is created only if not present. This provides for custom style sheets. All output is written to the directory
+.IR obncdoc .
+Oberon source files are expected to have the filename extension
+.IR .obn .
+.P
+.B obncdoc
+is not a complete parser so no syntax (or semantics) checks are performed. Also, for exported identifiers, a source file is expected to have at most one declaration per line.
+.SH OPTIONS
+.TP
+.BR \-h
+Display help and exit.
+.TP
+.BR \-v
+Display version and exit.
+.SH AUTHOR
+Written by Karl Landstr\[:o]m
diff --git a/src/Config.c b/src/Config.c
new file mode 100644
index 0000000..d328424
--- /dev/null
+++ b/src/Config.c
@@ -0,0 +1,42 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Config.h"
+#include
+
+const char *Config_Prefix(void)
+{
+ const char *prefix;
+
+ prefix = getenv("OBNC_PREFIX");
+ if (prefix == NULL) {
+ prefix = CONFIG_DEFAULT_PREFIX;
+ }
+ return prefix;
+}
+
+
+const char *Config_LibDir(void)
+{
+ const char *libdir;
+
+ libdir = getenv("OBNC_LIBDIR");
+ if (libdir == NULL) {
+ libdir = CONFIG_DEFAULT_LIBDIR;
+ }
+ return libdir;
+}
diff --git a/src/Files.c b/src/Files.c
new file mode 100644
index 0000000..eea8827
--- /dev/null
+++ b/src/Files.c
@@ -0,0 +1,137 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Files.h"
+#include /*POSIX*/
+#include /*POSIX*/
+#include /*POSIX*/
+#include
+#include
+#include
+#include
+#include
+
+int Files_Exists(const char filename[])
+{
+ int error;
+
+ assert(filename != NULL);
+
+ error = access(filename, F_OK);
+ return ! error;
+}
+
+
+FILE *Files_New(const char filename[])
+{
+ FILE *newFile;
+
+ assert(filename != NULL);
+
+ newFile = fopen(filename, "w+");
+ if (newFile == NULL) {
+ fprintf(stderr, "obnc-compile: error: Cannot open new file: %s: %s\n", filename, strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+
+ assert(newFile != NULL);
+
+ return newFile;
+}
+
+
+FILE *Files_Old(const char filename[], int mode)
+{
+ const char *fopenMode;
+ FILE *oldFile;
+
+ assert(filename != NULL);
+ assert((mode == FILES_READ) || (mode == FILES_WRITE));
+ assert(Files_Exists(filename));
+
+ if (mode == FILES_READ) {
+ fopenMode = "r";
+ } else {
+ fopenMode = "w";
+ }
+ oldFile = fopen(filename, fopenMode);
+ if (oldFile == NULL) {
+ fprintf(stderr, "obnc-compile: error: Cannot open old file: %s: %s\n", filename, strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+
+ assert(oldFile != NULL);
+
+ return oldFile;
+}
+
+
+void Files_Close(FILE *file)
+{
+ int error;
+
+ error = fclose(file);
+ if (error) {
+ fprintf(stderr, "obnc-compile: error: Closing file failed");
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+void Files_Move(const char sourceFilename[], const char destFilename[])
+{
+ int error;
+
+ assert(sourceFilename != NULL);
+ assert(destFilename != NULL);
+
+ error = rename(sourceFilename, destFilename);
+ if (error) {
+ fprintf(stderr, "obnc-compile: error: Cannot move file %s to %s: %s\n", sourceFilename, destFilename, strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+void Files_Remove(const char filename[])
+{
+ int error;
+
+ assert(filename != NULL);
+
+ error = remove(filename);
+ if (error) {
+ fprintf(stderr, "obnc-compile: error: Cannot remove file: %s: %s\n", filename, strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+void Files_CreateDir(const char dirname[])
+{
+ const mode_t accessMode = 0755;
+ int error;
+
+ assert(dirname != NULL);
+ assert(! Files_Exists(dirname));
+
+ error = mkdir(dirname, accessMode);
+ if (error) {
+ fprintf(stderr, "obnc-compile: error: Cannot create directory: %s: %s\n", dirname, strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+}
diff --git a/src/Files.h b/src/Files.h
new file mode 100644
index 0000000..be11da8
--- /dev/null
+++ b/src/Files.h
@@ -0,0 +1,41 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef FILES_H
+#define FILES_H
+
+#include
+
+/*file access modes*/
+#define FILES_READ 0
+#define FILES_WRITE 1
+
+int Files_Exists(const char filename[]);
+
+FILE *Files_New(const char filename[]);
+
+FILE *Files_Old(const char filename[], int mode);
+
+void Files_CreateDir(const char dirname[]);
+
+void Files_Move(const char sourceFilename[], const char destFilename[]);
+
+void Files_Remove(const char filename[]);
+
+void Files_Close(FILE *file);
+
+#endif
diff --git a/src/Generate.c b/src/Generate.c
new file mode 100644
index 0000000..ac82a7f
--- /dev/null
+++ b/src/Generate.c
@@ -0,0 +1,2685 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Generate.h"
+#include "Config.h"
+#include "Files.h"
+#include "Maps.h"
+#include "Oberon.h"
+#include "Trees.h"
+#include "Types.h"
+#include "Util.h"
+#include "../lib/obnc/OBNC.h"
+#include "y.tab.h"
+#include /*POSIX*/
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+
+static const char *inputModuleName;
+static int isEntryPointModule;
+
+static char *headerComment;
+static char tempCFilepath[PATH_MAX];
+static char tempHFilepath[PATH_MAX];
+static FILE *cFile;
+static FILE *hFile;
+
+static Trees_Node importList;
+
+static Trees_Node declaredTypeIdent;
+
+static Trees_Node caseVariable;
+static Trees_Node caseLabelType;
+
+static long int procedureDeclStart;
+static struct ProcedureDeclNode {
+ Trees_Node procIdent;
+ Maps_Map localProcedures;
+ Trees_Node runtimeInitVars;
+ char *partialDecl;
+ struct ProcedureDeclNode *next;
+} *procedureDeclStack;
+
+static void Indent(FILE *file, int n)
+{
+ int i;
+
+ for (i = 0; i < n; i++) {
+ fputc('\t', file);
+ }
+}
+
+static void Generate(Trees_Node tree, FILE *file, int indent);
+
+
+/*IDENTIFIER GENERATORS*/
+
+static int ModulePrefixNeeded(Trees_Node ident)
+{
+ int imported, indirectlyImported, exported, global, isType, isField;
+
+ imported = Trees_Imported(ident);
+ indirectlyImported = ! imported && (strchr(Trees_Name(ident), '.') != NULL);
+ exported = Trees_Exported(ident);
+ global = ! Trees_Local(ident);
+ isType = Types_IsType(ident);
+ isField = Trees_Kind(ident) == TREES_FIELD_KIND;
+
+ return ! isEntryPointModule && ! imported && ! indirectlyImported && ((exported && ! isField) || (global && isType));
+}
+
+
+static void GenerateLocalProcedurePrefix(Trees_Node ident, struct ProcedureDeclNode *node, FILE *file)
+{
+ if (node != NULL) {
+ GenerateLocalProcedurePrefix(ident, node->next, file);
+ fprintf(file, "%s_", Trees_Name(node->procIdent));
+ }
+}
+
+
+static void GenerateLocalProcedureIdent(Trees_Node ident, FILE *file, int indent)
+{
+ assert(procedureDeclStack != NULL);
+ Indent(file, indent);
+ if (Maps_HasKey(Trees_Name(ident), procedureDeclStack->localProcedures)) {
+ GenerateLocalProcedurePrefix(ident, procedureDeclStack, file);
+ } else {
+ GenerateLocalProcedurePrefix(ident, procedureDeclStack->next, file);
+ }
+ fprintf(file, "%s_Local", Trees_Name(ident));
+}
+
+
+static void GenerateIdent(Trees_Node ident, FILE *file, int indent)
+{
+ const char *name;
+ char *dotPtr;
+
+ name = Trees_UnaliasedName(ident);
+ if ((Trees_Kind(ident) == TREES_TYPE_KIND) && Types_Basic(Trees_Type(ident))) {
+ Generate(Trees_Type(ident), file, indent);
+ } else if (Trees_Internal(ident)) {
+ Indent(file, indent);
+ fprintf(file, "%s", name);
+ } else if (ModulePrefixNeeded(ident)) {
+ Indent(file, indent);
+ fprintf(file, "%s_%s_", inputModuleName, name);
+ } else if ((Trees_Kind(ident) == TREES_PROCEDURE_KIND) && Trees_Local(ident)) {
+ GenerateLocalProcedureIdent(ident, file, indent);
+ } else {
+ dotPtr = strchr(name, '.');
+ if (dotPtr != NULL) {
+ *dotPtr = '_';
+ }
+ Indent(file, indent);
+ fprintf(file, "%s_", name);
+ if (dotPtr != NULL) {
+ *dotPtr = '.';
+ }
+ }
+}
+
+
+static const char *CurrentDirname(void)
+{
+ static char dir[PATH_MAX + 1];
+ static const char *result = NULL;
+ const char *p;
+
+ if (result == NULL) {
+ p = getcwd(dir, sizeof dir);
+ if (p != NULL) {
+ result = strrchr(dir, '/');
+ assert(result != NULL);
+ result++;
+ } else {
+ fprintf(stderr, "obnc-compile: cannot get current directory: %s\n", strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+ }
+ assert(result != NULL);
+ return result;
+}
+
+
+static const char *DirPrefix(void)
+{
+ static char result[16];
+ static int initialized = 0;
+ const char *dir;
+ int i, j;
+
+ if (! initialized) {
+ dir = CurrentDirname();
+ i = 0;
+ j = 0;
+ while ((dir[i] != '\0') && (j < LEN(result) - 2)) {
+ if (((j == 0) && isalpha(dir[i])) || ((j > 0) && isalnum(dir[i]))) {
+ result[j] = dir[i];
+ j++;
+ }
+ i++;
+ }
+ result[j] = '_';
+ result[j + 1] = '\0';
+ initialized = 1;
+ }
+ return result;
+}
+
+
+static void GenerateObjectFileSymbolDefinitions(Trees_Node identList, const char *suffix, FILE *file, int indent)
+{
+ const char *dirPrefix;
+ Trees_Node ident;
+
+ /*NOTE: To prevent potential name collisions at link time when two modules with the same name (from different directories) are combined, we add a directory prefix to object file symbols with external linkage.*/
+
+ dirPrefix = DirPrefix();
+ if (strcmp(dirPrefix, "") != 0) {
+ while (identList != NULL) {
+ ident = Trees_Left(identList);
+ Indent(file, indent);
+ fprintf(file, "#define ");
+ GenerateIdent(ident, file, 0);
+ fprintf(file, "%s %s", suffix, dirPrefix);
+ GenerateIdent(ident, file, 0);
+ fprintf(file, "%s\n", suffix);
+ identList = Trees_Right(identList);
+ }
+ }
+}
+
+
+/*LITERAL GENERATORS*/
+
+static void GenerateReal(OBNC_LONGR double value, FILE *file)
+{
+ int formattedAsInteger;
+#ifdef OBNC_CONFIG_USE_LONG_REAL
+ char buffer[LDBL_DIG + 10]; /*LDBL_DIG + strlen("-") + strlen(".") + strlen("e+9999") + strlen("L") + 1*/
+
+ sprintf(buffer, "%.*" OBNC_REAL_MOD_W "g", LDBL_DIG, value);
+#else
+ char buffer[DBL_DIG + 8]; /*DBL_DIG + strlen("-") + strlen(".") + strlen("e+999") + 1*/
+
+ sprintf(buffer, "%.*g", DBL_DIG, value);
+#endif
+ if (strcmp(buffer, "inf") == 0) {
+ fprintf(file, "(1.0 / 0.0)");
+ } else if (strcmp(buffer, "-inf") == 0) {
+ fprintf(file, "(-1.0 / 0.0)");
+ } else if (strcmp(buffer, "nan") == 0) {
+ fprintf(file, "(0.0 / 0.0)");
+ } else if (strcmp(buffer, "-nan") == 0) {
+ fprintf(file, "(0.0 / 0.0)");
+ } else {
+ formattedAsInteger = (strchr(buffer, '.') == NULL) && (strchr(buffer, 'e') == 0);
+ if (formattedAsInteger) {
+ strcat(buffer, ".0");
+ }
+#ifdef OBNC_CONFIG_USE_LONG_REAL
+ strcat(buffer, "L");
+#endif
+ fprintf(file, "%s", buffer);
+ }
+}
+
+
+static void GenerateString(const char s[], FILE *file)
+{
+ int i;
+
+ fputc('"', file);
+ i = 0;
+ while (s[i] != '\0') {
+ if ((s[i] >= 0) && ((unsigned char) s[i] <= 127)) {
+ if (isprint(s[i])) {
+ if ((s[i] == '"') || (s[i] == '\\')) {
+ fputc('\\', file);
+ }
+ fputc(s[i], file);
+ } else {
+ fprintf(file, "\" \"\\x%02x\" \"", (unsigned char) s[i]);
+ }
+ } else {
+ fputc(s[i], file);
+ }
+ i++;
+ }
+ fputc('"', file);
+}
+
+
+static void GenerateChar(char ch, FILE *file)
+{
+ switch (ch) {
+ case '\'':
+ case '\\':
+ fprintf(file, "'\\%c'", ch);
+ break;
+ default:
+ if (isprint(ch)) {
+ fprintf(file, "'%c'", ch);
+ } else {
+ fprintf(file, "'\\x%x'", (unsigned char) ch);
+ }
+ }
+}
+
+
+/*CONSTANT DECLARATION GENERATORS*/
+
+void Generate_ConstDeclaration(Trees_Node ident)
+{
+ if (Trees_Exported(ident)) {
+ /*add constant declaration to header file to provide access to it from hand-written C file*/
+ fprintf(hFile, "\n#define ");
+ Generate(ident, hFile, 0);
+ fprintf(hFile, " ");
+ Generate(Trees_Value(ident), hFile, 0);
+ fprintf(hFile, "\n");
+ }
+}
+
+
+/*TYPE DECLARATION GENERATORS*/
+
+static void GenerateDeclaration(Trees_Node declaration, FILE *file, int indent);
+
+static void GenerateFields(Trees_Node type, FILE *file, int indent)
+{
+ Trees_Node typeDesc, baseType, pointerBaseType, fieldListSeq, identList;
+
+ assert(type != NULL);
+
+ typeDesc = Types_Descriptor(type);
+ fieldListSeq = Types_Fields(typeDesc);
+ baseType = Types_RecordBaseType(typeDesc);
+ if (baseType != NULL) {
+ if (Types_IsPointer(baseType)) {
+ pointerBaseType = Types_PointerBaseType(baseType);
+ if (Trees_Symbol(pointerBaseType) == RECORD) {
+ Indent(file, indent);
+ fprintf(file, "struct ");
+ Generate(baseType, file, 0);
+ } else {
+ assert(Trees_Symbol(pointerBaseType) == IDENT);
+ Generate(pointerBaseType, file, indent);
+ }
+ } else {
+ Generate(baseType, file, indent);
+ }
+ fprintf(file, " base;\n");
+ } else if (fieldListSeq == NULL) {
+ Indent(file, indent);
+ fprintf(file, "char dummy;\n");
+ }
+ while (fieldListSeq != NULL) {
+ identList = Trees_Left(fieldListSeq);
+ GenerateDeclaration(Trees_NewNode(TREES_NOSYM, identList, NULL), file, indent);
+ fieldListSeq = Trees_Right(fieldListSeq);
+ }
+}
+
+
+static void GenerateRecord(Trees_Node type, Trees_Node declIdent, FILE *file, int indent)
+{
+ Indent(file, indent);
+ fprintf(file, "struct ");
+ if ((declIdent != NULL) && (Trees_Kind(declIdent) == TREES_TYPE_KIND)) {
+ Generate(declIdent, file, 0);
+ fprintf(file, " ");
+ }
+ fprintf(file, "{\n");
+ GenerateFields(type, file, indent + 1);
+ Indent(file, indent);
+ fprintf(file, "}");
+}
+
+
+static Trees_Node TypeDescIdent(Trees_Node type)
+{
+ Trees_Node result, initialIdent, unaliasedIdent, typeStruct, pointerBaseType;
+
+ result = NULL;
+ initialIdent = type;
+ if (Trees_Symbol(type) == POINTER) {
+ initialIdent = Trees_Left(type);
+ assert(Trees_Symbol(initialIdent) == IDENT);
+ }
+ unaliasedIdent = Types_UnaliasedIdent(initialIdent);
+ typeStruct = Types_Structure(unaliasedIdent);
+ switch (Trees_Symbol(typeStruct)) {
+ case RECORD:
+ result = unaliasedIdent;
+ break;
+ case POINTER:
+ pointerBaseType = Types_PointerBaseType(typeStruct);
+ switch (Trees_Symbol(pointerBaseType)) {
+ case RECORD:
+ result = unaliasedIdent;
+ break;
+ case IDENT:
+ result = Types_UnaliasedIdent(pointerBaseType);
+ break;
+ default:
+ assert(0);
+ }
+ break;
+ default:
+ assert(0);
+ }
+
+ assert(result != NULL);
+
+ return result;
+}
+
+
+static void GenerateStorageClassSpecifier(Trees_Node ident, FILE *file)
+{
+ if (Trees_Kind(ident) == TREES_TYPE_KIND) {
+ fprintf(file, "typedef ");
+ } else if (! Trees_Local(ident)) {
+ if (file == hFile) {
+ fprintf(file, "extern ");
+ } else if (! Trees_Exported(ident)) {
+ fprintf(file, "static ");
+ }
+ }
+}
+
+
+static int TypeIncomplete(Trees_Node type, Trees_Node ident)
+{
+ return ((Trees_Kind(ident) == TREES_TYPE_KIND)
+ && ((Trees_Type(type) == NULL) || Types_IsRecord(type)))
+ || (type == declaredTypeIdent);
+}
+
+
+static void GenerateTypeSpecifier(Trees_Node ident, Trees_Node type, FILE *file, int indent)
+{
+ switch (Trees_Symbol(type)) {
+ case IDENT:
+ if (TypeIncomplete(type, ident)) {
+ fprintf(file, "struct ");
+ }
+ Generate(type, file, 0);
+ break;
+ case ARRAY:
+ GenerateTypeSpecifier(ident, Types_ElementType(type), file, indent);
+ break;
+ case RECORD:
+ GenerateRecord(type, ident, file, indent);
+ break;
+ case POINTER:
+ GenerateTypeSpecifier(ident, Types_PointerBaseType(type), file, indent);
+ break;
+ case PROCEDURE:
+ if (Types_ResultType(type) != NULL) {
+ GenerateTypeSpecifier(ident, Types_ResultType(type), file, indent);
+ } else {
+ Indent(file, indent);
+ fprintf(file, "void");
+ }
+ break;
+ default:
+ Generate(type, file, indent);
+ }
+}
+
+
+static void GenerateFormalParameterList(Trees_Node paramList, FILE *file, int indent);
+
+static void GenerateDeclarator(Trees_Node ident, FILE *file)
+{
+ Trees_Node type, firstNonArrayType, resultType;
+
+ type = Trees_Type(ident);
+ firstNonArrayType = type;
+ while (Trees_Symbol(firstNonArrayType) == ARRAY) {
+ firstNonArrayType = Types_ElementType(firstNonArrayType);
+ }
+ if ((Trees_Symbol(firstNonArrayType) == POINTER)
+ || (Types_IsPointer(firstNonArrayType) && TypeIncomplete(firstNonArrayType, ident))) {
+ fprintf(file, "*");
+ } else if (Trees_Symbol(firstNonArrayType) == PROCEDURE) {
+ resultType = Types_ResultType(firstNonArrayType);
+ if ((declaredTypeIdent != NULL) && (resultType == declaredTypeIdent)) {
+ fprintf(file, "*");
+ }
+ fprintf(file, "(*");
+ }
+ Generate(ident, file, 0);
+ while (Trees_Symbol(type) == ARRAY) {
+ fprintf(file, "[%" OBNC_INT_MOD "d]", Trees_Integer(Types_ArrayLength(type)));
+ type = Types_ElementType(type);
+ }
+ if (Trees_Symbol(firstNonArrayType) == PROCEDURE) {
+ fprintf(file, ")(");
+ if (Types_Parameters(type) != NULL) {
+ GenerateFormalParameterList(Types_Parameters(firstNonArrayType), file, 0);
+ } else {
+ fprintf(file, "void");
+ }
+ fprintf(file, ")");
+ }
+}
+
+
+static void SearchPointersAndProceduresRec(Trees_Node type, int *hasPointer, int *hasProcedure)
+{
+ Trees_Node recordBaseType, fieldListSeq, fieldList, ident;
+
+ if ((type != NULL) && ! (*hasPointer && *hasProcedure)) {
+ switch (Trees_Symbol(Types_Structure(type))) {
+ case ARRAY:
+ SearchPointersAndProceduresRec(Types_ElementType(type), hasPointer, hasProcedure);
+ break;
+ case RECORD:
+ recordBaseType = Types_RecordBaseType(type);
+ if (recordBaseType != NULL) {
+ SearchPointersAndProceduresRec(
+ Types_Descriptor(recordBaseType), hasPointer, hasProcedure);
+ }
+ fieldListSeq = Types_Fields(type);
+ while ((fieldListSeq != NULL) && ! (*hasPointer && *hasProcedure)) {
+ fieldList = Trees_Left(fieldListSeq);
+ ident = Trees_Left(fieldList);
+ SearchPointersAndProceduresRec(Trees_Type(ident), hasPointer, hasProcedure);
+ fieldListSeq = Trees_Right(fieldListSeq);
+ }
+ break;
+ case POINTER:
+ *hasPointer = 1;
+ break;
+ case PROCEDURE:
+ *hasProcedure = 1;
+ break;
+ }
+ }
+}
+
+
+static void SearchPointersAndProcedures(Trees_Node type, int *hasPointer, int *hasProcedure)
+{
+ *hasPointer = 0;
+ *hasProcedure = 0;
+ SearchPointersAndProceduresRec(type, hasPointer, hasProcedure);
+}
+
+
+static void GenerateDeclaration(Trees_Node declaration, FILE *file, int indent)
+{
+ Trees_Node identList, firstIdent, ident;
+ int hasPointer, hasProcedure;
+
+ if (Trees_Symbol(Trees_Left(declaration)) == IDENT) {
+ identList = Trees_NewNode(TREES_IDENT_LIST, Trees_Left(declaration), NULL);
+ } else {
+ identList = Trees_Left(declaration);
+ }
+ firstIdent = Trees_Left(identList);
+
+ Indent(file, indent);
+ GenerateStorageClassSpecifier(firstIdent, file);
+ GenerateTypeSpecifier(firstIdent, Trees_Type(firstIdent), file, indent);
+ fprintf(file, " ");
+
+ do {
+ ident = Trees_Left(identList);
+ GenerateDeclarator(ident, file);
+
+ if ((Trees_Kind(firstIdent) == TREES_VARIABLE_KIND) && Trees_Local(firstIdent) && (file != hFile)) {
+ switch (Trees_Symbol(Types_Structure(Trees_Type(firstIdent)))) {
+ case ARRAY:
+ case RECORD:
+ SearchPointersAndProcedures(Trees_Type(firstIdent), &hasPointer, &hasProcedure);
+ if (hasPointer || hasProcedure) {
+ fprintf(file, " = {0}");
+ }
+ break;
+ case POINTER:
+ case PROCEDURE:
+ fprintf(file, " = 0");
+ break;
+ }
+ }
+ if (Trees_Right(identList) != NULL) {
+ fprintf(file, ", ");
+ }
+ identList = Trees_Right(identList);
+ } while (identList != NULL);
+
+ fprintf(file, ";\n");
+}
+
+
+static void GenerateTypeIDs(Trees_Node type)
+{
+ Trees_Node baseType;
+
+ baseType = Types_RecordBaseType(type);
+ if (baseType != NULL) {
+ GenerateTypeIDs(baseType);
+ fprintf(cFile, ", ");
+ }
+ fprintf(cFile, "&");
+ Generate(TypeDescIdent(type), cFile, 0);
+ fprintf(cFile, "id");
+}
+
+
+static void GenerateHeapTypeDecl(Trees_Node typeIdent, FILE* file, int indent)
+{
+ Indent(file, indent);
+ fprintf(file, "struct ");
+ Generate(typeIdent, file, 0);
+ fprintf(file, "Heap {\n");
+ Indent(file, indent + 1);
+ fprintf(file, "const OBNC_Td *td;\n");
+ Indent(file, indent + 1);
+ fprintf(file, "struct ");
+ Generate(typeIdent, file, 0);
+ Indent(file, indent);
+ fprintf(file, " fields;\n");
+ Indent(file, indent);
+ fprintf(file, "};\n");
+}
+
+
+static void GenerateTypeDescDecl(Trees_Node typeIdent, int indent)
+{
+ int extensionLevel;
+ Trees_Node identList;
+ const char *storageClass;
+
+
+ /*generate type descriptor (type ID used for its unique address only)*/
+ extensionLevel = Types_ExtensionLevel(typeIdent);
+ if (ModulePrefixNeeded(typeIdent)) {
+ identList = Trees_NewNode(TREES_NOSYM, typeIdent, NULL);
+
+ fprintf(hFile, "\n");
+ GenerateObjectFileSymbolDefinitions(identList, "id", hFile, 0);
+ Indent(hFile, indent);
+ fprintf(hFile, "extern const int ");
+ Generate(typeIdent, hFile, 0);
+ fprintf(hFile, "id;\n\n");
+
+ GenerateObjectFileSymbolDefinitions(identList, "ids", hFile, 0);
+ Indent(hFile, indent);
+ fprintf(hFile, "extern const int *const ");
+ Generate(typeIdent, hFile, 0);
+ fprintf(hFile, "ids[%d];\n\n", extensionLevel + 1);
+
+ GenerateObjectFileSymbolDefinitions(identList, "td", hFile, 0);
+ Indent(hFile, indent);
+ fprintf(hFile, "extern const OBNC_Td ");
+ Generate(typeIdent, hFile, 0);
+ fprintf(hFile, "td;\n");
+
+ storageClass = "";
+ } else {
+ storageClass = "static ";
+ }
+ fprintf(cFile, "\n");
+ Indent(cFile, indent);
+ fprintf(cFile, "%sconst int ", storageClass);
+ Generate(typeIdent, cFile, 0);
+ fprintf(cFile, "id;\n");
+
+ Indent(cFile, indent);
+ fprintf(cFile, "%sconst int *const ", storageClass);
+ Generate(typeIdent, cFile, 0);
+ fprintf(cFile, "ids[%d] = {", extensionLevel + 1);
+ GenerateTypeIDs(typeIdent);
+ fprintf(cFile, "};\n");
+
+ Indent(cFile, indent);
+ fprintf(cFile, "%sconst OBNC_Td ", storageClass);
+ Generate(typeIdent, cFile, 0);
+ fprintf(cFile, "td = {");
+ Generate(typeIdent, cFile, 0);
+ fprintf(cFile, "ids, %d};\n", extensionLevel + 1);
+}
+
+
+void Generate_TypeDeclaration(Trees_Node ident)
+{
+ int indent = Trees_Local(ident)? 1: 0;
+ Trees_Node type, declaration, typeDescIdent;
+ int modulePrefixNeeded;
+
+ type = Trees_Type(ident);
+ modulePrefixNeeded = ModulePrefixNeeded(ident);
+
+ declaredTypeIdent = ident;
+ declaration = Trees_NewNode(TREES_NOSYM, ident, type);
+ if (modulePrefixNeeded) {
+ fprintf(hFile, "\n");
+ GenerateDeclaration(declaration, hFile, indent);
+ } else {
+ if (! Trees_Local(ident)) {
+ fprintf(cFile, "\n");
+ }
+ GenerateDeclaration(declaration, cFile, indent);
+ }
+ declaredTypeIdent = NULL;
+ if ((Trees_Symbol(type) == RECORD)
+ || ((Trees_Symbol(type) == POINTER) && (Trees_Symbol(Types_PointerBaseType(type)) == RECORD))) {
+ typeDescIdent = TypeDescIdent(ident);
+
+ if (modulePrefixNeeded) {
+ fprintf(hFile, "\n");
+ GenerateHeapTypeDecl(typeDescIdent, hFile, 0);
+ } else {
+ fprintf(cFile, "\n");
+ GenerateHeapTypeDecl(typeDescIdent, cFile, indent);
+ }
+ GenerateTypeDescDecl(typeDescIdent, indent);
+ }
+}
+
+
+/*VARIABLE DECLARATION GENERATORS*/
+
+static int HasExportedIdent(Trees_Node identList)
+{
+ while ((identList != NULL) && ! Trees_Exported(Trees_Left(identList))) {
+ identList = Trees_Right(identList);
+ }
+ return identList != NULL;
+}
+
+
+static int NameEquivalenceNeeded(Trees_Node type)
+{
+ int result;
+
+ assert(type != NULL);
+
+ switch (Trees_Symbol(type)) {
+ case ARRAY:
+ result = NameEquivalenceNeeded(Types_ElementType(type));
+ break;
+ case RECORD:
+ result = 1;
+ break;
+ case POINTER:
+ result = (Trees_Symbol(Types_PointerBaseType(type)) == RECORD);
+ break;
+ default:
+ result = 0;
+ }
+ return result;
+}
+
+
+static int DigitCount(int i)
+{
+ int n = 0;
+
+ do {
+ n++;
+ i = i / 10;
+ } while (i != 0);
+ return n;
+}
+
+
+void Generate_VariableDeclaration(Trees_Node identList)
+{
+ static int typeCounter;
+
+ char *newTypeName;
+ int newTypeNameLen, allExported;
+ Trees_Node ident, type, declaration, newTypeIdent, newTypeDecl, p, exportedIdents, nonExportedIdents, exportedDecl, nonExportedDecl;
+ int indent;
+
+ ident = Trees_Left(identList);
+ indent = Trees_Local(ident)? 1: 0;
+ type = Trees_Type(ident);
+ declaration = Trees_NewNode(TREES_NOSYM, identList, type);
+ if (! Trees_Local(ident)) {
+ fprintf(cFile, "\n");
+ }
+ if (HasExportedIdent(identList) && ! isEntryPointModule) {
+ fprintf(hFile, "\n");
+ if (NameEquivalenceNeeded(type)) {
+ /*declare anonymous type in header file*/
+ newTypeNameLen = strlen(inputModuleName) + strlen("_T") + DigitCount(typeCounter) + 1;
+ NEW_ARRAY(newTypeName, newTypeNameLen);
+ sprintf(newTypeName, "%s_T%d", inputModuleName, typeCounter);
+
+ newTypeIdent = Trees_NewIdent(newTypeName);
+ Trees_SetKind(TREES_TYPE_KIND, newTypeIdent);
+ Trees_SetType(type, newTypeIdent);
+ Trees_SetInternal(newTypeIdent);
+ newTypeDecl = Trees_NewNode(TREES_NOSYM, newTypeIdent, type);
+
+ GenerateDeclaration(newTypeDecl, hFile, indent);
+
+ /*replace anonymous type with named type*/
+ p = identList;
+ do {
+ ident = Trees_Left(p);
+ Trees_SetType(newTypeIdent, ident);
+ p = Trees_Right(p);
+ } while (p != NULL);
+
+ typeCounter++;
+ }
+
+ allExported = 1;
+ p = identList;
+ do {
+ ident = Trees_Left(p);
+ if (! Trees_Exported(ident)) {
+ allExported = 0;
+ }
+ p = Trees_Right(p);
+ } while ((p != NULL) && allExported);
+
+ if (allExported) {
+ GenerateObjectFileSymbolDefinitions(identList, "", hFile, indent);
+ GenerateDeclaration(declaration, hFile, indent);
+ GenerateDeclaration(declaration, cFile, indent);
+ } else {
+ exportedIdents = NULL;
+ nonExportedIdents = NULL;
+ p = identList;
+ do {
+ ident = Trees_Left(p);
+ if (Trees_Exported(ident)) {
+ exportedIdents = Trees_NewNode(TREES_IDENT_LIST, ident, exportedIdents);
+ } else {
+ nonExportedIdents = Trees_NewNode(TREES_IDENT_LIST, ident, nonExportedIdents);
+ }
+ p = Trees_Right(p);
+ } while (p != NULL);
+ assert(exportedIdents != NULL);
+ Trees_ReverseList(&exportedIdents);
+ exportedDecl = Trees_NewNode(TREES_NOSYM, exportedIdents, Trees_Right(declaration));
+ GenerateObjectFileSymbolDefinitions(exportedIdents, "", hFile, indent);
+ GenerateDeclaration(exportedDecl, hFile, indent);
+ GenerateDeclaration(exportedDecl, cFile, indent);
+ if (nonExportedIdents != NULL) {
+ Trees_ReverseList(&nonExportedIdents);
+ nonExportedDecl = Trees_NewNode(TREES_NOSYM, nonExportedIdents, Trees_Right(declaration));
+ GenerateDeclaration(nonExportedDecl, cFile, indent);
+ }
+ }
+
+ if (Trees_Symbol(type) != IDENT) {
+ /*reset original type*/
+ p = identList;
+ do {
+ ident = Trees_Left(p);
+ Trees_SetType(type, ident);
+ p = Trees_Right(p);
+ } while (p != NULL);
+ }
+ } else {
+ GenerateDeclaration(declaration, cFile, indent);
+ }
+}
+
+
+/*EXPRESSION GENERATORS*/
+
+static Trees_Node VarIdent(Trees_Node var)
+{
+ assert(Trees_Symbol(var) == TREES_DESIGNATOR);
+ return Trees_Left(var);
+}
+
+
+static Trees_Node VarSelector(Trees_Node var)
+{
+ assert(Trees_Symbol(var) == TREES_DESIGNATOR);
+ return Trees_Right(var);
+}
+
+
+static int IsVarParam(Trees_Node var)
+{
+ return (Trees_Kind(VarIdent(var)) == TREES_VAR_PARAM_KIND) && (VarSelector(var) == NULL);
+}
+
+
+static int IsProcedureCall(int symbol)
+{
+ int result;
+
+ switch (symbol) {
+ case TREES_ABS_PROC:
+ case TREES_ODD_PROC:
+ case TREES_LEN_PROC:
+ case TREES_LSL_PROC:
+ case TREES_ASR_PROC:
+ case TREES_ROR_PROC:
+ case TREES_FLOOR_PROC:
+ case TREES_FLT_PROC:
+ case TREES_ORD_PROC:
+ case TREES_CHR_PROC:
+ case TREES_INC_PROC:
+ case TREES_DEC_PROC:
+ case TREES_INCL_PROC:
+ case TREES_EXCL_PROC:
+ /*case TREES_NEW_PROC*/
+ case TREES_ASSERT_PROC:
+ case TREES_PACK_PROC:
+ case TREES_UNPK_PROC:
+ case TREES_PROCEDURE_CALL:
+ result = 1;
+ break;
+ default:
+ result = 0;
+ }
+ return result;
+}
+
+
+static void PrintCOperator(Trees_Node opNode, FILE *file)
+{
+ int leftType, rightType;
+
+ leftType = Trees_Symbol(Types_Structure(Trees_Type(Trees_Left(opNode))));
+ if (Trees_Right(opNode) != NULL) {
+ rightType = Trees_Symbol(Types_Structure(Trees_Type(Trees_Right(opNode))));
+ } else {
+ rightType = -1;
+ }
+
+ switch (Trees_Symbol(opNode)) {
+ case '#':
+ fprintf(file, "!=");
+ break;
+ case '&':
+ fprintf(file, "&&");
+ break;
+ case '*':
+ if (leftType == TREES_SET_TYPE) {
+ fprintf(file, "&");
+ } else {
+ fprintf(file, "*");
+ }
+ break;
+ case '+':
+ if ((leftType == TREES_SET_TYPE) && (rightType >= 0)) {
+ fprintf(file, "|");
+ } else {
+ fprintf(file, "+");
+ }
+ break;
+ case '-':
+ if (leftType == TREES_SET_TYPE) {
+ if (rightType == -1) {
+ fprintf(file, "~");
+ } else {
+ fprintf(file, "& ~");
+ }
+ } else {
+ fprintf(file, "-");
+ }
+ break;
+ case '/':
+ if (leftType == TREES_SET_TYPE) {
+ fprintf(file, "^");
+ } else {
+ fprintf(file, "/");
+ }
+ break;
+ case '<':
+ fprintf(file, "<");
+ break;
+ case '=':
+ fprintf(file, "==");
+ break;
+ case '>':
+ fprintf(file, ">");
+ break;
+ case '~':
+ fprintf(file, "! ");
+ break;
+ case OR:
+ fprintf(file, "||");
+ break;
+ case GE:
+ fprintf(file, ">=");
+ break;
+ case LE:
+ fprintf(file, "<=");
+ break;
+ default:
+ assert(0);
+ }
+}
+
+
+static void GenerateArrayLength(Trees_Node ident, Trees_Node arrayType, FILE *file)
+{
+ assert(Trees_Symbol(ident) == IDENT);
+ assert(Types_IsArray(arrayType));
+
+ if (Types_IsOpenArray(arrayType)) {
+ Generate(ident, file, 0);
+ fprintf(file, "len");
+ } else {
+ fprintf(file, "%" OBNC_INT_MOD "d", Trees_Integer(Types_ArrayLength(arrayType)));
+ }
+}
+
+
+static void GenerateNonScalarOperation(Trees_Node opNode, FILE *file, int indent)
+{
+ Trees_Node leftOperand, rightOperand;
+ Trees_Node leftType, rightType;
+
+ leftOperand = Trees_Left(opNode);
+ rightOperand = Trees_Right(opNode);
+ leftType = Types_Structure(Trees_Type(leftOperand));
+ rightType = Types_Structure(Trees_Type(rightOperand));
+
+ switch (Trees_Symbol(opNode)) {
+ case '=':
+ case '#':
+ case '<':
+ case LE:
+ case '>':
+ case GE:
+ Indent(file, indent);
+ fprintf(file, "OBNC_CMP(");
+ Generate(leftOperand, file, indent);
+ fprintf(file, ", ");
+ if (Trees_Symbol(leftType) == TREES_STRING_TYPE) {
+ fprintf(file, "%lu", (long unsigned) strlen(Trees_String(leftOperand)) + 1);
+ } else {
+ GenerateArrayLength(VarIdent(leftOperand), leftType, file);
+ }
+ fprintf(file, ", ");
+ Generate(rightOperand, file, indent);
+ fprintf(file, ", ");
+ if (Trees_Symbol(rightType) == TREES_STRING_TYPE) {
+ fprintf(file, "%lu", (long unsigned) strlen(Trees_String(rightOperand)) + 1);
+ } else {
+ GenerateArrayLength(VarIdent(rightOperand), rightType, file);
+ }
+ fprintf(file, ") ");
+ PrintCOperator(opNode, file);
+ fprintf(file, " 0");
+ break;
+ default:
+ assert(0);
+ }
+}
+
+
+static void GenerateWithPrecedence(Trees_Node exp, FILE *file)
+{
+ if (Trees_IsLeaf(exp)
+ || (Trees_Symbol(exp) == TREES_DESIGNATOR)
+ || IsProcedureCall(Trees_Symbol(exp))) {
+ Generate(exp, file, 0);
+ } else {
+ fprintf(file, "(");
+ Generate(exp, file, 0);
+ fprintf(file, ")");
+ }
+}
+
+
+static void GenerateTypeDescExp(Trees_Node var, FILE *file, int indent)
+{
+ if (Types_IsRecord(Trees_Type(var))) {
+ if (IsVarParam(var)) {
+ GenerateIdent(VarIdent(var), file, indent);
+ fprintf(file, "td");
+ } else {
+ fprintf(file, "&");
+ GenerateIdent(TypeDescIdent(Trees_Type(var)), file, 0);
+ fprintf(file, "td");
+ }
+ } else {
+ assert(Types_IsPointer(Trees_Type(var)));
+ fprintf(file, "OBNC_TD(");
+ Generate(var, file, 0);
+ fprintf(file, ", struct ");
+ Generate(TypeDescIdent(Trees_Type(var)), file, 0);
+ fprintf(file, "Heap)");
+ }
+}
+
+
+static void GenerateISExpression(Trees_Node var, Trees_Node type, FILE *file)
+{
+ int isPointer;
+
+ isPointer = Types_IsPointer(Trees_Type(var));
+ if (isPointer) {
+ fprintf(file, "((void) OBNC_PT(");
+ Generate(var, file, 0);
+ fprintf(file, "), ");
+ }
+ fprintf(file, "OBNC_IS(");
+ GenerateTypeDescExp(var, file, 0);
+ fprintf(file, ", &");
+ Generate(TypeDescIdent(type), file, 0);
+ fprintf(file, "id, %d)", Types_ExtensionLevel(type));
+ if (isPointer) {
+ fprintf(file, ")");
+ }
+}
+
+
+static void GenerateOperator(Trees_Node opNode, FILE *file)
+{
+ Trees_Node leftOperand, rightOperand, leftType, rightType;
+ int opSym;
+
+ leftOperand = Trees_Left(opNode);
+ rightOperand = Trees_Right(opNode);
+ opSym = Trees_Symbol(opNode);
+
+ if (Trees_Right(opNode) == NULL) {
+ /*unary operator*/
+ PrintCOperator(opNode, file);
+ GenerateWithPrecedence(leftOperand, file);
+ } else {
+ /*binary operator*/
+ leftType = Trees_Type(leftOperand);
+ rightType = Trees_Type(rightOperand);
+
+ if ((Types_IsString(leftType) || Types_IsCharacterArray(leftType))
+ && (Types_IsString(rightType) || Types_IsCharacterArray(rightType))) {
+ GenerateNonScalarOperation(opNode, file, 0);
+ } else {
+ switch (opSym) {
+ case DIV:
+ case MOD:
+ if (opSym == DIV) {
+ fprintf(file, "OBNC_DIV(");
+ } else {
+ fprintf(file, "OBNC_MOD(");
+ }
+ Generate(leftOperand, file, 0);
+ fprintf(file, ", ");
+ Generate(rightOperand, file, 0);
+ fprintf(file, ")");
+ break;
+ case '<':
+ case LE:
+ case '>':
+ case GE:
+ if (Types_IsChar(Trees_Type(leftOperand))) {
+ fprintf(file, "(unsigned char) ");
+ }
+ GenerateWithPrecedence(leftOperand, file);
+ fprintf(file, " ");
+ PrintCOperator(opNode, file);
+ fprintf(file, " ");
+ if (Types_IsChar(Trees_Type(rightOperand))) {
+ fprintf(file, "(unsigned char) ");
+ }
+ GenerateWithPrecedence(rightOperand, file);
+ break;
+ default:
+ if (Types_IsPointer(leftType) && (Trees_Symbol(leftOperand) != NIL) && ! Types_Same(leftType, rightType) && (Trees_Symbol(rightOperand) != NIL)) {
+ if (Types_Extends(leftType, rightType)) {
+ GenerateWithPrecedence(leftOperand, file);
+ fprintf(file, " ");
+ PrintCOperator(opNode, file);
+ fprintf(file, " (");
+ Generate(leftType, file, 0);
+ fprintf(file, ") ");
+ GenerateWithPrecedence(rightOperand, file);
+ } else {
+ fprintf(file, "(");
+ Generate(rightType, file, 0);
+ fprintf(file, ") ");
+ GenerateWithPrecedence(leftOperand, file);
+ fprintf(file, " ");
+ PrintCOperator(opNode, file);
+ fprintf(file, " ");
+ GenerateWithPrecedence(rightOperand, file);
+ }
+ } else {
+ GenerateWithPrecedence(leftOperand, file);
+ fprintf(file, " ");
+ PrintCOperator(opNode, file);
+ fprintf(file, " ");
+ GenerateWithPrecedence(rightOperand, file);
+ }
+ }
+ }
+ }
+}
+
+
+static int IsConstExpression(Trees_Node exp)
+{
+ int result;
+
+ result = 0;
+ switch (Trees_Symbol(exp)) {
+ case TRUE:
+ case FALSE:
+ case STRING:
+ case INTEGER:
+ case REAL:
+ case TREES_SET_CONSTANT:
+ result = 1;
+ }
+ return result;
+}
+
+
+static int ContainsProcedureCall(Trees_Node exp)
+{
+ int result;
+
+ result = 0;
+ if (exp != NULL) {
+ if (Trees_Symbol(exp) == TREES_PROCEDURE_CALL) {
+ result = 1;
+ } else {
+ result = ContainsProcedureCall(Trees_Left(exp));
+ if (result == 0) {
+ result = ContainsProcedureCall(Trees_Right(exp));
+ }
+ }
+ }
+ return result;
+}
+
+
+static void GenerateArrayIndex(Trees_Node designator, Trees_Node elemSelector, FILE *file)
+{
+ Trees_Node indexExp, type, ident;
+
+ assert(designator != NULL);
+ assert(Trees_Symbol(designator) == TREES_DESIGNATOR);
+ assert(elemSelector != NULL);
+ assert(Trees_Symbol(elemSelector) == '[');
+
+ ident = Trees_Left(designator);
+ indexExp = Trees_Left(elemSelector);
+ type = Trees_Type(elemSelector);
+ assert(Types_IsArray(type));
+
+ if (IsConstExpression(indexExp)) {
+ Generate(indexExp, file, 0);
+ } else {
+ if (ContainsProcedureCall(indexExp)) {
+ fprintf(file, "OBNC_IT1(");
+ } else {
+ fprintf(file, "OBNC_IT(");
+ }
+ Generate(indexExp, file, 0);
+ fprintf(file, ", ");
+ GenerateArrayLength(ident, type, file);
+ fprintf(file, ")");
+ }
+}
+
+
+static void GenerateDesignatorVar(Trees_Node ident, FILE *file)
+{
+ int identKind, paramDerefNeeded;
+ Trees_Node identType;
+
+ identKind = Trees_Kind(ident);
+ identType = Trees_Type(ident);
+ paramDerefNeeded = ((identKind == TREES_VALUE_PARAM_KIND) && Types_IsRecord(identType))
+ || ((identKind == TREES_VAR_PARAM_KIND) && ! Types_IsArray(identType));
+
+ if (paramDerefNeeded) {
+ fprintf(file, "(*");
+ Generate(ident, file, 0);
+ fprintf(file, ")");
+ } else {
+ Generate(ident, file, 0);
+ }
+}
+
+
+static void GenerateDesignatorRec(Trees_Node des, Trees_Node reversedSelectors, FILE *file)
+{
+ Trees_Node field, fieldIdent, fieldBaseType, typeIdent;
+ int castNeeded;
+
+ if (reversedSelectors == NULL) {
+ if ((caseVariable != NULL) && (caseLabelType != NULL) && (VarIdent(des) == caseVariable) && ! Types_Same(Trees_Type(caseVariable), caseLabelType)) {
+ fprintf(file, "(*((");
+ Generate(caseLabelType, file, 0);
+ fprintf(file, " *) &");
+ GenerateDesignatorVar(VarIdent(des), file);
+ fprintf(file, "))");
+ } else {
+ GenerateDesignatorVar(VarIdent(des), file);
+ }
+ } else {
+ switch (Trees_Symbol(reversedSelectors)) {
+ case '[':
+ GenerateDesignatorRec(des, Trees_Right(reversedSelectors), file);
+ fprintf(file, "[");
+ GenerateArrayIndex(des, reversedSelectors, file);
+ fprintf(file, "]");
+ break;
+ case '.':
+ field = Trees_Left(reversedSelectors);
+ Types_GetFieldIdent(Trees_Name(field), Trees_Type(reversedSelectors), Trees_Imported(VarIdent(des)), &fieldIdent, &fieldBaseType);
+ castNeeded = ! Types_Same(fieldBaseType, Trees_Type(reversedSelectors));
+ if (castNeeded) {
+ fprintf(file, "(*((");
+ Generate(fieldBaseType, file, 0);
+ if (Types_IsRecord(fieldBaseType)) {
+ fprintf(file, " *");
+ }
+ fprintf(file, ") &");
+ }
+ GenerateDesignatorRec(des, Trees_Right(reversedSelectors), file);
+ if (castNeeded) {
+ fprintf(file, "))");
+ }
+ fprintf(file, ".");
+ Generate(Trees_Left(reversedSelectors), file, 0);
+ break;
+ case '^':
+ fprintf(file, "(*OBNC_PT(");
+ GenerateDesignatorRec(des, Trees_Right(reversedSelectors), file);
+ fprintf(file, "))");
+ break;
+ case '(':
+ typeIdent = Trees_Left(reversedSelectors);
+
+ fprintf(file, "(*((");
+ Generate(typeIdent, file, 0);
+ if (Types_IsRecord(typeIdent)) {
+ fprintf(file, "*) OBNC_RTT(&(");
+ } else {
+ fprintf(file, "*) OBNC_PTT(&(");
+ }
+ GenerateDesignatorRec(des, Trees_Right(reversedSelectors), file);
+ fprintf(file, "), ");
+ if (Types_IsRecord(typeIdent)) {
+ if (IsVarParam(des) && (reversedSelectors == VarSelector(des))) {
+ GenerateIdent(VarIdent(des), file, 0);
+ fprintf(file, "td");
+ } else {
+ fprintf(file, "&");
+ GenerateIdent(TypeDescIdent(Trees_Type(reversedSelectors)), file, 0);
+ fprintf(file, "td");
+ }
+ } else {
+ assert(Types_IsPointer(typeIdent));
+ fprintf(file, "OBNC_TD(");
+ GenerateDesignatorRec(des, Trees_Right(reversedSelectors), file);
+ fprintf(file, ", struct ");
+ Generate(TypeDescIdent(Trees_Type(reversedSelectors)), file, 0);
+ fprintf(file, "Heap)");
+ }
+ fprintf(file, ", &");
+ Generate(TypeDescIdent(typeIdent), file, 0);
+ fprintf(file, "id, %d)))", Types_ExtensionLevel(typeIdent));
+ break;
+ default:
+ assert(0);
+ }
+ }
+}
+
+
+static void GenerateDesignator(Trees_Node des, FILE *file)
+{
+ Trees_Node selectors;
+
+ selectors = Trees_Right(des);
+ Trees_ReverseList(&selectors);
+ GenerateDesignatorRec(des, selectors, file);
+ Trees_ReverseList(&selectors); /*reset order*/
+}
+
+
+static void GenerateSingleElementSet(Trees_Node node, FILE *file)
+{
+ fprintf(file, "(0x1u << ");
+ GenerateWithPrecedence(Trees_Left(node), file);
+ fprintf(file, ")");
+}
+
+
+static void GenerateRangeSet(Trees_Node node, FILE *file)
+{
+ fprintf(file, "OBNC_RANGE(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ")");
+}
+
+
+static void GenerateExpList(Trees_Node expList, FILE *file)
+{
+ Trees_Node exp, tail;
+
+ exp = Trees_Right(expList);
+ Generate(exp, file, 0);
+ tail = Trees_Right(expList);
+ if (tail != NULL) {
+ fprintf(file, ", ");
+ Generate(tail, file, 0);
+ }
+}
+
+
+/*STATEMENT GENERATORS*/
+
+static void GenerateArrayAssignment(Trees_Node source, Trees_Node target, FILE *file, int indent)
+{
+ Trees_Node sourceIdent, targetIdent, sourceType, targetType;
+
+ assert(Trees_Symbol(target) == TREES_DESIGNATOR);
+
+ if (Trees_Symbol(source) == TREES_DESIGNATOR) {
+ sourceIdent = Trees_Left(source);
+ } else {
+ sourceIdent = source;
+ }
+ targetIdent = Trees_Left(target);
+ sourceType = Trees_Type(source);
+ targetType = Types_Structure(Trees_Type(target));
+ assert(Trees_Symbol(targetType) == ARRAY);
+
+ if (Types_IsOpenArray(sourceType) || Types_IsOpenArray(targetType)) {
+ Indent(file, indent);
+ fprintf(file, "OBNC_AAT(");
+ if (Trees_Symbol(source) == STRING) {
+ fprintf(file, "%lu", (long unsigned) strlen(Trees_String(source)) + 1);
+ } else {
+ GenerateArrayLength(sourceIdent, sourceType, file);
+ }
+ fprintf(file, ", ");
+ GenerateArrayLength(targetIdent, targetType, file);
+ fprintf(file, ");\n");
+ }
+ Indent(file, indent);
+ fprintf(file, "OBNC_COPY_ARRAY(");
+ Generate(source, file, 0);
+ fprintf(file, ", ");
+ Generate(target, file, 0);
+ fprintf(file, ", ");
+ if (Trees_Symbol(source) == STRING) {
+ fprintf(file, "%lu", (long unsigned) strlen(Trees_String(source)) + 1);
+ } else {
+ GenerateArrayLength(sourceIdent, sourceType, file);
+ }
+ fprintf(file, ");\n");
+}
+
+
+static void GenerateRecordAssignment(Trees_Node source, Trees_Node target, FILE *file, int indent)
+{
+ Trees_Node sourceType, targetType;
+
+ sourceType = Trees_Type(source);
+ targetType = Trees_Type(target);
+
+ if (IsVarParam(target)) {
+ Indent(file, indent);
+ fprintf(file, "OBNC_RAT(");
+ GenerateTypeDescExp(source, file, 0);
+ fprintf(file, ", ");
+ GenerateTypeDescExp(target, file, 0);
+ fprintf(file, ");\n");
+ }
+ if (Types_Same(sourceType, targetType) && ! IsVarParam(target)) {
+ GenerateDesignator(target, file);
+ fprintf(file, " = ");
+ Generate(source, file, 0);
+ fprintf(file, ";\n");
+ } else {
+ Generate(target, file, indent);
+ fprintf(file, " = ");
+ if (! Types_Same(sourceType, targetType)) {
+ assert(Types_Extends(targetType, sourceType));
+ fprintf(file, "*(");
+ Generate(targetType, file, 0);
+ fprintf(file, " *) &");
+ }
+ Generate(source, file, 0);
+ fprintf(file, ";\n");
+ }
+}
+
+
+static int CastNeeded(Trees_Node sourceType, Trees_Node targetType)
+{
+ return (Types_IsByte(targetType) && ! Types_IsByte(sourceType))
+ || ((Types_IsRecord(targetType) || Types_IsPointer(targetType))
+ && (Trees_Symbol(sourceType) != TREES_NIL_TYPE)
+ && Types_Extends(targetType, sourceType)
+ && ! Types_Same(targetType, sourceType));
+}
+
+
+static void GenerateAssignment(Trees_Node becomesNode, FILE *file, int indent)
+{
+ Trees_Node source, target;
+ Trees_Node sourceType, targetType;
+
+ source = Trees_Right(becomesNode);
+ target = Trees_Left(becomesNode);
+ sourceType = Trees_Type(source);
+ targetType = Trees_Type(target);
+
+ switch (Trees_Symbol(Types_Structure(targetType))) {
+ case ARRAY:
+ GenerateArrayAssignment(source, target, file, indent);
+ break;
+ case RECORD:
+ GenerateRecordAssignment(source, target, file, indent);
+ break;
+ default:
+ Indent(file, indent);
+ GenerateDesignator(target, file);
+ fprintf(file, " = ");
+ if (CastNeeded(sourceType, targetType)) {
+ fprintf(file, "(");
+ Generate(targetType, file, 0);
+ fprintf(file, ") ");
+ }
+ GenerateWithPrecedence(source, file);
+ fprintf(file, ";\n");
+ }
+}
+
+
+static void GenerateProcedureCall(Trees_Node call, FILE *file, int indent)
+{
+ Trees_Node designator, designatorTypeStruct, expList, fpList, fpType, exp, expType, resultType;
+ int procKind, isProcVar, isValueParam, isVarParam;
+
+ designator = Trees_Left(call);
+ designatorTypeStruct = Types_Structure(Trees_Type(designator));
+ procKind = Trees_Kind(Trees_Left(designator));
+ assert(Types_IsProcedure(designatorTypeStruct));
+ resultType = Types_ResultType(designatorTypeStruct);
+ isProcVar = procKind != TREES_PROCEDURE_KIND;
+
+ Indent(file, indent);
+ if (isProcVar) {
+ fprintf(file, "OBNC_PCT(");
+ Generate(designator, file, 0);
+ fprintf(file, ")");
+ } else {
+ Generate(designator, file, 0);
+ }
+
+ fprintf(file, "(");
+
+ expList = Trees_Right(call);
+ fpList = Types_Parameters(designatorTypeStruct);
+ while (expList != NULL) {
+ assert(fpList != NULL);
+ exp = Trees_Left(expList);
+ expType = Trees_Type(exp);
+ isValueParam = Trees_Kind(Trees_Left(fpList)) == TREES_VALUE_PARAM_KIND;
+ isVarParam = Trees_Kind(Trees_Left(fpList)) == TREES_VAR_PARAM_KIND;
+ fpType = Trees_Type(Trees_Left(fpList));
+
+ if (isValueParam && Types_IsArray(fpType) && Types_IsArray(Types_ElementType(fpType))) {
+ /*cast to const needed for array of array parameters*/
+ fprintf(file, "(const ");
+ Generate(Types_ElementType(expType), file, 0);
+ fprintf(file, " *) ");
+ } else if (CastNeeded(expType, fpType)) {
+ fprintf(file, "(");
+ Generate(fpType, file, 0);
+ if ((isVarParam && ! Types_IsArray(fpType)) || Types_IsRecord(fpType)) {
+ fprintf(file, " *");
+ }
+ fprintf(file, ") ");
+ }
+ if ((isValueParam && Types_IsRecord(fpType)) || (isVarParam && ! Types_IsArray(fpType))) {
+ fprintf(file, "&");
+ }
+ GenerateWithPrecedence(exp, file);
+
+ /*additional type info parameters*/
+ if (Types_IsArray(expType)) {
+ fprintf(file, ", ");
+ if (Trees_Symbol(exp) == TREES_DESIGNATOR) {
+ GenerateArrayLength(Trees_Left(exp), expType, file);
+ } else {
+ GenerateArrayLength(exp, expType, file);
+ }
+ } else if (Trees_Symbol(exp) == STRING) {
+ fprintf(file, ", %lu", (long unsigned) strlen(Trees_String(exp)) + 1);
+ } else if (isVarParam && Types_IsRecord(fpType)) {
+ fprintf(file, ", ");
+ GenerateTypeDescExp(exp, file, 0);
+ }
+
+ if (Trees_Right(expList) != NULL) {
+ fprintf(file, ", ");
+ }
+ expList = Trees_Right(expList);
+ fpList = Trees_Right(fpList);
+ }
+
+ fprintf(file, ")");
+ if (resultType == NULL) {
+ fprintf(file, ";\n");
+ }
+}
+
+
+static void GenerateAssert(Trees_Node node, FILE *file, int indent)
+{
+ Trees_Node exp, filename, line;
+
+ exp = Trees_Left(node);
+ filename = Trees_Left(Trees_Right(node));
+ line = Trees_Right(Trees_Right(node));
+
+ Indent(file, indent);
+ if (Trees_Symbol(exp) == FALSE) {
+ /*unconditional ASSERT(FALSE) replaces HALT(1)*/
+ fprintf(file, "exit(1);\n");
+ } else {
+ fprintf(file, "OBNC_ASSERT(");
+ Generate(exp, file, 0);
+ fprintf(file, ", ");
+ Generate(filename, file, 0);
+ fprintf(file, ", ");
+ Generate(line, file, 0);
+ fprintf(file, ");\n");
+ }
+}
+
+
+static void GenerateIntegralCaseStatement(Trees_Node caseStmtNode, FILE *file, int indent)
+{
+ Trees_Node expNode, currCaseRepNode, currCaseNode, currCaseLabelListNode, currStmtSeqNode, currLabelRangeNode;
+ int rangeMin, rangeMax, label;
+
+ expNode = Trees_Left(caseStmtNode);
+
+ Indent(file, indent);
+ fprintf(file, "switch (");
+ Generate(expNode, file, 0);
+ fprintf(file, ") {\n");
+ currCaseRepNode = Trees_Right(caseStmtNode);
+ while (currCaseRepNode != NULL) {
+ currCaseNode = Trees_Left(currCaseRepNode);
+ currStmtSeqNode = Trees_Right(currCaseNode);
+
+ /*generate case labels for current case*/
+ currCaseLabelListNode = Trees_Left(currCaseNode);
+ do {
+ currLabelRangeNode = Trees_Left(currCaseLabelListNode);
+ if (Trees_Right(currLabelRangeNode) == NULL) {
+ /*generate single label*/
+ Indent(file, indent + 1);
+ fprintf(file, "case ");
+ Generate(currLabelRangeNode, file, 0);
+ fprintf(file, ":\n");
+ } else {
+ /*generate label range*/
+ if (Trees_Symbol(Trees_Left(currLabelRangeNode)) == INTEGER) {
+ rangeMin = Trees_Integer(Trees_Left(currLabelRangeNode));
+ rangeMax = Trees_Integer(Trees_Right(currLabelRangeNode));
+ for (label = rangeMin; label <= rangeMax; label++) {
+ Indent(file, indent + 1);
+ fprintf(file, "case %d:\n", label);
+ }
+ } else {
+ rangeMin = Trees_Char(Trees_Left(currLabelRangeNode));
+ rangeMax = Trees_Char(Trees_Right(currLabelRangeNode));
+ for (label = rangeMin; label <= rangeMax; label++) {
+ Indent(file, indent + 1);
+ fprintf(file, "case ");
+ GenerateChar(label, file);
+ fprintf(file, ":\n");
+ }
+ }
+ }
+ currCaseLabelListNode = Trees_Right(currCaseLabelListNode);
+ } while (currCaseLabelListNode != NULL);
+
+ /*generate statement sequence for current case*/
+ Generate(currStmtSeqNode, file, indent + 2);
+ Indent(file, indent + 2);
+ fprintf(file, "break;\n");
+
+ currCaseRepNode = Trees_Right(currCaseRepNode);
+ }
+ Indent(file, indent + 1);
+ fprintf(file, "default:\n");
+ Indent(file, indent + 2);
+ fprintf(file, "OBNC_CT;\n");
+ Indent(file, indent);
+ fprintf(file, "}\n");
+}
+
+
+static void GenerateTypeCaseStatement(Trees_Node caseStmtNode, FILE *file, int indent)
+{
+ Trees_Node caseExp, caseList, caseNode, label, statementSeq;
+ int caseNumber;
+
+ caseExp = Trees_Left(caseStmtNode);
+ assert(Trees_Symbol(caseExp) == TREES_DESIGNATOR);
+ caseVariable = Trees_Left(caseExp);
+
+ caseList = Trees_Right(caseStmtNode);
+ caseNumber = 0;
+ while (caseList != NULL) {
+ caseNode = Trees_Left(caseList);
+ label = Trees_Left(Trees_Left(caseNode));
+ statementSeq = Trees_Right(caseNode);
+
+ if (caseNumber == 0) {
+ Indent(file, indent);
+ fprintf(file, "if (");
+ } else {
+ fprintf(file, " else if (");
+ }
+ GenerateISExpression(caseExp, label, file);
+ fprintf(file, ") {\n");
+ caseLabelType = label;
+ Generate(statementSeq, file, indent + 1);
+ caseLabelType = NULL;
+ Indent(file, indent);
+ fprintf(file, "}");
+ caseList = Trees_Right(caseList);
+ if (caseList == NULL) {
+ fprintf(file, "\n");
+ }
+ caseNumber++;
+ }
+
+ caseVariable = NULL;
+}
+
+
+static void GenerateCaseStatement(Trees_Node caseStmtNode, FILE *file, int indent)
+{
+ Trees_Node expNode, expType;
+
+ expNode = Trees_Left(caseStmtNode);
+ expType = Trees_Type(expNode);
+ if (Types_IsInteger(expType) || Types_IsChar(expType)) {
+ GenerateIntegralCaseStatement(caseStmtNode, file, indent);
+ } else {
+ GenerateTypeCaseStatement(caseStmtNode, file, indent);
+ }
+}
+
+
+static void GenerateWhileStatement(Trees_Node whileNode, FILE *file, int indent)
+{
+ Trees_Node expNode, doNode, stmtSeqNode, elsifNode;
+
+ expNode = Trees_Left(whileNode);
+ doNode = Trees_Right(whileNode);
+ stmtSeqNode = Trees_Left(doNode);
+ elsifNode = Trees_Right(doNode);
+ if (elsifNode == NULL) {
+ Indent(file, indent);
+ fprintf(file, "while (");
+ Generate(expNode, file, 0);
+ fprintf(file, ") {\n");
+ Generate(stmtSeqNode, file, indent + 1);
+ Indent(file, indent);
+ fprintf(file, "}\n");
+ } else {
+ Indent(file, indent);
+ fprintf(file, "while (1) {\n");
+ Indent(file, indent + 1);
+ fprintf(file, "if (");
+ Generate(expNode, file, 0);
+ fprintf(file, ") {\n");
+ Generate(stmtSeqNode, file, indent + 2);
+ Indent(file, indent + 1);
+ fprintf(file, "}\n");
+ Generate(elsifNode, file, indent + 1);
+ Indent(file, indent + 1);
+ fprintf(file, "else {\n");
+ Indent(file, indent + 2);
+ fprintf(file, "break;\n");
+ Indent(file, indent + 1);
+ fprintf(file, "}\n");
+ Indent(file, indent);
+ fprintf(file, "}\n");
+ }
+}
+
+
+static void GenerateForStatement(Trees_Node forNode, FILE *file, int indent)
+{
+ Trees_Node initNode, controlVarNode, toNode, limit, byNode, statementSeq;
+ int inc;
+
+ initNode = Trees_Left(forNode);
+ controlVarNode = Trees_Left(initNode);
+ toNode = Trees_Right(forNode);
+ limit = Trees_Left(toNode);
+ byNode = Trees_Right(toNode);
+ inc = Trees_Integer(Trees_Left(byNode));
+ assert(inc != 0);
+ statementSeq = Trees_Right(byNode);
+
+ Indent(file, indent);
+ fprintf(file, "for (");
+ Generate(controlVarNode, file, 0);
+ fprintf(file, " = ");
+ Generate(Trees_Right(initNode), file, 0);
+ fprintf(file, "; ");
+ Generate(controlVarNode, file, 0);
+ if (inc > 0) {
+ fprintf(file, " <= ");
+ } else {
+ fprintf(file, " >= ");
+ }
+ Generate(limit, file, 0);
+ fprintf(file, "; ");
+ Generate(controlVarNode, file, 0);
+ fprintf(file, " += %d) {\n", inc);
+ Generate(statementSeq, file, indent + 1);
+ Indent(file, indent);
+ fprintf(file, "}\n");
+}
+
+
+static void GenerateMemoryAllocation(Trees_Node var, FILE *file, int indent)
+{
+ Trees_Node type;
+ int hasPointer, hasProcedure;
+ const char *allocKind;
+
+ assert(var != NULL);
+ assert(Trees_Symbol(var) == TREES_DESIGNATOR);
+
+ type = Trees_Type(var);
+ SearchPointersAndProcedures(Types_PointerBaseType(type), &hasPointer, &hasProcedure);
+ allocKind = "OBNC_ATOMIC_NOINIT_ALLOC";
+ if (hasPointer) {
+ allocKind = "OBNC_REGULAR_ALLOC";
+ } else if (hasProcedure) {
+ allocKind = "OBNC_ATOMIC_ALLOC";
+ }
+ if ((Trees_Symbol(type) == IDENT) || (Trees_Symbol(Types_PointerBaseType(type)) == IDENT)) {
+ Indent(file, indent);
+ fprintf(file, "OBNC_NEW(");
+ Generate(var, file, 0);
+ fprintf(file, ", &");
+ Generate(TypeDescIdent(type), file, 0);
+ fprintf(file, "td, struct ");
+ Generate(TypeDescIdent(type), file, 0);
+ fprintf(file, "Heap, %s);\n", allocKind);
+ } else {
+ Indent(file, indent);
+ fprintf(file, "OBNC_NEW_ANON(");
+ Generate(var, file, 0);
+ fprintf(file, ", %s);\n", allocKind);
+ }
+}
+
+
+/*PROCEDURE DECLARATION GENERATORS*/
+
+static void CopyText(FILE *source, long int pos, int count, FILE *target)
+{
+ long int oldPos;
+ int i, ch;
+
+ assert(source != NULL);
+ assert(pos >= 0);
+ assert(count >= 0);
+ assert(target != NULL);
+
+ oldPos = ftell(source);
+ if (oldPos >= 0) {
+ fseek(source, pos, SEEK_SET);
+ if (! ferror(source)) {
+ i = 0;
+ ch = fgetc(source);
+ while ((i < count) && (ch != EOF)) {
+ fputc(ch, target);
+ i++;
+ ch = fgetc(source);
+ }
+ }
+ fseek(source, oldPos, SEEK_SET);
+ }
+
+ if (ferror(source) || ferror(target)) {
+ fprintf(stderr, "obnc-compile: file input/output failed: %s\n", strerror(errno));
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void ReadText(FILE *fp, long int pos, long int count, char result[], int resultLen)
+{
+ int i, ch;
+
+ assert(count < resultLen);
+
+ fseek(fp, pos, SEEK_SET);
+ if (! ferror(fp)) {
+ i = 0;
+ ch = fgetc(fp);
+ while ((ch != EOF) && (i < count)) {
+ result[i] = ch;
+ i++;
+ ch = fgetc(fp);
+ }
+ result[count] = '\0';
+ fseek(fp, 0, SEEK_CUR);
+ } else {
+ perror(NULL);
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void PushProcedureDeclaration(Trees_Node procIdent)
+{
+ struct ProcedureDeclNode *node;
+ int generatedLen, isFirstLocalProc, ch;
+
+ NEW(node);
+ node->procIdent = procIdent;
+ node->localProcedures = Maps_New();
+ node->runtimeInitVars = NULL;
+ if (Trees_Local(procIdent)) {
+ /*save unfinished procedure declaration*/
+ generatedLen = ftell(cFile) - procedureDeclStart + 1;
+ NEW_ARRAY(node->partialDecl, generatedLen);
+ ReadText(cFile, procedureDeclStart, generatedLen - 1, node->partialDecl, generatedLen);
+ } else {
+ node->partialDecl = NULL;
+ }
+ node->next = procedureDeclStack;
+
+ if (Trees_Local(procIdent)) {
+ assert(procedureDeclStack != NULL);
+ isFirstLocalProc = (procedureDeclStack->next == NULL) && Maps_IsEmpty(procedureDeclStack->localProcedures);
+ Maps_Put(Trees_Name(procIdent), NULL, &(procedureDeclStack->localProcedures));
+
+ /*set file position for writing local procedure*/
+ fseek(cFile, procedureDeclStart, SEEK_SET);
+ if (isFirstLocalProc) {
+ /*keep function signature for global procedure*/
+ do {
+ ch = fgetc(cFile);
+ } while ((ch != EOF) && (ch != ')'));
+ assert(ch == ')');
+ fseek(cFile, 0, SEEK_CUR);
+ fprintf(cFile, ";\n");
+ }
+ }
+
+ procedureDeclStack = node;
+}
+
+
+static void PopProcedureDeclaration(void)
+{
+ assert(procedureDeclStack != NULL);
+ procedureDeclStart = ftell(cFile);
+ if (procedureDeclStack->partialDecl != NULL) {
+ fprintf(cFile, "%s", procedureDeclStack->partialDecl);
+ }
+ procedureDeclStack = procedureDeclStack->next;
+}
+
+
+static void GenerateFormalParameter(Trees_Node param, FILE *file, int indent)
+{
+ int kind;
+ Trees_Node type;
+
+ kind = Trees_Kind(param);
+ type = Trees_Type(param);
+ if (kind == TREES_VALUE_PARAM_KIND) {
+ if (Types_IsArray(type) || Types_IsRecord(type)) {
+ fprintf(file, "const ");
+ }
+ if (Types_IsRecord(type) || (type == declaredTypeIdent)) {
+ fprintf(file, "struct ");
+ }
+ if (Types_IsArray(type)) {
+ Generate(Types_ElementType(type), file, 0);
+ fprintf(file, " ");
+ Generate(param, file, 0);
+ fprintf(file, "[], OBNC_LONGI int ");
+ Generate(param, file, 0);
+ fprintf(file, "len");
+ } else {
+ Generate(type, file, 0);
+ fprintf(file, " ");
+ if (Types_IsRecord(type) || (type == declaredTypeIdent)) {
+ fprintf(file, "*");
+ }
+ Generate(param, file, 0);
+ }
+ } else {
+ assert(kind == TREES_VAR_PARAM_KIND);
+ if (type == declaredTypeIdent) {
+ fprintf(file, "struct ");
+ }
+ if (Types_IsArray(type)) {
+ Generate(Types_ElementType(type), file, 0);
+ fprintf(file, " ");
+ Generate(param, file, 0);
+ fprintf(file, "[], OBNC_LONGI int ");
+ Generate(param, file, 0);
+ fprintf(file, "len");
+ } else {
+ Generate(type, file, 0);
+ fprintf(file, " *");
+ if (Types_IsPointer(type) && (type == declaredTypeIdent)) {
+ fprintf(file, "*");
+ }
+ Generate(param, file, 0);
+ if (Types_IsRecord(type)) {
+ fprintf(file, ", const OBNC_Td *");
+ Generate(param, file, 0);
+ fprintf(file, "td");
+ }
+ }
+ }
+}
+
+
+static void GenerateFormalParameterList(Trees_Node paramList, FILE *file, int indent)
+{
+ Trees_Node param;
+
+ assert(paramList != NULL);
+
+ do {
+ param = Trees_Left(paramList);
+ GenerateFormalParameter(param, file, 0);
+ if (Trees_Right(paramList) != NULL) {
+ fprintf(file, ", ");
+ }
+ paramList = Trees_Right(paramList);
+ } while (paramList != NULL);
+}
+
+
+void Generate_ProcedureHeading(Trees_Node procIdent)
+{
+ Trees_Node procType, resultType, paramList;
+
+ PushProcedureDeclaration(procIdent);
+ procedureDeclStart = ftell(cFile);
+ fprintf(cFile, "\n");
+
+ /*generate export status*/
+ if (! Trees_Exported(procIdent)) {
+ fprintf(cFile, "static ");
+ }
+
+ /*generate return type*/
+ procType = Trees_Type(procIdent);
+ resultType = Types_ResultType(procType);
+ if (resultType != NULL) {
+ Generate(resultType, cFile, 0);
+ fprintf(cFile, " ");
+ } else {
+ fprintf(cFile, "void ");
+ }
+
+ /*generate function identifier*/
+ Generate(procIdent, cFile, 0);
+
+ /*generate parameter list*/
+ fprintf(cFile, "(");
+ paramList = Types_Parameters(procType);
+ if (paramList != NULL) {
+ GenerateFormalParameterList(paramList, cFile, 0);
+ } else {
+ fprintf(cFile, "void");
+ }
+ fprintf(cFile, ")");
+
+ if (Trees_Exported(procIdent)) {
+ fprintf(hFile, "\n");
+ GenerateObjectFileSymbolDefinitions(Trees_NewNode(TREES_NOSYM, procIdent, NULL), "", hFile, 0);
+ CopyText(cFile, procedureDeclStart + 1, ftell(cFile) - procedureDeclStart, hFile);
+ fprintf(hFile, ";\n");
+ }
+
+ fprintf(cFile, "\n{\n");
+}
+
+
+void Generate_ProcedureStatements(Trees_Node stmtSeq)
+{
+ fprintf(cFile, "\n");
+ Generate(stmtSeq, cFile, 1);
+}
+
+
+void Generate_ReturnClause(Trees_Node exp)
+{
+ Trees_Node resultType;
+
+ assert(procedureDeclStack != NULL);
+
+ resultType = Types_ResultType(Trees_Type(procedureDeclStack->procIdent));
+
+ Indent(cFile, 1);
+ fprintf(cFile, "return ");
+ if (CastNeeded(Trees_Type(exp), resultType)) {
+ fprintf(cFile, "(");
+ Generate(resultType, cFile, 0);
+ fprintf(cFile, ") ");
+ }
+ Generate(exp, cFile, 0);
+ fprintf(cFile, ";\n");
+}
+
+
+void Generate_ProcedureEnd(Trees_Node procIdent)
+{
+ fprintf(cFile, "}\n\n");
+ PopProcedureDeclaration();
+}
+
+
+/*MODULE GENERATORS*/
+
+static void GenerateInitCalls(int indent)
+{
+ Trees_Node current, moduleAndDirPath, module;
+
+ current = importList;
+ while (current != NULL) {
+ moduleAndDirPath = Trees_Left(current);
+ module = Trees_Left(moduleAndDirPath);
+ Indent(cFile, indent);
+ fprintf(cFile, "%s_Init();\n", Trees_Name(module));
+ current = Trees_Right(current);
+ }
+}
+
+
+static int Generated(const char filename[])
+{
+ FILE *file;
+ const char *p;
+ int result, n, ch, i;
+
+ assert(filename != NULL);
+
+ result = 0;
+ file = Files_Old(filename, FILES_READ);
+ p = strrchr(headerComment, ' ');
+ if (p != NULL) {
+ n = p - headerComment; /*ignore version string*/
+ i = 0;
+ ch = fgetc(file);
+ while ((ch != EOF) && (i < n) && (headerComment[i] == ch)) {
+ i++;
+ ch = fgetc(file);
+ }
+ result = (i == n) && (headerComment[i] == ch);
+ }
+ Files_Close(file);
+ return result;
+}
+
+
+static void DeleteTemporaryFiles(void)
+{
+ if (Files_Exists(tempCFilepath)) {
+ Files_Remove(tempCFilepath);
+ }
+ if (Files_Exists(tempHFilepath)) {
+ Files_Remove(tempHFilepath);
+ }
+}
+
+
+void Generate_Open(const char moduleName[], int isEntryPoint)
+{
+ const char *template;
+
+ inputModuleName = moduleName;
+ isEntryPointModule = isEntryPoint;
+
+ /*initialize header comment*/
+ if (strcmp(CONFIG_VERSION, "") != 0) {
+ template = "/*GENERATED BY OBNC %s*/";
+ NEW_ARRAY(headerComment, strlen(template) + strlen(CONFIG_VERSION) + 1);
+ sprintf(headerComment, "/*GENERATED BY OBNC %s*/", CONFIG_VERSION);
+ } else {
+ template = "/*GENERATED BY OBNC*/";
+ NEW_ARRAY(headerComment, strlen(template) + 1);
+ strcpy(headerComment, template);
+ }
+
+ /*make sure output directory exists*/
+ if (! Files_Exists(".obnc")) {
+ Files_CreateDir(".obnc");
+ }
+
+ /*create temporary C file*/
+ sprintf(tempCFilepath, ".obnc/%s.c.%d", inputModuleName, getpid());
+ cFile = Files_New(tempCFilepath);
+
+ /*create temporary header file*/
+ sprintf(tempHFilepath, ".obnc/%s.h.%d", inputModuleName, getpid());
+ hFile = Files_New(tempHFilepath);
+
+ atexit(DeleteTemporaryFiles);
+}
+
+
+void Generate_ModuleHeading(void)
+{
+ fprintf(cFile, "%s\n\n", headerComment);
+ fprintf(cFile, "#include \n");
+ if (! isEntryPointModule) {
+ fprintf(cFile, "#include \"%s.h\"\n", inputModuleName);
+ }
+
+ fprintf(hFile, "%s\n\n", headerComment);
+ fprintf(hFile, "#ifndef %s_h\n", inputModuleName);
+ fprintf(hFile, "#define %s_h\n\n", inputModuleName);
+ fprintf(hFile, "#include \n");
+}
+
+
+static int IsInstalledLibrary(const char *path)
+{
+ char *dotObncPath;
+ const char *prefix = Config_Prefix();
+
+ NEW_ARRAY(dotObncPath, strlen(path) + strlen("/.obnc") + 1);
+ sprintf(dotObncPath, "%s/.obnc", path);
+ return (strstr(path, prefix) == path) && (path[strlen(prefix)] == '/') && ! Files_Exists(dotObncPath);
+}
+
+
+static const char *RelativeInstalledLibraryPath(const char *path)
+{
+ const char *prefix = Config_Prefix();
+ const char *libdir = Config_LibDir();
+ const char *result, *tail;
+
+ result = path;
+ if (strstr(path, prefix) == path) {
+ tail = result + strlen(prefix);
+ if (tail[0] == '/') {
+ tail++;
+ if (strstr(tail, libdir) == tail) {
+ tail += strlen(libdir);
+ if (tail[0] == '/') {
+ result = tail + 1;
+ }
+ }
+ }
+ }
+ return result;
+}
+
+
+void Generate_ImportList(Trees_Node list)
+{
+ static char hFileDir[PATH_MAX + 1];
+
+ Trees_Node moduleAndDirPath, module, dirPathNode;
+ const char *dirPath, *parentDirPrefix, *relativePath;
+
+ importList = list;
+
+ while (list != NULL) {
+ moduleAndDirPath = Trees_Left(list);
+ module = Trees_Left(moduleAndDirPath);
+ dirPathNode = Trees_Right(moduleAndDirPath);
+ dirPath = Trees_String(dirPathNode);
+ if (IsInstalledLibrary(dirPath)) {
+ relativePath = RelativeInstalledLibraryPath(dirPath);
+ fprintf(cFile, "#include <%s/%s.h>\n", relativePath, Trees_Name(module));
+ fprintf(hFile, "#include <%s/%s.h>\n", relativePath, Trees_Name(module));
+ } else if (strcmp(dirPath, ".") == 0) {
+ fprintf(cFile, "#include \"%s.h\"\n", Trees_Name(module));
+ fprintf(hFile, "#include \"%s.h\"\n", Trees_Name(module));
+ } else {
+ if ((dirPath[0] == '.') && (dirPath[1] == '/') && Files_Exists(".obnc")) {
+ parentDirPrefix = ".";
+ } else {
+ parentDirPrefix = "";
+ }
+ sprintf(hFileDir, "%s/.obnc", dirPath);
+ if (! Files_Exists(hFileDir)) {
+ sprintf(hFileDir, "%s", dirPath);
+ }
+ fprintf(cFile, "#include \"%s%s/%s.h\"\n", parentDirPrefix, hFileDir, Trees_Name(module));
+ fprintf(hFile, "#include \"%s%s/%s.h\"\n", parentDirPrefix, hFileDir, Trees_Name(module));
+ }
+ list = Trees_Right(list);
+ }
+}
+
+
+void Generate_ModuleStatements(Trees_Node stmtSeq)
+{
+ static char initFuncName[FILENAME_MAX + 1];
+ Trees_Node initFuncIdent;
+
+ if (isEntryPointModule) {
+ fprintf(cFile, "\nint main(int argc, char *argv[])\n");
+ fprintf(cFile, "{\n");
+ Indent(cFile, 1);
+ fprintf(cFile, "OBNC_Initialize(argc, argv);\n");
+ if (importList != NULL) {
+ GenerateInitCalls(1);
+ }
+ Generate(stmtSeq, cFile, 1);
+ Indent(cFile, 1);
+ fprintf(cFile, "return 0;\n");
+ fprintf(cFile, "}\n");
+ } else {
+ sprintf(initFuncName, "%s_Init", inputModuleName);
+ fprintf(cFile, "\nvoid %s(void)\n", initFuncName);
+ fprintf(cFile, "{\n");
+ if ((importList != NULL) || (stmtSeq != NULL)) {
+ Indent(cFile, 1);
+ fprintf(cFile, "static int initialized = 0;\n\n");
+ Indent(cFile, 1);
+ fprintf(cFile, "if (! initialized) {\n");
+ GenerateInitCalls(2);
+ Generate(stmtSeq, cFile, 2);
+ Indent(cFile, 2);
+ fprintf(cFile, "initialized = 1;\n");
+ Indent(cFile, 1);
+ fprintf(cFile, "}\n");
+ }
+ fprintf(cFile, "}\n");
+
+ fprintf(hFile, "\n");
+ initFuncIdent = Trees_NewIdent(initFuncName);
+ Trees_SetInternal(initFuncIdent);
+ GenerateObjectFileSymbolDefinitions(Trees_NewNode(TREES_NOSYM, initFuncIdent, NULL), "", hFile, 0);
+ fprintf(hFile, "void %s(void);\n", initFuncName);
+ }
+}
+
+
+void Generate_ModuleEnd(void)
+{
+ fprintf(hFile, "\n#endif\n");
+}
+
+
+void Generate_Close(void)
+{
+ static char cFilepath[PATH_MAX];
+ static char hFilepath[PATH_MAX];
+
+ /*close temporary files*/
+ Files_Close(cFile);
+ Files_Close(hFile);
+
+ /*move temporary C file to permanent C file*/
+ sprintf(cFilepath, ".obnc/%s.c", inputModuleName);
+ if (! Files_Exists(cFilepath) || Generated(cFilepath)) {
+ Files_Move(tempCFilepath, cFilepath);
+ } else {
+ fprintf(stderr, "obnc-compile: error: C file generated by obnc-compile expected, will not overwrite: %s\n", cFilepath);
+ exit(EXIT_FAILURE);
+ }
+
+ sprintf(hFilepath, ".obnc/%s.h", inputModuleName);
+ if (isEntryPointModule) {
+ /*delete generated header file*/
+ if (Files_Exists(hFilepath)) {
+ if (Generated(hFilepath)) {
+ Files_Remove(hFilepath);
+ } else {
+ fprintf(stderr, "obnc-compile: error: header file generated by obnc-compile expected, will not delete: %s\n", hFilepath);
+ exit(EXIT_FAILURE);
+ }
+ }
+ } else {
+ /*move temporary header file to permanent header file*/
+ if (! Files_Exists(hFilepath) || Generated(hFilepath)) {
+ Files_Move(tempHFilepath, hFilepath);
+ } else {
+ fprintf(stderr, "obnc-compile: error: header file generated by obnc-compile expected, will not overwrite: %s\n", hFilepath);
+ exit(EXIT_FAILURE);
+ }
+ }
+}
+
+
+/*GENERAL GENERATOR*/
+
+static void Generate(Trees_Node node, FILE *file, int indent)
+{
+ int symbol;
+
+ if (node != NULL) {
+ symbol = Trees_Symbol(node);
+ switch (symbol) {
+ case '#':
+ case '&':
+ case '*':
+ case '+':
+ case '-':
+ case '/':
+ case '<':
+ case '=':
+ case '>':
+ case '~':
+ case DIV:
+ case MOD:
+ case OR:
+ case GE:
+ case LE:
+ GenerateOperator(node, file);
+ break;
+ case BECOMES:
+ GenerateAssignment(node, file, indent);
+ break;
+ case CASE:
+ GenerateCaseStatement(node, file, indent);
+ break;
+ case ELSE:
+ Indent(file, indent);
+ fprintf(file, "else {\n");
+ Generate(Trees_Left(node), file, indent + 1);
+ Indent(file, indent);
+ fprintf(file, "}\n");
+ break;
+ case ELSIF:
+ Indent(file, indent);
+ fprintf(file, "else if (");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ") ");
+ Generate(Trees_Right(node), file, indent);
+ break;
+ case FALSE:
+ fprintf(file, "0");
+ break;
+ case FOR:
+ GenerateForStatement(node, file, indent);
+ break;
+ case IDENT:
+ GenerateIdent(node, file, indent);
+ break;
+ case IF:
+ Indent(file, indent);
+ fprintf(file, "if (");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ") ");
+ Generate(Trees_Right(node), file, indent);
+ break;
+ case IN:
+ fprintf(file, "OBNC_IN(");
+ Generate(Trees_Left(node), file, indent);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, indent);
+ fprintf(file, ")");
+ break;
+ case INTEGER:
+ fprintf(file, "%" OBNC_INT_MOD "d", Trees_Integer(node));
+ break;
+ case IS:
+ GenerateISExpression(Trees_Left(node), Trees_Right(node), file);
+ break;
+ case NIL:
+ fprintf(file, "0");
+ break;
+ case POINTER:
+ Generate(Trees_Left(node), file, indent);
+ fprintf(file, " *");
+ break;
+ case REAL:
+ GenerateReal(Trees_Real(node), file);
+ break;
+ case REPEAT:
+ Indent(file, indent);
+ fprintf(file, "do {\n");
+ Generate(Trees_Left(node), file, indent + 1);
+ Indent(file, indent);
+ fprintf(file, "} while (! (");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, "));\n");
+ break;
+ case STRING:
+ GenerateString(Trees_String(node), file);
+ break;
+ case THEN:
+ fprintf(file, "{\n");
+ Generate(Trees_Left(node), file, indent + 1);
+ Indent(file, indent);
+ fprintf(file, "}\n");
+ Generate(Trees_Right(node), file, indent);
+ break;
+ case TREES_NOSYM:
+ Generate(Trees_Left(node), file, indent);
+ Generate(Trees_Right(node), file, indent);
+ break;
+ case TREES_ABS_PROC:
+ if (Types_IsInteger(Trees_Type(Trees_Left(node)))) {
+ fprintf(file, "OBNC_ABS_INT(");
+ } else {
+ fprintf(file, "OBNC_ABS_FLT(");
+ }
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_ASR_PROC:
+ Indent(file, indent);
+ fprintf(file, "OBNC_ASR(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_ASSERT_PROC:
+ GenerateAssert(node, file, indent);
+ break;
+ case TREES_BOOLEAN_TYPE:
+ fprintf(file, "int");
+ break;
+ case TREES_BYTE_TYPE:
+ fprintf(file, "unsigned char");
+ break;
+ case TREES_CHAR_CONSTANT:
+ GenerateChar(Trees_Char(node), file);
+ break;
+ case TREES_CHAR_TYPE:
+ fprintf(file, "char");
+ break;
+ case TREES_CHR_PROC:
+ fprintf(file, "OBNC_CHR(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_DEC_PROC:
+ if (Trees_Right(node) == NULL) {
+ Indent(file, indent);
+ fprintf(file, "OBNC_DEC(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ");\n");
+ } else {
+ Indent(file, indent);
+ fprintf(file, "OBNC_DEC_N(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ");\n");
+ }
+ break;
+ case TREES_DESIGNATOR:
+ GenerateDesignator(node, file);
+ break;
+ case TREES_EXCL_PROC:
+ Indent(file, indent);
+ fprintf(file, "OBNC_EXCL(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ");\n");
+ break;
+ case TREES_EXP_LIST:
+ GenerateExpList(node, file);
+ break;
+ case TREES_FIELD_LIST_SEQUENCE:
+ Generate(Trees_Left(node), file, indent);
+ Generate(Trees_Right(node), file, indent);
+ break;
+ case TREES_FLOOR_PROC:
+ fprintf(file, "OBNC_FLOOR(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_FLT_PROC:
+ fprintf(file, "OBNC_FLT(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_INC_PROC:
+ if (Trees_Right(node) == NULL) {
+ Indent(file, indent);
+ fprintf(file, "OBNC_INC(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ");\n");
+ } else {
+ Indent(file, indent);
+ fprintf(file, "OBNC_INC_N(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ");\n");
+ }
+ break;
+ case TREES_INCL_PROC:
+ Indent(file, indent);
+ fprintf(file, "OBNC_INCL(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ");\n");
+ break;
+ case TREES_INTEGER_TYPE:
+ fprintf(file, "OBNC_LONGI int");
+ break;
+ case TREES_LEN_PROC:
+ GenerateArrayLength(Trees_Left(Trees_Left(node)), Trees_Type(Trees_Left(node)), file);
+ break;
+ case TREES_LSL_PROC:
+ fprintf(file, "OBNC_LSL(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_NEW_PROC:
+ GenerateMemoryAllocation(Trees_Left(node), file, indent);
+ break;
+ case TREES_ODD_PROC:
+ fprintf(file, "OBNC_ODD(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_ORD_PROC:
+ fprintf(file, "OBNC_ORD(");
+ if (Types_IsChar(Trees_Type(Trees_Left(node)))) {
+ fprintf(file, "(unsigned char) ");
+ }
+ GenerateWithPrecedence(Trees_Left(node), file);
+ fprintf(file, ")");
+ break;
+ case TREES_PACK_PROC:
+ Indent(file, indent);
+ fprintf(file, "OBNC_PACK(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ");\n");
+ break;
+ case TREES_PROCEDURE_CALL:
+ GenerateProcedureCall(node, file, indent);
+ break;
+ case TREES_RANGE_SET:
+ GenerateRangeSet(node, file);
+ break;
+ case TREES_REAL_TYPE:
+ fprintf(file, "OBNC_LONGR double");
+ break;
+ case TREES_ROR_PROC:
+ fprintf(file, "OBNC_ROR(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ")");
+ break;
+ case TREES_SET_CONSTANT:
+ fprintf(file, "0x%" OBNC_INT_MOD "Xu", Trees_Set(node));
+ break;
+ case TREES_SET_TYPE:
+ fprintf(file, "OBNC_LONGI unsigned int");
+ break;
+ case TREES_SINGLE_ELEMENT_SET:
+ GenerateSingleElementSet(node, file);
+ break;
+ case TREES_STATEMENT_SEQUENCE:
+ Generate(Trees_Left(node), file, indent);
+ Generate(Trees_Right(node), file, indent);
+ break;
+ case TREES_UNPK_PROC:
+ Indent(file, indent);
+ fprintf(file, "OBNC_UNPK(");
+ Generate(Trees_Left(node), file, 0);
+ fprintf(file, ", ");
+ Generate(Trees_Right(node), file, 0);
+ fprintf(file, ");\n");
+ break;
+ case TRUE:
+ fprintf(file, "1");
+ break;
+ case WHILE:
+ GenerateWhileStatement(node, file, indent);
+ break;
+ default:
+ fprintf(stderr, "obnc-compile: unknown symbol: %d\n", Trees_Symbol(node));
+ assert(0);
+ }
+ }
+}
diff --git a/src/Generate.h b/src/Generate.h
new file mode 100644
index 0000000..a12b5da
--- /dev/null
+++ b/src/Generate.h
@@ -0,0 +1,49 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef GENERATE_H
+#define GENERATE_H
+
+#include "Trees.h"
+
+void Generate_Open(const char moduleName[], int isEntryPoint);
+
+void Generate_ModuleHeading(void);
+
+void Generate_ImportList(Trees_Node importList);
+
+void Generate_ConstDeclaration(Trees_Node constIdent);
+
+void Generate_TypeDeclaration(Trees_Node typeIdent);
+
+void Generate_VariableDeclaration(Trees_Node varIdentList);
+
+void Generate_ProcedureHeading(Trees_Node procIdent);
+
+void Generate_ProcedureStatements(Trees_Node stmtSeq);
+
+void Generate_ReturnClause(Trees_Node exp);
+
+void Generate_ProcedureEnd(Trees_Node procIdent);
+
+void Generate_ModuleStatements(Trees_Node stmtSeq);
+
+void Generate_ModuleEnd(void);
+
+void Generate_Close(void);
+
+#endif
diff --git a/src/Maps.c b/src/Maps.c
new file mode 100644
index 0000000..5a7c2e5
--- /dev/null
+++ b/src/Maps.c
@@ -0,0 +1,108 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Maps.h"
+#include "Util.h"
+#include
+#include
+#include
+
+struct Maps_MapDesc {
+ char *key;
+ void *value;
+ Maps_Map next;
+};
+
+Maps_Map Maps_New(void)
+{
+ return NULL;
+}
+
+
+int Maps_IsEmpty(Maps_Map map)
+{
+ return map == NULL;
+}
+
+
+void Maps_Put(const char key[], void *value, Maps_Map *map)
+{
+ Maps_Map node;
+
+ assert(key != NULL);
+ assert(map != NULL);
+
+ NEW(node);
+ NEW_ARRAY(node->key, strlen(key) + 1);
+ strcpy(node->key, key);
+ node->value = value;
+ node->next = *map;
+ *map = node;
+}
+
+
+int Maps_HasKey(const char key[], Maps_Map map)
+{
+ assert(key != NULL);
+
+ while ((map != NULL) && (strcmp(map->key, key) != 0)) {
+ map = map->next;
+ }
+ return map != NULL;
+}
+
+
+void *Maps_At(const char key[], Maps_Map map)
+{
+ void *result;
+
+ assert(key != NULL);
+
+ while ((map != NULL) && (strcmp(map->key, key) != 0)) {
+ map = map->next;
+ }
+ if (map != NULL) {
+ result = map->value;
+ } else {
+ result = NULL;
+ }
+ return result;
+}
+
+
+static Maps_Map DeletedDuplicates(Maps_Map map)
+{
+ Maps_Map result = Maps_New();
+
+ while (map != NULL) {
+ if (! Maps_HasKey(map->key, result)) {
+ Maps_Put(map->key, map->value, &result);
+ }
+ map = map->next;
+ }
+ return result;
+}
+
+
+void Maps_Apply(Maps_Applicator f, Maps_Map map, void *data)
+{
+ map = DeletedDuplicates(map);
+ while (map != NULL) {
+ f(map->key, map->value, data);
+ map = map->next;
+ }
+}
diff --git a/src/Maps.h b/src/Maps.h
new file mode 100644
index 0000000..8a054c8
--- /dev/null
+++ b/src/Maps.h
@@ -0,0 +1,36 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef MAPS_H
+#define MAPS_H
+
+typedef struct Maps_MapDesc *Maps_Map;
+typedef void (*Maps_Applicator)(const char key[], void *value, void *data);
+
+Maps_Map Maps_New(void);
+
+int Maps_IsEmpty(Maps_Map map);
+
+void Maps_Put(const char key[], void *value, Maps_Map *map);
+
+int Maps_HasKey(const char key[], Maps_Map map);
+
+void *Maps_At(const char key[], Maps_Map map);
+
+void Maps_Apply(Maps_Applicator f, Maps_Map map, void *data);
+
+#endif
diff --git a/src/MapsTest.c b/src/MapsTest.c
new file mode 100644
index 0000000..eeb1fd2
--- /dev/null
+++ b/src/MapsTest.c
@@ -0,0 +1,88 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Maps.h"
+#include "Util.h"
+#include
+#include
+
+typedef struct { int value; } *BoxedInteger;
+
+int count;
+
+static void Count(const char key[], void *value, void *data)
+{
+ count++;
+}
+
+
+static void Increment(const char key[], void *value, void *data)
+{
+ ((BoxedInteger) value)->value++;
+}
+
+
+int main(void)
+{
+ Maps_Map map;
+ BoxedInteger boxedInteger;
+ struct { const char *key; int value; } items[] = {{"foo", 1}, {"bar", 2}, {"baz", 3}};
+ int i;
+
+ Util_Init();
+ map = Maps_New();
+ assert(Maps_IsEmpty(map));
+
+ /*insert items*/
+ for (i = 0; i < LEN(items); i++) {
+ NEW(boxedInteger);
+ boxedInteger->value = items[i].value;
+ Maps_Put(items[i].key, boxedInteger, &map);
+ }
+ assert(! Maps_IsEmpty(map));
+
+ /*retrieve keys*/
+ for (i = 0; i < LEN(items); i++) {
+ assert(Maps_HasKey(items[i].key, map));
+ }
+
+ /*retrieve values*/
+ for (i = 0; i < LEN(items); i++) {
+ boxedInteger = Maps_At(items[i].key, map);
+ assert(boxedInteger->value == items[i].value);
+ }
+
+ /*reinsert element*/
+ NEW(boxedInteger);
+ boxedInteger->value = 1;
+ Maps_Put("foo", boxedInteger, &map);
+
+ /*count elements*/
+ count = 0;
+ Maps_Apply(Count, map, NULL);
+ assert(count == 3);
+
+ /*increment all values by one*/
+ Maps_Apply(Increment, map, NULL);
+ for (i = 0; i < LEN(items); i++) {
+ assert(Maps_HasKey(items[i].key, map));
+ boxedInteger = Maps_At(items[i].key, map);
+ assert(boxedInteger->value == items[i].value + 1);
+ }
+
+ return 0;
+}
diff --git a/src/Oberon.h b/src/Oberon.h
new file mode 100644
index 0000000..affbfbe
--- /dev/null
+++ b/src/Oberon.h
@@ -0,0 +1,30 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef OBERON_H
+#define OBERON_H
+
+/*parse modes*/
+#define OBERON_NORMAL_MODE 0
+#define OBERON_ENTRY_POINT_MODE 1
+#define OBERON_IMPORT_LIST_MODE 2
+
+void Oberon_Parse(const char inputFile[], int mode);
+
+void Oberon_PrintContext(void);
+
+#endif
diff --git a/src/Oberon.l b/src/Oberon.l
new file mode 100644
index 0000000..b2aab86
--- /dev/null
+++ b/src/Oberon.l
@@ -0,0 +1,234 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+%option always-interactive
+
+%{
+#include "Oberon.h"
+#include "Util.h"
+#include "../lib/obnc/OBNC.h"
+#include "Trees.h" /*needed by YYSTYPE in y.tab.h*/
+#include "y.tab.h"
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+
+static int KeywordToken(const char word[]);
+
+%}
+
+WORD [A-Za-z][A-Za-z0-9]*
+
+INTEGER [0-9]+|[0-9][0-9A-F]*H
+
+REAL [0-9]+"."[0-9]*(E[+-]?[0-9]+)?
+
+QUOTED-STRING \"[^"\n]*\"
+
+ORDINAL-STRING [0-9][0-9A-F]*X
+
+%%
+
+[ \t\r]+
+
+\n {
+ yylineno++;
+}
+
+":=" return BECOMES;
+
+".." return DOTDOT;
+
+"<=" return LE;
+
+">=" return GE;
+
+[][*+/&~.,;|({^:)}=#<>-] return yytext[0];
+
+{WORD} {
+ int token;
+ char *lexeme;
+
+ token = KeywordToken(yytext);
+ if (token < 0) {
+ token = IDENT;
+ NEW_ARRAY(lexeme, yyleng + 1);
+ strcpy(lexeme, yytext);
+ yylval.ident = lexeme;
+ }
+ return token;
+}
+
+{INTEGER}/".."? {
+#ifdef OBNC_CONFIG_USE_LONG_INT
+ const long int max = LONG_MAX;
+#else
+ const int max = INT_MAX;
+#endif
+ int base;
+ long lexeme;
+
+ base = (yytext[yyleng - 1] == 'H')? 16: 10;
+ errno = 0;
+ lexeme = strtol(yytext, NULL, base);
+ if ((errno != 0) || (lexeme > max)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: %s: %s > %" OBNC_INT_MOD "d\n", strerror(ERANGE), yytext, max);
+ }
+ yylval.integer = (OBNC_LONGI int) lexeme;
+ return INTEGER;
+}
+
+{REAL} {
+#ifdef OBNC_CONFIG_USE_LONG_REAL
+ int n = sscanf(yytext, "%Lf", &yylval.real);
+ if (n != 1) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: %s: %s > %LG\n", strerror(ERANGE), yytext, LDBL_MAX);
+ }
+#else
+ errno = 0;
+ yylval.real = strtod(yytext, NULL);
+ if (errno != 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: %s: %s > %G\n", strerror(ERANGE), yytext, DBL_MAX);
+ }
+#endif
+ return REAL;
+}
+
+{QUOTED-STRING} {
+ int lexemeLen;
+ char *lexeme;
+
+ lexemeLen = yyleng - 1;
+ NEW_ARRAY(lexeme, lexemeLen);
+ memcpy(lexeme, yytext + 1, lexemeLen - 1);
+ lexeme[lexemeLen - 1] = '\0';
+ yylval.string = lexeme;
+ return STRING;
+}
+
+{ORDINAL-STRING} {
+ long ordinalNumber;
+ char *lexeme;
+
+ if (strcmp(yytext, "0X") == 0) {
+ ordinalNumber = 0;
+ } else {
+ errno = 0;
+ ordinalNumber = strtol(yytext, NULL, 16);
+ if ((errno != 0) || (ordinalNumber > UCHAR_MAX)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: %s: %s > 0%XX\n", strerror(ERANGE), yytext, UCHAR_MAX);
+ }
+ }
+ NEW_ARRAY(lexeme, 2);
+ lexeme[0] = (char) ordinalNumber;
+ lexeme[1] = '\0';
+ yylval.string = lexeme;
+ return STRING;
+}
+
+"(*" {
+ int level, ch;
+
+ level = 1;
+ do {
+ ch = input();
+ switch (ch) {
+ case '(':
+ ch = input();
+ if (ch == '*') {
+ level++;
+ } else {
+ unput(ch);
+ }
+ break;
+ case '*':
+ ch = input();
+ if (ch == ')') {
+ level--;
+ } else {
+ unput(ch);
+ }
+ break;
+ case '\n':
+ yylineno++;
+ break;
+ }
+ } while ((level > 0) && (ch != EOF));
+
+ if (level > 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unterminated comment\n");
+ exit(EXIT_FAILURE);
+ }
+}
+
+. {
+ if (isprint(yytext[0])) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unexpected character: %c\n", yytext[0]);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unexpected character: %02X (hex)\n", yytext[0]);
+ }
+ return -1;
+}
+
+%%
+
+static int Cmp(const void *word, const void *keywordPtr)
+{
+ return strcmp((char *) word, * (char **) keywordPtr);
+}
+
+
+static int KeywordToken(const char word[])
+{
+ static const char *keywords[] = {"ARRAY", "BEGIN", "BY", "CASE", "CONST", "DIV", "DO", "ELSE", "ELSIF", "END", "FALSE", "FOR", "IF", "IMPORT", "IN", "IS", "MOD", "MODULE", "NIL", "OF", "OR", "POINTER", "PROCEDURE", "RECORD", "REPEAT", "RETURN", "THEN", "TO", "TRUE", "TYPE", "UNTIL", "VAR", "WHILE"};
+
+ static int keywordTokens[] = {ARRAY, BEGIN_, BY, CASE, CONST, DIV, DO, ELSE, ELSIF, END, FALSE, FOR, IF, IMPORT, IN, IS, MOD, MODULE, NIL, OF, OR, POINTER, PROCEDURE, RECORD, REPEAT, RETURN, THEN, TO, TRUE, TYPE, UNTIL, VAR, WHILE};
+
+ const char **keywordPtr;
+ int pos, token;
+
+ keywordPtr = bsearch(word, keywords, LEN(keywords), sizeof keywords[0], Cmp);
+ if (keywordPtr != NULL) {
+ pos = keywordPtr - keywords;
+ assert(pos >= 0);
+ assert(pos < LEN(keywordTokens));
+ token = keywordTokens[pos];
+ } else {
+ token = -1;
+ }
+ return token;
+}
+
+
+int yywrap(void)
+{
+ const int done = 1;
+
+ return done;
+}
diff --git a/src/Oberon.y b/src/Oberon.y
new file mode 100644
index 0000000..39811c2
--- /dev/null
+++ b/src/Oberon.y
@@ -0,0 +1,4078 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+%{
+#include "Config.h"
+#include "Files.h"
+#include "Generate.h"
+#include "lex.yy.h"
+#include "Maps.h"
+#include "Oberon.h"
+#include "Path.h"
+#include "Range.h"
+#include "Table.h"
+#include "Types.h"
+#include "Trees.h"
+#include "Util.h"
+#include "../lib/obnc/OBNC.h"
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+
+/*assignment contexts*/
+#define ASSIGNMENT_CONTEXT 0
+#define PARAM_SUBST_CONTEXT 1
+#define PROC_RESULT_CONTEXT 2
+
+static const char *inputFilename;
+static int parseMode;
+static char *inputModuleName;
+
+static Trees_Node unresolvedPointerTypes;
+static Trees_Node currentTypeIdentdef;
+static Trees_Node currentCaseExpression;
+static Trees_Node caseExpressionType;
+static Trees_Node currentlyDefinedCaseLabels;
+static Trees_Node procedureDeclarationStack;
+
+void yyerror(const char format[], ...);
+
+static char *QualidentName(const char qualifier[], const char ident[]);
+
+/*constant predicate functions*/
+
+static int IsBoolean(Trees_Node node);
+static int IsChar(Trees_Node node);
+static int IsInteger(Trees_Node node);
+static int IsReal(Trees_Node node);
+static int IsString(Trees_Node node);
+static int IsSet(Trees_Node node);
+
+/*functions for type declaration productions*/
+
+static Trees_Node ResolvedType(Trees_Node type, int isTypeDecl);
+static void ResolvePointerTypes(Trees_Node baseType);
+static const char *TypeString(Trees_Node type);
+
+/*functions for expression productions*/
+
+static Trees_Node Designator(const char ident[], Trees_Node selectorList);
+static int IsDesignator(Trees_Node exp);
+static Trees_Node BaseIdent(Trees_Node designator);
+static Trees_Node FirstSelector(Trees_Node designator);
+static const char *DesignatorString(Trees_Node designator);
+static void CheckIsValueExpression(Trees_Node exp);
+static void SetSelectorTypes(Trees_Node identType, Trees_Node designator, int *parameterListFound);
+static void RemoveActualParameters(Trees_Node *designator, Trees_Node *actualParameters);
+static Trees_Node ExpressionConstValue(int relation, Trees_Node expA, Trees_Node expB);
+static Trees_Node SimpleExpressionConstValue(int addOperator, Trees_Node expA, Trees_Node expB);
+static Trees_Node TermConstValue(int mulOperator, Trees_Node expA, Trees_Node expB);
+static const char *OperatorString(int operator);
+
+/*functions for statement productions*/
+
+static int Writable(Trees_Node designator);
+static void ValidateAssignment(Trees_Node expression, Trees_Node targetType, int context, int paramPos);
+static void HandleProcedureCall(Trees_Node designator, Trees_Node actualParameters, int isFunctionCall, Trees_Node *ast);
+static void CheckCaseLabelUniqueness(Trees_Node label);
+
+/*functions for module productions*/
+
+static void ExportSymbolTable(const char symfilePath[]);
+%}
+
+%union {
+ const char *ident;
+ OBNC_LONGI int integer;
+ OBNC_LONGR double real;
+ const char *string;
+ Trees_Node node;
+}
+
+%token TOKEN_START
+
+/*reserved words (underscore avoids name clash)*/
+%token ARRAY BEGIN_ BY CASE CONST DIV DO ELSE ELSIF END FALSE FOR IF IMPORT IN IS MOD MODULE NIL OF OR POINTER PROCEDURE RECORD REPEAT RETURN THEN TO TRUE TYPE UNTIL VAR WHILE
+
+/*two-character operators and delimiters*/
+%token BECOMES DOTDOT GE LE
+
+/*tokens with semantic values*/
+%token IDENT
+%token INTEGER
+%token REAL
+%token STRING
+
+%token TOKEN_END
+
+/*nonterminals with semantic values*/
+%type AddOperator
+%type ArrayLengthOf
+%type ArrayType
+%type assignment
+%type BaseType
+%type BaseTypeOpt
+%type BecomesIdentOpt
+%type ByOpt
+%type case
+%type CaseExpression
+%type CaseLabelList
+%type CaseRep
+%type CaseStatement
+%type ConstExpression
+%type designator
+%type element
+%type ElementRep
+%type ElseIfDoOptRep
+%type ElseIfThenOptRep
+%type ElseOpt
+%type ExpList
+%type ExportMarkOpt
+%type expression
+%type factor
+%type FieldList
+%type FieldListSequence
+%type FieldListSequenceOpt
+%type ForInit
+%type ForLimit
+%type FormalParameters
+%type FormalParametersOpt
+%type FormalType
+%type ForStatement
+%type FPSection
+%type FPSectionRep
+%type FPSectionsOpt
+%type guard
+%type identdef
+%type IdentRep
+%type IfStatement
+%type IdentList
+%type import
+%type ImportRep
+%type length
+%type label
+%type LabelRange
+%type LengthRep
+%type ModuleStatements
+%type MulOperator
+%type number
+%type OpenArrayOpt
+%type ParameterKindOpt
+%type PointerTo
+%type PointerType
+%type ProcedureCall
+%type ProcedureHeading
+%type ProcedureHeadingSansParam
+%type ProcedureType
+%type ProcedureTypeSansParam
+%type qualident
+%type RecordHeading
+%type RecordType
+%type relation
+%type RepeatStatement
+%type ResultTypeOpt
+%type ReturnExpressionOpt
+%type selector
+%type SelectorOptRep
+%type set
+%type SignOpt
+%type SimpleExpression
+%type statement
+%type StatementSequence
+%type StatementSequenceOpt
+%type StatementSequenceReversed
+%type term
+%type type
+%type TypeIdentDef
+%type TypeKeyword
+%type TypeSectionOpt
+%type WhileStatement
+
+%start module
+
+%%
+
+/*IDENTIFIER RULES*/
+
+qualident:
+ IDENT
+ {
+ $$ = Trees_NewIdent($1);
+ }
+ | IDENT '.' IDENT
+ {
+ $$ = Trees_NewIdent(QualidentName($1, $3));
+ }
+ ;
+
+identdef:
+ IDENT ExportMarkOpt
+ {
+ if (! Table_LocallyDeclared($1)) {
+ $$ = Trees_NewIdent($1);
+ if ($2) {
+ Trees_SetExported($$);
+ }
+ if (Table_ScopeLocal()) {
+ Trees_SetLocal($$);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: redeclaration of identifier: %s\n", $1);
+ YYABORT;
+ }
+ }
+ ;
+
+ExportMarkOpt:
+ '*'
+ {
+ $$ = 1;
+ }
+ | /*empty*/
+ {
+ $$ = 0;
+ }
+ ;
+
+
+/*NUMBER RULE*/
+
+number:
+ INTEGER
+ {
+ $$ = Trees_NewInteger($1);
+ }
+ | REAL
+ {
+ $$ = Trees_NewReal($1);
+ }
+ ;
+
+
+/*CONSTANT DECLARATION RULES*/
+
+ConstDeclaration:
+ identdef '=' ConstExpression
+ {
+ if (! (Trees_Exported($1) && Trees_Local($1))) {
+ Trees_SetKind(TREES_CONSTANT_KIND, $1);
+ Trees_SetType(Trees_Type($3), $1);
+ Trees_SetValue($3, $1);
+ Table_Put($1);
+ Generate_ConstDeclaration($1);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: cannot export local constant: %s\n", Trees_Name($1));
+ YYABORT;
+ }
+ }
+ ;
+
+ConstExpression:
+ expression
+ {
+ switch (Trees_Symbol($1)) {
+ case TRUE:
+ case FALSE:
+ case STRING:
+ case TREES_CHAR_CONSTANT:
+ case INTEGER:
+ case REAL:
+ case TREES_SET_CONSTANT:
+ case NIL:
+ $$ = $1;
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: constant expression expected\n");
+ YYABORT;
+ }
+ }
+ ;
+
+
+/*TYPE DECLARATION RULES*/
+
+TypeDeclaration:
+ TypeIdentDef type
+ {
+ Trees_Node sourceType;
+
+ sourceType = ResolvedType($2, 1);
+ if (sourceType != NULL) {
+ if (! (Trees_Exported($1) && Trees_Local($1))) {
+ Trees_SetType(sourceType, $1);
+ ResolvePointerTypes($1);
+ currentTypeIdentdef = NULL;
+ Generate_TypeDeclaration($1);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: cannot export local type: %s\n", Trees_Name($1));
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: undeclared identifier: %s\n", Trees_Name($2));
+ YYABORT;
+ }
+ }
+ ;
+
+TypeIdentDef:
+ identdef '='
+ {
+ Trees_SetKind(TREES_TYPE_KIND, $1);
+ currentTypeIdentdef = $1;
+ Table_Put($1);
+ $$ = $1;
+ }
+ ;
+
+type:
+ qualident
+ | ArrayType
+ | RecordType
+ | PointerType
+ | ProcedureType
+ ;
+
+ArrayType:
+ ArrayLengthOf type
+ {
+ Trees_Node reversedLengths, length;
+
+ $$ = ResolvedType($2, 0);
+ if ($$ != NULL) {
+ reversedLengths = $1;
+ do {
+ length = Trees_Left(reversedLengths);
+ $$ = Types_NewArray(length, $$);
+ reversedLengths = Trees_Right(reversedLengths);
+ } while (reversedLengths != NULL);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: undeclared identifier: %s\n", Trees_Name($2));
+ exit(EXIT_FAILURE);
+ }
+ }
+ ;
+
+ArrayLengthOf:
+ ARRAY LengthRep OF
+ {
+ if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) {
+ Trees_SetType(Trees_NewLeaf(ARRAY), currentTypeIdentdef); /*incomplete type*/
+ }
+ $$ = $2;
+ }
+ ;
+
+LengthRep:
+ length
+ {
+ $$ = Trees_NewNode(TREES_NOSYM, $1, NULL);
+ }
+ | LengthRep ',' length
+ {
+ $$ = Trees_NewNode(TREES_NOSYM, $3, $1);
+ }
+ ;
+
+length:
+ ConstExpression
+ {
+ if (IsInteger($1)) {
+ if (Trees_Integer($1) > 0) {
+ $$ = $1;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: positive length expected: %" OBNC_INT_MOD "d" OBNC_INT_MOD "\n", Trees_Integer($1));
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: integer length expected\n");
+ YYABORT;
+ }
+ }
+ ;
+
+RecordType:
+ RecordHeading FieldListSequenceOpt END
+ {
+ Table_CloseScope();
+ $$ = Types_NewRecord(Types_RecordBaseType($1), $2);
+ }
+ ;
+
+RecordHeading:
+ RECORD BaseTypeOpt
+ {
+ $$ = Types_NewRecord($2, NULL);
+ if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) {
+ Trees_SetType($$, currentTypeIdentdef);
+ }
+ Table_OpenScope();
+ }
+ ;
+
+BaseTypeOpt:
+ '(' BaseType ')'
+ {
+ $$ = $2;
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+BaseType:
+ qualident
+ {
+ const char *name;
+ Trees_Node symbol;
+
+ $$ = NULL;
+ name = Trees_Name($1);
+ symbol = Table_At(name);
+ if (symbol != NULL) {
+ if (Trees_Kind(symbol) == TREES_TYPE_KIND) {
+ switch (Trees_Symbol(Types_Structure(symbol))) {
+ case RECORD:
+ case POINTER:
+ $$ = symbol;
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record or pointer base type expected: %s\n", name);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: type name expected: %s\n", name);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: undeclared identifier: %s\n", name);
+ YYABORT;
+ }
+ }
+ ;
+
+FieldListSequenceOpt:
+ FieldListSequence
+ {
+ Trees_ReverseList(&$1); /*correct order*/
+ $$ = $1;
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+FieldListSequence:
+ FieldList
+ {
+ $$ = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, $1, NULL);
+ }
+ | FieldListSequence ';' FieldList
+ {
+ $$ = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, $3, $1);
+ }
+ ;
+
+FieldList:
+ IdentList ':' type
+ {
+ Trees_Node type, identList, ident;
+
+ $$ = NULL;
+ type = ResolvedType($3, 0);
+ if (type != NULL) {
+ if (! ((type == currentTypeIdentdef) && ! Types_IsPointer(type))) {
+ Trees_ReverseList(&$1); /*correct order*/
+ identList = $1;
+ do {
+ ident = Trees_Left(identList);
+ if (! Table_LocallyDeclared(Trees_Name(ident))) {
+ Trees_SetKind(TREES_FIELD_KIND, ident);
+ Trees_SetType(type, ident);
+ Table_Put(ident);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: redeclaration of identifier with the same name: %s\n", Trees_Name(ident));
+ YYABORT;
+ }
+ identList = Trees_Right(identList);
+ } while (identList != NULL);
+
+ $$ = $1;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: recursive field type must be a pointer: %s\n", Trees_Name($3));
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: undeclared type: %s\n", Trees_Name($3));
+ YYABORT;
+ }
+ }
+ ;
+
+IdentList:
+ identdef
+ {
+ $$ = Trees_NewNode(TREES_IDENT_LIST, $1, NULL);
+ }
+ | IdentList ',' identdef
+ {
+ Trees_Node reversedIdents;
+
+ reversedIdents = Trees_NewNode(TREES_IDENT_LIST, $3, $1);
+ $$ = reversedIdents;
+ }
+ ;
+
+PointerType:
+ PointerTo type
+ {
+ const char *baseTypeName;
+ Trees_Node declaredBaseType;
+
+ $$ = NULL;
+ if (Trees_Symbol($2) == IDENT) {
+ baseTypeName = Trees_Name($2);
+ declaredBaseType = Table_At(baseTypeName);
+ if (declaredBaseType != NULL) {
+ if (Types_IsRecord(declaredBaseType)) {
+ $$ = Types_NewPointer(declaredBaseType);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record expected as pointer base type: %s\n", baseTypeName);
+ YYABORT;
+ }
+ } else if (currentTypeIdentdef != NULL) {
+ Trees_SetKind(TREES_TYPE_KIND, $2);
+ Trees_SetType(Types_NewRecord(NULL, NULL), $2);
+ $$ = Types_NewPointer($2);
+ unresolvedPointerTypes = Trees_NewNode(TREES_NOSYM, $$, unresolvedPointerTypes);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: undeclared type: %s\n", baseTypeName);
+ YYABORT;
+ }
+ } else if(Trees_Symbol($2) == RECORD) {
+ $$ = Types_NewPointer($2);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record expected as pointer base type\n");
+ YYABORT;
+ }
+ }
+ ;
+
+PointerTo:
+ POINTER TO
+ {
+ if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) {
+ Trees_SetType(Types_NewPointer(NULL), currentTypeIdentdef); /*incomplete type*/
+ }
+ }
+ ;
+
+ProcedureType:
+ ProcedureTypeSansParam FormalParametersOpt
+ {
+ Table_CloseScope();
+ $$ = $2;
+ }
+ ;
+
+ProcedureTypeSansParam:
+ PROCEDURE
+ {
+ Table_OpenScope();
+ $$ = NULL;
+ }
+ ;
+
+FormalParametersOpt:
+ FormalParameters
+ | /*empty*/
+ {
+ $$ = Trees_NewLeaf(PROCEDURE);
+ }
+ ;
+
+
+/*VARIABLE DECLARATION RULE*/
+
+VariableDeclaration:
+ IdentList ':' type
+ {
+ Trees_Node type, identList, ident;
+
+ type = ResolvedType($3, 0);
+ if (type != NULL) {
+ Trees_ReverseList(&$1); /*correct order*/
+ identList = $1;
+ do {
+ ident = Trees_Left(identList);
+ if (! (Trees_Exported(ident) && Trees_Local(ident))) {
+ if (! Table_LocallyDeclared(Trees_Name(ident))) {
+ Trees_SetKind(TREES_VARIABLE_KIND, ident);
+ Trees_SetType(type, ident);
+ Table_Put(ident);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: redeclaration of identifier with the same name: %s\n", Trees_Name(ident));
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: cannot export local variable: %s\n", Trees_Name(ident));
+ YYABORT;
+ }
+ identList = Trees_Right(identList);
+ } while (identList != NULL);
+
+ Generate_VariableDeclaration($1);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: undeclared identifier: %s\n", Trees_Name($3));
+ exit(EXIT_FAILURE);
+ }
+ }
+ ;
+
+
+/*EXPRESSION RULES*/
+
+expression:
+ SimpleExpression
+ | SimpleExpression relation SimpleExpression
+ {
+ Trees_Node expA, expB, typeA, typeB;
+
+ expA = $1;
+ expB = $3;
+ typeA = Trees_Type($1);
+ typeB = Trees_Type($3);
+
+ CheckIsValueExpression($1);
+ if ($2 == IS) {
+ if (! Types_IsRecord(typeA)
+ || (IsDesignator($1) && (Trees_Kind(BaseIdent($1)) == TREES_VAR_PARAM_KIND))) {
+ if (IsDesignator($3)) {
+ expB = BaseIdent($3);
+ typeB = BaseIdent($3);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: identifier expected as first operand of IS\n");
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: variable parameter expected as first operand of IS\n");
+ YYABORT;
+ }
+ } else {
+ CheckIsValueExpression($3);
+ }
+
+ if (Types_ExpressionCompatible($2, typeA, typeB)) {
+ $$ = ExpressionConstValue($2, expA, expB);
+ if ($$ == NULL) {
+ if (IsString(expA) && Types_IsChar(typeB)) {
+ expA = Trees_NewChar(Trees_String(expA)[0]);
+ } else if (Types_IsChar(typeA) && IsString(expB)) {
+ expB = Trees_NewChar(Trees_String(expB)[0]);
+ }
+ $$ = Trees_NewNode($2, expA, expB);
+ Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), $$);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible types in relation \"%s\": %s, %s\n",
+ OperatorString($2), TypeString(typeA), TypeString(typeB));
+ YYABORT;
+ }
+ }
+ ;
+
+relation:
+ '='
+ {
+ $$ = '=';
+ }
+ | '#'
+ {
+ $$ = '#';
+ }
+ | '<'
+ {
+ $$ = '<';
+ }
+ | LE
+ {
+ $$ = LE;
+ }
+ | '>'
+ {
+ $$ = '>';
+ }
+ | GE
+ {
+ $$ = GE;
+ }
+ | IN
+ {
+ $$ = IN;
+ }
+ | IS
+ {
+ $$ = IS;
+ }
+ ;
+
+SimpleExpression:
+ SignOpt term
+ {
+ $$ = $2;
+ if ($1 >= 0) {
+ CheckIsValueExpression($2);
+ if (Types_ExpressionCompatible($1, Trees_Type($2), NULL)) {
+ $$ = SimpleExpressionConstValue($1, $2, NULL);
+ if ($$ == NULL) {
+ $$ = Trees_NewNode($1, $2, NULL);
+ if (Types_IsByte(Trees_Type($2))) {
+ Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), $$);
+ } else {
+ Trees_SetType(Trees_Type($2), $$);
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible type in unary operation \"%s\": %s\n", OperatorString($1), TypeString(Trees_Type($2)));
+ YYABORT;
+ }
+ }
+ }
+ | SimpleExpression AddOperator term
+ {
+ $$ = NULL;
+
+ CheckIsValueExpression($1);
+ CheckIsValueExpression($3);
+
+ if (Types_ExpressionCompatible($2, Trees_Type($1), Trees_Type($3))) {
+ $$ = SimpleExpressionConstValue($2, $1, $3);
+ if ($$ == NULL) {
+ $$ = Trees_NewNode($2, $1, $3);
+ if (Types_IsByte(Trees_Type($1)) || Types_IsByte(Trees_Type($3))) {
+ Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), $$);
+ } else {
+ Trees_SetType(Trees_Type($1), $$);
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible types in operation \"%s\": %s, %s\n",
+ OperatorString($2), TypeString(Trees_Type($1)), TypeString(Trees_Type($3)));
+ YYABORT;
+ }
+ assert($$ != NULL);
+ }
+ ;
+
+SignOpt:
+ '+'
+ {
+ $$ = '+';
+ }
+ | '-'
+ {
+ $$ = '-';
+ }
+ | /*empty*/
+ {
+ $$ = -1;
+ }
+ ;
+
+AddOperator:
+ '+'
+ {
+ $$ = '+';
+ }
+ | '-'
+ {
+ $$ = '-';
+ }
+ | OR
+ {
+ $$ = OR;
+ }
+ ;
+
+term:
+ factor
+ | term MulOperator factor
+ {
+ $$ = NULL;
+
+ CheckIsValueExpression($1);
+ CheckIsValueExpression($3);
+
+ if (Types_ExpressionCompatible($2, Trees_Type($1), Trees_Type($3))) {
+ $$ = TermConstValue($2, $1, $3);
+ if ($$ == NULL) {
+ $$ = Trees_NewNode($2, $1, $3);
+ if (Types_IsByte(Trees_Type($1)) || Types_IsByte(Trees_Type($3))) {
+ Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), $$);
+ } else {
+ Trees_SetType(Trees_Type($1), $$);
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible types in operation \"%s\": %s, %s\n",
+ OperatorString($2), TypeString(Trees_Type($1)), TypeString(Trees_Type($3)));
+ YYABORT;
+ }
+
+ assert($$ != NULL);
+ }
+ ;
+
+MulOperator:
+ '*'
+ {
+ $$ = '*';
+ }
+ | '/'
+ {
+ $$ = '/';
+ }
+ | DIV
+ {
+ $$ = DIV;
+ }
+ | MOD
+ {
+ $$ = MOD;
+ }
+ | '&'
+ {
+ $$ = '&';
+ }
+ ;
+
+factor:
+ number
+ | STRING
+ {
+ $$ = Trees_NewString($1);
+ }
+ | NIL
+ {
+ $$ = Trees_NewLeaf(NIL);
+ Trees_SetType(Trees_NewLeaf(TREES_NIL_TYPE), $$);
+ }
+ | TRUE
+ {
+ $$ = Trees_NewLeaf(TRUE);
+ Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), $$);
+ }
+ | FALSE
+ {
+ $$ = Trees_NewLeaf(FALSE);
+ Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), $$);
+ }
+ | set
+ {
+ $$ = $1;
+ Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$);
+ }
+ /*NOTE: actual parameters are parsed by rule `designator'*/
+ | designator
+ {
+ const int isFunctionCall = 1;
+ Trees_Node designator, actualParameters, ident;
+
+ $$ = NULL;
+ if (Trees_Symbol($1) == TREES_PROCEDURE_CALL) {
+ designator = Trees_Left($1);
+ actualParameters = Trees_Right($1);
+ HandleProcedureCall(designator, actualParameters, isFunctionCall, &$$);
+ } else {
+ ident = Trees_Left($1);
+ if (Trees_Kind(ident) == TREES_CONSTANT_KIND) {
+ $$ = Trees_Value(ident);
+ } else {
+ $$ = $1;
+ }
+ }
+ assert($$ != NULL);
+ }
+ | '(' expression ')'
+ {
+ CheckIsValueExpression($2);
+ $$ = $2;
+ }
+ | '~' factor
+ {
+ $$ = NULL;
+ CheckIsValueExpression($2);
+ if (Types_ExpressionCompatible('~', Trees_Type($2), NULL)) {
+ switch (Trees_Symbol($2)) {
+ case TRUE:
+ $$ = Trees_NewLeaf(FALSE);
+ break;
+ case FALSE:
+ $$ = Trees_NewLeaf(TRUE);
+ break;
+ default:
+ $$ = Trees_NewNode('~', $2, NULL);
+ }
+ Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), $$);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible type in operation \"~\": %s\n", TypeString(Trees_Type($2)));
+ YYABORT;
+ }
+ assert($$ != NULL);
+ }
+ ;
+
+designator:
+ /*NOTE: qualified (imported) identifiers are parsed as field designators and detected semantically*/
+ IDENT SelectorOptRep
+ {
+ Trees_Node designator, identType, actualParameters;
+ int parameterListFound; /*possibly empty*/
+
+ Trees_ReverseList(&$2); /*correct order*/
+ designator = Designator($1, $2);
+
+ identType = Trees_Type(BaseIdent(designator));
+ SetSelectorTypes(identType, designator, ¶meterListFound);
+ if (parameterListFound) {
+ RemoveActualParameters(&designator, &actualParameters);
+ $$ = Trees_NewNode(TREES_PROCEDURE_CALL, designator, actualParameters);
+ } else {
+ $$ = designator;
+ }
+ }
+ ;
+
+SelectorOptRep:
+ SelectorOptRep selector
+ {
+ Trees_Node curr;
+
+ if ((Trees_Symbol($2) == '[') && (Trees_Right($2) != NULL)) { /*multi-dimensional element selector*/
+ /*attatch last element selector node to $1*/
+ Trees_ReverseList(&$2);
+ $$ = $1;
+ curr = $2;
+ do {
+ $$ = Trees_NewNode('[', Trees_Left(curr), $$);
+ curr = Trees_Right(curr);
+ } while (curr != NULL);
+ Trees_ReverseList(&$$);
+ } else {
+ $$ = Trees_NewNode(Trees_Symbol($2), Trees_Left($2), $1);
+ }
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+selector:
+ '.' IDENT
+ {
+ Trees_Node field;
+
+ field = Trees_NewIdent($2);
+ Trees_SetKind(TREES_FIELD_KIND, field);
+ $$ = Trees_NewNode('.', field, NULL);
+ }
+ | '[' ExpList ']'
+ {
+ Trees_Node curr, exp;
+
+ /*create one selector node per index*/
+ $$ = NULL;
+ curr = $2; /*NOTE: ExpList is reversed*/
+ do {
+ exp = Trees_Left(curr);
+ if (Types_IsInteger(Trees_Type(exp))) {
+ $$ = Trees_NewNode('[', Trees_Left(curr), $$);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: integer array index expected\n");
+ YYABORT;
+ }
+ curr = Trees_Right(curr);
+ } while (curr != NULL);
+ }
+ | '^'
+ {
+ $$ = Trees_NewNode('^', NULL, NULL);
+ }
+ /*NOTE: Procedure calls are parsed as designators and distinguished from type guards through semantic analysis.*/
+ | '(' ExpList ')' /*type guard or actual parameters*/
+ {
+ Trees_ReverseList(&$2); /*correct order*/
+ $$ = Trees_NewNode('(', $2, NULL);
+ }
+ | '(' ')' /*actual parameters*/
+ {
+ $$ = Trees_NewNode('(', NULL, NULL);
+ }
+ ;
+
+set:
+ '{' '}'
+ {
+ $$ = Trees_NewSet(0x0u);
+ }
+ | '{' ElementRep '}'
+ {
+ $$ = $2;
+ }
+ ;
+
+ElementRep:
+ element
+ | ElementRep ',' element
+ {
+ if ((Trees_Symbol($1) == TREES_SET_CONSTANT)
+ && (Trees_Symbol($3) == TREES_SET_CONSTANT)) {
+ $$ = Trees_NewSet(Trees_Set($1) | Trees_Set($3));
+ } else {
+ $$ = Trees_NewNode('+', $1, $3);
+ }
+ }
+ ;
+
+element:
+ expression
+ {
+ int i;
+ Trees_Node type;
+
+ CheckIsValueExpression($1);
+ $$ = NULL;
+ type = Trees_Type($1);
+ if (IsInteger($1)) {
+ i = Trees_Integer($1);
+ Range_CheckSetElement(i);
+ $$ = Trees_NewSet(1 << i);
+ } else if (Types_IsInteger(type)) {
+ $$ = Trees_NewNode(TREES_SINGLE_ELEMENT_SET, $1, NULL);
+ Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: element must have integer type\n");
+ YYABORT;
+ }
+ }
+ | expression DOTDOT expression
+ {
+ CheckIsValueExpression($1);
+ CheckIsValueExpression($3);
+ $$ = NULL;
+ if (IsInteger($1)) {
+ Range_CheckSetElement(Trees_Integer($1));
+ }
+ if (IsInteger($3)) {
+ Range_CheckSetElement(Trees_Integer($3));
+ }
+ if (IsInteger($1) && IsInteger($3)) {
+ $$ = Trees_NewSet(OBNC_RANGE(Trees_Integer($1), Trees_Integer($3)));
+ } else if (Types_IsInteger(Trees_Type($1)) && Types_IsInteger(Trees_Type($3))) {
+ $$ = Trees_NewNode(TREES_RANGE_SET, $1, $3);
+ Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: element must have integer type\n");
+ YYABORT;
+ }
+ }
+ ;
+
+ExpList:
+ expression
+ {
+ $$ = Trees_NewNode(TREES_EXP_LIST, $1, NULL);
+ Trees_SetType(Trees_Type($1), $$);
+ }
+ | ExpList ',' expression
+ {
+ Trees_Node reversedList;
+
+ reversedList = Trees_NewNode(TREES_EXP_LIST, $3, $1);
+ $$ = reversedList;
+ Trees_SetType(Trees_Type($3), $$);
+ }
+ ;
+
+
+/*STATEMENT RULES*/
+
+statement:
+ assignment
+ | ProcedureCall
+ | IfStatement
+ | CaseStatement
+ | WhileStatement
+ | RepeatStatement
+ | ForStatement
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+assignment:
+ designator BECOMES expression
+ {
+ Trees_Node designator, ident, designatorType, exp;
+
+ CheckIsValueExpression($3);
+ switch (Trees_Symbol($1)) {
+ case TREES_DESIGNATOR:
+ designator = $1;
+ exp = $3;
+ ident = BaseIdent($1);
+ designatorType = Trees_Type($1);
+ switch (Trees_Kind(ident)) {
+ case TREES_VARIABLE_KIND:
+ case TREES_VALUE_PARAM_KIND:
+ case TREES_VAR_PARAM_KIND:
+ if (Writable($1)) {
+ ValidateAssignment(exp, designatorType, ASSIGNMENT_CONTEXT, 0);
+ if (Types_IsChar(designatorType) && IsString(exp)) {
+ exp = Trees_NewChar(Trees_String(exp)[0]);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: assignment to read-only variable\n");
+ YYABORT;
+ }
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: assignment to non-variable\n");
+ YYABORT;
+ }
+ $$ = Trees_NewNode(BECOMES, designator, exp);
+ break;
+ case TREES_PROCEDURE_CALL:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unexpected procedure call in assignment target\n");
+ YYABORT;
+ break;
+ default:
+ assert(0);
+ }
+ }
+ ;
+
+ProcedureCall:
+ /*NOTE: actual parameters are parsed by rule `designator'*/
+ designator
+ {
+ const int isFunctionCall = 0;
+ Trees_Node designator, actualParameters;
+
+ if (Trees_Symbol($1) == TREES_PROCEDURE_CALL) {
+ designator = Trees_Left($1);
+ actualParameters = Trees_Right($1);
+ } else {
+ designator = $1;
+ actualParameters = NULL;
+ }
+ HandleProcedureCall(designator, actualParameters, isFunctionCall, &$$);
+ assert($$ != NULL);
+ }
+ ;
+
+StatementSequence:
+ StatementSequenceReversed
+ {
+ Trees_ReverseList(&$1); /*correct order*/
+ $$ = $1;
+ }
+ ;
+
+StatementSequenceReversed:
+ statement
+ {
+ if ($1 == NULL) {
+ $$ = NULL;
+ } else {
+ $$ = Trees_NewNode(TREES_STATEMENT_SEQUENCE, $1, NULL);
+ }
+ }
+ | StatementSequenceReversed ';' statement
+ {
+ if ($3 != NULL) {
+ $$ = Trees_NewNode(TREES_STATEMENT_SEQUENCE, $3, $1);
+ } else {
+ $$ = $1;
+ }
+ }
+ ;
+
+IfStatement:
+ IF guard THEN StatementSequence ElseIfThenOptRep ElseOpt END
+ {
+ Trees_Node currElsif, currExp, currThen, currStmt;
+
+ if ($5 == NULL) {
+ $$ = Trees_NewNode(IF, $2, Trees_NewNode(THEN, $4, $6));
+ } else {
+ /*correct order of elsif nodes*/
+ $$ = $6;
+ currElsif = $5;
+ do {
+ currExp = Trees_Left(currElsif);
+ currThen = Trees_Right(currElsif);
+ currStmt = Trees_Left(currThen);
+ $$ = Trees_NewNode(ELSIF, currExp, Trees_NewNode(THEN, currStmt, $$));
+ currElsif = Trees_Right(currThen);
+ } while (currElsif != NULL);
+ $$ = Trees_NewNode(IF, $2, Trees_NewNode(THEN, $4, $$));
+ }
+ }
+ ;
+
+guard:
+ expression
+ {
+ CheckIsValueExpression($1);
+ if (Types_IsBoolean(Trees_Type($1))) {
+ $$ = $1;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: boolean expression expected\n");
+ YYABORT;
+ }
+ }
+ ;
+
+ElseIfThenOptRep:
+ ElseIfThenOptRep ELSIF guard THEN StatementSequence
+ {
+ $$ = Trees_NewNode(ELSIF, $3, Trees_NewNode(THEN, $5, $1));
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+ElseOpt:
+ ELSE StatementSequence
+ {
+ $$ = Trees_NewNode(ELSE, $2, NULL);
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+CaseStatement:
+ CASE CaseExpression OF CaseRep END
+ {
+ Trees_Node expType, caseVariable;
+
+ if ($4 != NULL) {
+ Trees_ReverseList(&$4); /*correct order*/
+ }
+ expType = Trees_Type($2);
+ if (Types_IsRecord(expType) || Types_IsPointer(expType)) {
+ /*reset original type*/
+ caseVariable = Trees_Left($2);
+ Trees_SetType(caseExpressionType, caseVariable);
+ }
+ $$ = Trees_NewNode(CASE, $2, $4);
+ }
+ ;
+
+CaseExpression:
+ expression
+ {
+ Trees_Node typeStruct, caseVariable;
+
+ CheckIsValueExpression($1);
+ typeStruct = Types_Structure(Trees_Type($1));
+ switch (Trees_Symbol(typeStruct)) {
+ case RECORD:
+ /*fall through*/
+ case POINTER:
+ if (IsDesignator($1) && (FirstSelector($1) == NULL)) {
+ caseVariable = BaseIdent($1);
+ if (! Types_IsRecord(typeStruct) || (Trees_Kind(caseVariable) == TREES_VAR_PARAM_KIND)) {
+ $$ = $1;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record CASE expression must be a variable parameter\n");
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: non-integral CASE expression must be a variable\n");
+ YYABORT;
+ }
+ /*fall through*/
+ case TREES_INTEGER_TYPE:
+ /*fall through*/
+ case TREES_CHAR_TYPE:
+ currentCaseExpression = $1;
+ caseExpressionType = Trees_Type($1);
+ currentlyDefinedCaseLabels = NULL;
+ $$ = $1;
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: invalid type of CASE expression\n");
+ YYABORT;
+ }
+ }
+ ;
+
+CaseRep:
+ case
+ {
+ if ($1 != NULL) {
+ $$ = Trees_NewNode(TREES_CASE_REP, $1, NULL);
+ } else {
+ $$ = NULL;
+ }
+ }
+ | CaseRep '|' case
+ {
+ if ($3 != NULL) {
+ if ($1 != NULL) {
+ $$ = Trees_NewNode(TREES_CASE_REP, $3, $1);
+ } else {
+ $$ = Trees_NewNode(TREES_CASE_REP, $3, NULL);
+ }
+ } else {
+ $$ = NULL;
+ }
+ }
+ ;
+
+case:
+ CaseLabelList ':' StatementSequence
+ {
+ Trees_ReverseList(&$1); /*correct order*/
+ $$ = Trees_NewNode(TREES_CASE, $1, $3);
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+CaseLabelList:
+ LabelRange
+ {
+ $$ = Trees_NewNode(TREES_CASE_LABEL_LIST, $1, NULL);
+ }
+ | CaseLabelList ',' LabelRange
+ {
+ switch (Trees_Symbol($3)) {
+ case INTEGER:
+ case TREES_CHAR_CONSTANT:
+ case DOTDOT:
+ $$ = Trees_NewNode(TREES_CASE_LABEL_LIST, $3, $1);
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unexpected list of type name labels\n");
+ YYABORT;
+ }
+ }
+ ;
+
+LabelRange:
+ label
+ {
+ $$ = $1;
+ CheckCaseLabelUniqueness($1);
+ currentlyDefinedCaseLabels = Trees_NewNode(TREES_NOSYM, $1, currentlyDefinedCaseLabels);
+ }
+ | label DOTDOT label
+ {
+ const int rangeLenMax = 255;
+ int leftSym, rightSym;
+ int rangeMin, rangeMax;
+
+ leftSym = Trees_Symbol($1);
+ rightSym = Trees_Symbol($3);
+ if (leftSym == rightSym) {
+ switch (leftSym) {
+ case INTEGER:
+ rangeMin = Trees_Integer($1);
+ rangeMax = Trees_Integer($3);
+ if (rangeMin <= rangeMax) {
+ if (rangeMax - rangeMin > rangeLenMax) {
+ Oberon_PrintContext();
+ fprintf(stderr, "maximum range length of %d exceeded\n", rangeLenMax);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: left integer must be less than right integer in case range\n");
+ YYABORT;
+ }
+ break;
+ case TREES_CHAR_CONSTANT:
+ if (Trees_Char($1) >= Trees_Char($3)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: left string must be less than right string in case range\n");
+ YYABORT;
+ }
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: case label ranges must contain integers or single-character strings\n");
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: case labels in a range must have the same type\n");
+ YYABORT;
+ }
+ $$ = Trees_NewNode(DOTDOT, $1, $3);
+ CheckCaseLabelUniqueness($$);
+ currentlyDefinedCaseLabels = Trees_NewNode(TREES_NOSYM, $$, currentlyDefinedCaseLabels);
+ }
+ ;
+
+label:
+ INTEGER
+ {
+ if (Types_IsInteger(Trees_Type(currentCaseExpression))) {
+ $$ = Trees_NewInteger($1);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unexpected integer label\n");
+ YYABORT;
+ }
+ }
+ | STRING
+ {
+ if (Types_IsChar(Trees_Type(currentCaseExpression))) {
+ if (strlen($1) <= 1) {
+ $$ = Trees_NewChar($1[0]);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "single-character string expected: %s\n", $1);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "unexpected string label: %s\n", $1);
+ YYABORT;
+ }
+ }
+ | qualident
+ {
+ Trees_Node caseExpTypeStruct, constValue, caseVariable;
+
+ $$ = Table_At(Trees_Name($1));
+ if ($$ != NULL) {
+ caseExpTypeStruct = Types_Structure(Trees_Type(currentCaseExpression));
+ switch (Trees_Symbol(caseExpTypeStruct)) {
+ case TREES_INTEGER_TYPE:
+ constValue = Trees_Value($$);
+ if (Trees_Symbol(constValue) == INTEGER) {
+ if (Trees_Integer(constValue) >= 0) {
+ $$ = constValue;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "non-negative case label expected: %" OBNC_INT_MOD "d\n", Trees_Integer(constValue));
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: integer label expected\n");
+ YYABORT;
+ }
+ break;
+ case TREES_CHAR_TYPE:
+ constValue = Trees_Value($$);
+ if (Trees_Symbol(constValue) == STRING) {
+ if (Types_StringLength(Trees_Type(constValue)) <= 1) {
+ $$ = Trees_NewChar(Trees_String(constValue)[0]);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "single-character string expected: %s\n", Trees_String(constValue));
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: character label expected\n");
+ YYABORT;
+ }
+ break;
+ case RECORD:
+ if (Types_IsRecord($$)) {
+ if (Types_Extends(Trees_Type(currentCaseExpression), $$)) {
+ caseVariable = Trees_Left(currentCaseExpression);
+ Trees_SetType($$, caseVariable);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: extended type expected in label\n");
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record type label expected\n");
+ YYABORT;
+ }
+ break;
+ case POINTER:
+ if (Types_IsPointer($$)) {
+ if (Types_Extends(Trees_Type(currentCaseExpression), $$)) {
+ caseVariable = Trees_Left(currentCaseExpression);
+ Trees_SetType($$, caseVariable);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: extended type expected in label\n");
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: pointer type label expected\n");
+ YYABORT;
+ }
+ break;
+ default:
+ assert(0);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared identifier: %s\n", Trees_Name($1));
+ YYABORT;
+ }
+ }
+ ;
+
+WhileStatement:
+ WHILE guard DO StatementSequence ElseIfDoOptRep END
+ {
+ $$ = Trees_NewNode(WHILE, $2, Trees_NewNode(DO, $4, $5));
+ }
+ ;
+
+ElseIfDoOptRep:
+ ElseIfDoOptRep ELSIF guard DO StatementSequence
+ {
+ $$ = Trees_NewNode(ELSIF, $3, Trees_NewNode(THEN, $5, $1));
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+RepeatStatement:
+ REPEAT StatementSequence UNTIL expression
+ {
+ CheckIsValueExpression($4);
+ $$ = NULL;
+ if (Types_IsBoolean(Trees_Type($4))) {
+ $$ = Trees_NewNode(REPEAT, $2, $4);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: boolean expression expected\n");
+ YYABORT;
+ }
+ }
+ ;
+
+
+ForStatement:
+ FOR ForInit TO ForLimit ByOpt DO StatementSequence END
+ {
+ Trees_Node byExp;
+
+ if ($5 != NULL) {
+ byExp = $5;
+ } else {
+ byExp = Trees_NewInteger(1);
+ }
+ $$ = Trees_NewNode(FOR,
+ $2,
+ Trees_NewNode(TO,
+ $4,
+ Trees_NewNode(BY, byExp, $7)));
+ }
+ ;
+
+ForInit:
+ IDENT BECOMES expression
+ {
+ Trees_Node ctrlVar, ctrlVarType;
+
+ CheckIsValueExpression($3);
+ ctrlVar = Table_At($1);
+ if (ctrlVar != NULL) {
+ ctrlVarType = Trees_Type(ctrlVar);
+ if (Types_IsInteger(ctrlVarType)) {
+ if (Types_IsInteger(Trees_Type($3))) {
+ $$ = Trees_NewNode(BECOMES, ctrlVar, $3);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: integer expression expected as initial value\n");
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer control variable expected: %s\n", $1);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared control variable: %s\n", $1);
+ YYABORT;
+ }
+ }
+
+ForLimit:
+ expression
+ {
+ CheckIsValueExpression($1);
+ if (! Types_IsInteger(Trees_Type($1))) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: integer expression expected as upper limit\n");
+ YYABORT;
+ }
+ }
+ ;
+
+ByOpt:
+ BY ConstExpression
+ {
+ if (IsInteger($2)) {
+ if (Trees_Integer($2) != 0) {
+ $$ = $2;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: steps by zero leads to infinite loop\n");
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: integer increment expected\n");
+ YYABORT;
+ }
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+
+/*PROCEDURE DECLARATION RULES*/
+
+ProcedureDeclaration:
+ ProcedureHeading ';' DeclarationSequence StatementSequenceOpt ReturnExpressionOpt END IDENT
+ {
+ Trees_Node procIdent, procType, resultType, procStatements, returnExp;
+ const char *procName;
+
+ procIdent = $1;
+ procName = Trees_Name(procIdent);
+ procType = Trees_Type($1);
+ resultType = Types_ResultType(procType);
+ procStatements = $4;
+ returnExp = $5;
+
+ if (strcmp(procName, $7) == 0) {
+ if (resultType == NULL) {
+ if (returnExp != NULL) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: unexpected return expression\n");
+ YYABORT;
+ }
+ } else {
+ if (returnExp != NULL) {
+ CheckIsValueExpression(returnExp);
+ ValidateAssignment(returnExp, resultType, PROC_RESULT_CONTEXT, 0);
+ if ((Trees_Symbol(returnExp) == STRING) && Types_IsChar(resultType)) {
+ returnExp = Trees_NewChar(Trees_String(returnExp)[0]);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: return expression expected\n");
+ YYABORT;
+ }
+ }
+ if (procStatements != NULL) {
+ Generate_ProcedureStatements(procStatements);
+ }
+ if (returnExp != NULL) {
+ Generate_ReturnClause(returnExp);
+ }
+ if (procedureDeclarationStack != NULL) {
+ procedureDeclarationStack = Trees_Right(procedureDeclarationStack);
+ }
+ Generate_ProcedureEnd(procIdent);
+ Table_CloseScope();
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "expected procedure name: %s\n", procName);
+ YYABORT;
+ }
+ }
+ ;
+
+ProcedureHeading:
+ ProcedureHeadingSansParam FormalParametersOpt
+ {
+ Trees_Node paramList, param;
+
+ $$ = NULL;
+ Table_CloseScope();
+ Trees_SetType($2, $1);
+ Table_OpenScope();
+
+ /*reenter parameters in the symbol table*/
+ paramList = Types_Parameters($2);
+ while (paramList != NULL) {
+ param = Trees_Left(paramList);
+ Table_Put(param);
+ paramList = Trees_Right(paramList);
+ }
+
+ procedureDeclarationStack = Trees_NewNode(TREES_NOSYM, $1, procedureDeclarationStack);
+ Generate_ProcedureHeading($1);
+ $$ = $1;
+ }
+ ;
+
+ProcedureHeadingSansParam:
+ PROCEDURE identdef
+ {
+ if (! (Trees_Exported($2) && Trees_Local($2))) {
+ Trees_SetKind(TREES_PROCEDURE_KIND, $2);
+ Table_Put($2);
+ Table_OpenScope();
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "cannot export local procedure: %s\n", Trees_Name($2));
+ YYABORT;
+ }
+ $$ = $2;
+ }
+ ;
+
+StatementSequenceOpt:
+ BEGIN_ StatementSequence
+ {
+ $$ = $2;
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+ReturnExpressionOpt:
+ RETURN expression
+ {
+ $$ = $2;
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+DeclarationSequence:
+ ConstSectionOpt TypeSectionOpt VariableSectionOpt ProcedureDeclarationOptRep
+ ;
+
+ConstSectionOpt:
+ CONST ConstDeclarationOptRep
+ | /*empty*/
+ ;
+
+ConstDeclarationOptRep:
+ ConstDeclarationOptRep ConstDeclaration ';'
+ | /*empty*/
+ ;
+
+TypeSectionOpt:
+ TypeKeyword TypeDeclarationOptRep
+ {
+ Trees_Node unresolvedPointerType, undeclaredBaseType;
+
+ if (unresolvedPointerTypes != NULL) {
+ unresolvedPointerType = Trees_Left(unresolvedPointerTypes);
+ undeclaredBaseType = Types_PointerBaseType(unresolvedPointerType);
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared pointer base type: %s\n", Trees_Name(undeclaredBaseType));
+ YYABORT;
+ }
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+TypeKeyword:
+ TYPE
+ {
+ unresolvedPointerTypes = NULL;
+ }
+ ;
+
+TypeDeclarationOptRep:
+ TypeDeclarationOptRep TypeDeclaration ';'
+ | /*empty*/
+ ;
+
+VariableSectionOpt:
+ VAR VariableDeclarationOptRep
+ | /*empty*/
+ ;
+
+VariableDeclarationOptRep:
+ VariableDeclarationOptRep VariableDeclaration ';'
+ | /*empty*/
+ ;
+
+ProcedureDeclarationOptRep:
+ ProcedureDeclarationOptRep ProcedureDeclaration ';'
+ | /*empty*/
+ ;
+
+FormalParameters:
+ '(' FPSectionsOpt ')' ResultTypeOpt
+ {
+ $$ = Types_NewProcedure($2, $4);
+ }
+ ;
+
+FPSectionsOpt:
+ FPSectionRep
+ {
+ Trees_ReverseList(&$1); /*correct order*/
+ $$ = $1;
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+FPSectionRep:
+ FPSection
+ {
+ $$ = $1;
+ Trees_ReverseList(&$$);
+ }
+ | FPSectionRep ';' FPSection
+ {
+ Trees_Node curr;
+
+ /*make one list of the two lists*/
+ $$ = $1;
+ curr = $3;
+ do {
+ $$ = Trees_NewNode(TREES_IDENT_LIST, Trees_Left(curr), $$);
+ curr = Trees_Right(curr);
+ } while (curr != NULL);
+ /*$$ in reversed order*/
+ }
+ ;
+
+ResultTypeOpt:
+ ':' qualident
+ {
+ $$ = ResolvedType($2, 0);
+ if ($$ != NULL) {
+ if (Trees_Symbol($$) == IDENT) {
+ if (Trees_Kind($$) != TREES_TYPE_KIND) {
+ Oberon_PrintContext();
+ fprintf(stderr, "type name expected as result type: %s\n", Trees_Name($2));
+ YYABORT;
+ }
+ if (! Types_Scalar($$)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "scalar result type expected: %s\n", Trees_Name($2));
+ YYABORT;
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared identifier: %s\n", Trees_Name($2));
+ YYABORT;
+ }
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+FPSection:
+ ParameterKindOpt IdentRep ':' FormalType
+ {
+ Trees_Node curr, ident;
+
+ Trees_ReverseList(&$2); /*correct order*/
+ curr = $2;
+ do {
+ ident = Trees_Left(curr);
+ Trees_SetKind($1, ident);
+ Trees_SetType($4, ident);
+ Trees_SetLocal(ident);
+ if (! Table_LocallyDeclared(Trees_Name(ident))) {
+ Table_Put(ident);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "redeclaration of identifier with the same name: %s\n", Trees_Name(ident));
+ YYABORT;
+ }
+ curr = Trees_Right(curr);
+ } while (curr != NULL);
+
+ $$ = $2;
+ }
+ ;
+
+ParameterKindOpt:
+ VAR
+ {
+ $$ = TREES_VAR_PARAM_KIND;
+ }
+ | /*empty*/
+ {
+ $$ = TREES_VALUE_PARAM_KIND;
+ }
+ ;
+
+IdentRep:
+ IDENT
+ {
+ $$ = Trees_NewNode(TREES_IDENT_LIST, Trees_NewIdent($1), NULL);
+ }
+ | IdentRep ',' IDENT
+ {
+ $$ = Trees_NewNode(TREES_IDENT_LIST, Trees_NewIdent($3), $1);
+ }
+ ;
+
+FormalType:
+ OpenArrayOpt qualident
+ {
+ $$ = ResolvedType($2, 0);
+ if ($$ != NULL) {
+ if ($1) {
+ $$ = Types_NewArray(NULL, $$);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared identifier: %s\n", Trees_Name($2));
+ exit(EXIT_FAILURE);
+ }
+ }
+ ;
+
+OpenArrayOpt:
+ ARRAY OF
+ {
+ $$ = 1;
+ }
+ | /*empty*/
+ {
+ $$ = 0;
+ }
+ ;
+
+
+/*MODULE RULES*/
+
+module:
+ ModuleHeading ';' ImportListOpt DeclarationSequence ModuleStatements END IDENT '.'
+ {
+ static char symfilePath[PATH_MAX + 1];
+
+ if (strcmp($7, inputModuleName) == 0) {
+ Generate_ModuleEnd();
+ Generate_Close();
+
+ sprintf(symfilePath, ".obnc/%s.sym", inputModuleName);
+ if (parseMode == OBERON_ENTRY_POINT_MODE) {
+ if (Files_Exists(symfilePath)) {
+ Files_Remove(symfilePath);
+ }
+ } else {
+ ExportSymbolTable(symfilePath);
+ }
+ YYACCEPT;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "expected identifier %s\n", inputModuleName);
+ YYABORT;
+ }
+ }
+ ;
+
+
+ModuleHeading:
+ MODULE IDENT
+ {
+ if (strcmp($2, inputModuleName) == 0) {
+ if (parseMode != OBERON_IMPORT_LIST_MODE) {
+ Generate_ModuleHeading();
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "module name does not match filename: %s\n", $2);
+ YYABORT;
+ }
+ }
+ ;
+
+ImportListOpt:
+ ImportList
+ {
+ if (parseMode == OBERON_IMPORT_LIST_MODE) {
+ YYACCEPT;
+ }
+ }
+ | /*empty*/
+ {
+ if (parseMode == OBERON_IMPORT_LIST_MODE) {
+ YYACCEPT;
+ }
+ }
+ ;
+
+ImportList:
+ IMPORT ImportRep ';'
+ {
+ static char impfilePath[PATH_MAX + 1];
+ Trees_Node moduleAndDirPath, module, p;
+ FILE *impFile;
+ const char *name;
+
+ Trees_ReverseList(&$2); /*correct order*/
+ if (parseMode == OBERON_IMPORT_LIST_MODE) {
+ while ($2 != NULL) {
+ module = Trees_Left($2);
+ puts(Trees_Name(module));
+ $2 = Trees_Right($2);
+ }
+ } else {
+ sprintf(impfilePath, ".obnc/%s.imp", inputModuleName);
+ if (parseMode == OBERON_ENTRY_POINT_MODE) {
+ if (Files_Exists(impfilePath)) {
+ Files_Remove(impfilePath);
+ }
+ } else {
+ impFile = Files_New(impfilePath);
+ p = $2;
+ do {
+ moduleAndDirPath = Trees_Left(p);
+ module = Trees_Left(moduleAndDirPath);
+ name = Trees_UnaliasedName(module);
+ fprintf(impFile, "%s\n", name);
+ p = Trees_Right(p);
+ } while (p != NULL);
+ Files_Close(impFile);
+ }
+ Generate_ImportList($2);
+ }
+ }
+ ;
+
+ImportRep:
+ import
+ {
+ $$ = Trees_NewNode(TREES_NOSYM, $1, NULL);
+ }
+ | ImportRep ',' import
+ {
+ $$ = Trees_NewNode(TREES_NOSYM, $3, $1);
+ }
+ ;
+
+import:
+ IDENT BecomesIdentOpt
+ {
+ static Maps_Map importedModules = NULL;
+ static char symbolFileDir[PATH_MAX + 1];
+ static char symbolFileName[PATH_MAX + 1];
+ static char moduleDirPath[PATH_MAX + 1];
+ const char *module, *qualifier;
+ Trees_Node qualifierSym, moduleIdent;
+
+ if (importedModules == NULL) {
+ importedModules = Maps_New();
+ }
+ if ($2 != NULL) {
+ module = $2;
+ qualifier = $1;
+ } else {
+ module = $1;
+ qualifier = $1;
+ }
+ $$ = NULL;
+ if (strcmp(module, inputModuleName) != 0) {
+ if (! Maps_HasKey(module, importedModules)) {
+ Maps_Put(module, NULL, &importedModules);
+ qualifierSym = Table_At(qualifier);
+ if (qualifierSym == NULL) {
+ qualifierSym = Trees_NewIdent(qualifier);
+ if ($2 != NULL) {
+ Trees_SetUnaliasedName(module, qualifierSym);
+ }
+ Trees_SetKind(TREES_QUALIFIER_KIND, qualifierSym);
+ Table_Put(qualifierSym);
+
+ if (parseMode == OBERON_IMPORT_LIST_MODE) {
+ $$ = Trees_NewIdent(module);
+ } else {
+ Path_Get(module, moduleDirPath, LEN(moduleDirPath));
+ if (moduleDirPath[0] != '\0') {
+ /*import identifiers into the symbol table*/
+ sprintf(symbolFileDir, "%s/.obnc", moduleDirPath);
+ if (! Files_Exists(symbolFileDir)) {
+ sprintf(symbolFileDir, "%s", moduleDirPath);
+ }
+ sprintf(symbolFileName, "%s/%s.sym", symbolFileDir, module);
+ if (Files_Exists(symbolFileName)) {
+ Table_Import(symbolFileName, module, qualifier);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: symbol file not found for module %s: %s\n", module, symbolFileName);
+ YYABORT;
+ }
+
+ moduleIdent = Trees_NewIdent(module);
+ Trees_SetKind(TREES_QUALIFIER_KIND, moduleIdent);
+ $$ = Trees_NewNode(TREES_NOSYM, moduleIdent, Trees_NewString(moduleDirPath));
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: imported module not found: %s\n", module);
+ YYABORT;
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: qualifier already used: %s\n", qualifier);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: module already imported: %s\n", module);
+ YYABORT;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: a module cannot import itself\n");
+ YYABORT;
+ }
+ }
+ ;
+
+BecomesIdentOpt:
+ BECOMES IDENT
+ {
+ $$ = $2;
+ }
+ | /*empty*/
+ {
+ $$ = NULL;
+ }
+ ;
+
+ModuleStatements:
+ StatementSequenceOpt
+ {
+ Generate_ModuleStatements($1);
+ }
+ ;
+
+%%
+
+static char *ModuleName(const char filename[])
+{
+ char *result;
+ int startPos, endPos, resultLen, i;
+
+ endPos = strlen(filename);
+ do {
+ endPos--;
+ } while ((endPos >= 0) && (filename[endPos] != '.'));
+ assert(endPos > 0);
+ assert(filename[endPos] == '.');
+
+ startPos = endPos - 1;
+ while ((startPos >= 0) && isalnum(filename[startPos])) {
+ startPos--;
+ }
+ if ((startPos < 0) || ! isalnum(filename[startPos])) {
+ startPos++;
+ }
+
+ resultLen = endPos - startPos;
+ NEW_ARRAY(result, resultLen);
+ for (i = 0; i < resultLen; i++) {
+ result[i] = filename[startPos + i];
+ }
+ return result;
+}
+
+
+void Oberon_Parse(const char inputFile[], int mode)
+{
+ int error;
+
+ Table_Init();
+ inputFilename = inputFile;
+ parseMode = mode;
+ inputModuleName = ModuleName(inputFile);
+
+ yyin = fopen(inputFile, "r");
+ if (yyin != NULL) {
+ if (mode != OBERON_IMPORT_LIST_MODE) {
+ Generate_Open(inputModuleName, mode == OBERON_ENTRY_POINT_MODE);
+ }
+ error = yyparse();
+ if (error) {
+ fprintf(stderr, "compilation failed\n");
+ exit(1);
+ }
+ } else {
+ fprintf(stderr, "obnc-compile: error: cannot open file: %s: %s\n", inputFile, strerror(errno));
+ exit(1);
+ }
+}
+
+
+/*NOTE: prefer Oberon_PrintContext and fprintf over yyerror since a C compiler cannot type-check the format string of yyerror*/
+
+void Oberon_PrintContext(void)
+{
+ fprintf(stderr, "obnc-compile: %s:%d: ", inputFilename, yylineno);
+}
+
+
+void yyerror(const char format[], ...)
+{
+ va_list ap;
+
+ Oberon_PrintContext();
+ va_start(ap, format);
+ vfprintf(stderr, format, ap);
+ va_end(ap);
+ fputc('\n', stderr);
+}
+
+
+/*accessor functions*/
+
+static char *QualidentName(const char qualifier[], const char ident[])
+{
+ int resultLen;
+ char *result;
+
+ resultLen = strlen(qualifier) + strlen(".") + strlen(ident) + 1;
+ NEW_ARRAY(result, resultLen);
+ sprintf(result, "%s.%s", qualifier, ident);
+ return result;
+}
+
+
+/*constant predicate functions*/
+
+static int IsBoolean(Trees_Node node)
+{
+ return (Trees_Symbol(node) == TRUE) || (Trees_Symbol(node) == FALSE);
+}
+
+
+static int IsChar(Trees_Node node)
+{
+ return Trees_Symbol(node) == TREES_CHAR_CONSTANT;
+}
+
+
+static int IsInteger(Trees_Node node)
+{
+ return Trees_Symbol(node) == INTEGER;
+}
+
+
+static int IsReal(Trees_Node node)
+{
+ return Trees_Symbol(node) == REAL;
+}
+
+
+static int IsString(Trees_Node node)
+{
+ return Trees_Symbol(node) == STRING;
+}
+
+
+static int IsSet(Trees_Node node)
+{
+ return Trees_Symbol(node) == TREES_SET_CONSTANT;
+}
+
+
+/*functions for type declaration productions*/
+
+static Trees_Node ResolvedType(Trees_Node type, int isTypeDecl)
+{
+ Trees_Node result, identDef, typeStruct;
+ const char *name;
+
+ result = NULL;
+ if (Trees_Symbol(type) == IDENT) {
+ name = Trees_Name(type);
+ identDef = Table_At(name);
+ if (identDef != NULL) {
+ if (Trees_Kind(identDef) == TREES_TYPE_KIND) {
+ typeStruct = Types_Structure(identDef);
+ if (typeStruct != NULL) {
+ if (Types_Basic(Trees_Type(identDef)) && ! isTypeDecl) {
+ result = Trees_Type(identDef);
+ } else {
+ result = identDef;
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "unresolved type: %s\n", name);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "type expected: %s\n", name);
+ exit(EXIT_FAILURE);
+ }
+ }
+ } else {
+ result = type;
+ }
+ return result;
+}
+
+
+static void ResolvePointerTypes(Trees_Node baseType)
+{
+ const char *baseTypeName;
+ Trees_Node prev, curr, currPointerType, currBaseType;
+
+ assert(Trees_Symbol(baseType) == IDENT);
+ baseTypeName = Trees_Name(baseType);
+
+ prev = NULL;
+ curr = unresolvedPointerTypes;
+ while (curr != NULL) {
+ currPointerType = Trees_Left(curr);
+ currBaseType = Types_PointerBaseType(currPointerType);
+ if (strcmp(Trees_Name(currBaseType), baseTypeName) == 0) {
+ if (Types_IsRecord(baseType)) {
+ /*update pointer base type*/
+ Types_SetPointerBaseType(baseType, currPointerType);
+ /*delete current node*/
+ if (curr == unresolvedPointerTypes) {
+ unresolvedPointerTypes = Trees_Right(curr);
+ } else {
+ Trees_SetRight(Trees_Right(curr), prev);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "record type expected in declaration of pointer base type: %s\n", baseTypeName);
+ exit(EXIT_FAILURE);
+ }
+ }
+ prev = curr;
+ curr = Trees_Right(curr);
+ }
+}
+
+
+static const char *TypeString(Trees_Node type)
+{
+ const char *result = "";
+
+ assert(Types_IsType(type));
+
+ switch (Trees_Symbol(type)) {
+ case IDENT:
+ result = Trees_Name(type);
+ break;
+ case TREES_STRING_TYPE:
+ switch (Types_StringLength(type)) {
+ case 0:
+ result = "empty string";
+ break;
+ case 1:
+ result = "single-char string";
+ break;
+ default:
+ result = "multi-char string";
+ }
+ break;
+ case TREES_BOOLEAN_TYPE:
+ result = "BOOLEAN";
+ break;
+ case TREES_CHAR_TYPE:
+ result = "CHAR";
+ break;
+ case TREES_INTEGER_TYPE:
+ result = "INTEGER";
+ break;
+ case TREES_REAL_TYPE:
+ result = "REAL";
+ break;
+ case TREES_BYTE_TYPE:
+ result = "BYTE";
+ break;
+ case TREES_SET_TYPE:
+ result = "SET";
+ break;
+ case ARRAY:
+ if (Types_IsOpenArray(type)) {
+ result = "open ARRAY";
+ } else {
+ result = "anon ARRAY";
+ }
+ break;
+ case RECORD:
+ result = "anon RECORD";
+ break;
+ case POINTER:
+ result = "anon POINTER";
+ break;
+ case PROCEDURE:
+ result = "anon PROCEDURE";
+ break;
+ default:
+ assert(0);
+ }
+ return result;
+}
+
+
+/*functions for expression productions*/
+
+static int IsDesignator(Trees_Node exp)
+{
+ return Trees_Symbol(exp) == TREES_DESIGNATOR;
+}
+
+
+static void CheckIsValueExpression(Trees_Node exp)
+{
+ Trees_Node ident;
+
+ if (Trees_Symbol(exp) == TREES_DESIGNATOR) {
+ ident = Trees_Left(exp);
+ switch (Trees_Kind(ident)) {
+ case TREES_CONSTANT_KIND:
+ case TREES_FIELD_KIND:
+ case TREES_VARIABLE_KIND:
+ case TREES_PROCEDURE_KIND:
+ case TREES_VALUE_PARAM_KIND:
+ case TREES_VAR_PARAM_KIND:
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "value expected: %s\n", Trees_Name(ident));
+ exit(EXIT_FAILURE);
+ }
+ }
+}
+
+
+static Trees_Node Designator(const char identName[], Trees_Node selectorList)
+{
+ Trees_Node identSym, qualidentSym, designator, qualidentSelectorList;
+ const char *qualidentName;
+
+ /*set qualident name, symbol and selector list*/
+ qualidentSym = NULL;
+ qualidentSelectorList = NULL;
+ if ((procedureDeclarationStack != NULL)
+ && (strcmp(identName, Trees_Name(Trees_Left(procedureDeclarationStack))) == 0)) {
+ qualidentSym = Trees_Left(procedureDeclarationStack);
+ qualidentSelectorList = selectorList;
+ } else {
+ identSym = Table_At(identName);
+ if (identSym != NULL) {
+ if (Trees_Kind(identSym) == TREES_QUALIFIER_KIND) {
+ if ((selectorList != NULL) && (Trees_Symbol(selectorList) == '.')) {
+ qualidentName = QualidentName(identName, Trees_Name(Trees_Left(selectorList)));
+ qualidentSym = Table_At(qualidentName);
+ qualidentSelectorList = Trees_Right(selectorList);
+ if (qualidentSym == NULL) {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared identifier: %s\n", qualidentName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "'.' expected after qualifier: %s\n", identName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ qualidentSym = identSym;
+ qualidentSelectorList = selectorList;
+ }
+
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared identifier: %s\n", identName);
+ exit(EXIT_FAILURE);
+ }
+ }
+ assert(qualidentSym != NULL);
+
+ designator = Trees_NewNode(TREES_DESIGNATOR, qualidentSym, qualidentSelectorList);
+
+ return designator;
+}
+
+
+static Trees_Node BaseIdent(Trees_Node designator)
+{
+ assert(Trees_Symbol(designator) == TREES_DESIGNATOR);
+
+ return Trees_Left(designator);
+}
+
+
+static Trees_Node FirstSelector(Trees_Node designator)
+{
+ assert(Trees_Symbol(designator) == TREES_DESIGNATOR);
+
+ return Trees_Right(designator);
+}
+
+
+static void SetSelectorTypes(Trees_Node identType, Trees_Node designator, int *parameterListFound)
+{
+ Trees_Node currType, currTypeStruct, currSelector, prevSelector, indexExp, lengthNode, pointerNode, expList, extendedType, symbol, varField, typeField, fieldBaseType;
+ int length, index;
+ const char *fieldName;
+
+ currType = identType;
+ currSelector = FirstSelector(designator);
+ prevSelector = designator;
+ *parameterListFound = 0;
+ while ((currSelector != NULL) && ! *parameterListFound) {
+ currTypeStruct = Types_Structure(currType);
+ switch (Trees_Symbol(currSelector)) {
+ case '[':
+ if ((currTypeStruct != NULL) && (Trees_Symbol(currTypeStruct) == ARRAY)) {
+ indexExp = Trees_Left(currSelector);
+ lengthNode = Types_ArrayLength(currTypeStruct);
+ if ((lengthNode != NULL) && (Trees_Symbol(indexExp) == INTEGER)) {
+ length = Trees_Integer(lengthNode);
+ index = Trees_Integer(indexExp);
+ if ((index < 0) || (index >= length)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "invalid array index: %d not between 0 and %d\n", index, length - 1);
+ exit(EXIT_FAILURE);
+ }
+ }
+ Trees_SetType(currType, currSelector);
+ currType = Types_ElementType(currTypeStruct);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: array variable expected in element selector\n");
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case '.':
+ if (currType != NULL) {
+ switch (Trees_Symbol(currTypeStruct)) {
+ case POINTER:
+ pointerNode = Trees_NewNode('^', NULL, currSelector);
+ Trees_SetType(currType, pointerNode);
+ Trees_SetRight(pointerNode, prevSelector);
+ currType = Types_PointerBaseType(currTypeStruct);
+ /*fall through*/
+ case RECORD:
+ Trees_SetType(currType, currSelector);
+ varField = Trees_Left(currSelector);
+ fieldName = Trees_Name(varField);
+ Types_GetFieldIdent(fieldName, currType, Trees_Imported(BaseIdent(designator)), &typeField, &fieldBaseType);
+ if (typeField != NULL) {
+ if (Trees_Exported(typeField)) {
+ Trees_SetExported(varField);
+ }
+ currType = Trees_Type(typeField);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared field: %s\n", fieldName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record variable expected in field selector\n");
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: record variable expected in field selector\n");
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case '^':
+ if ((currType != NULL) && (Trees_Symbol(currTypeStruct) == POINTER)) {
+ Trees_SetType(currType, currSelector);
+ currType = Types_PointerBaseType(currTypeStruct);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: pointer variable expected in pointer dereference\n");
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case '(':
+ if (Types_IsProcedure(currTypeStruct)) {
+ *parameterListFound = 1;
+ } else if (Types_IsRecord(currTypeStruct) || Types_IsPointer(currTypeStruct)) {
+ /*type guard*/
+ expList = Trees_Left(currSelector);
+ if (Trees_Right(expList) == NULL) {
+ if ((Trees_Symbol(Trees_Left(expList)) == TREES_DESIGNATOR)
+ && (Trees_Right(Trees_Left(expList)) == NULL)) {
+ extendedType = Trees_Left(Trees_Left(expList));
+ symbol = Table_At(Trees_Name(extendedType));
+ if (symbol != NULL) {
+ if (Trees_Kind(symbol) == TREES_TYPE_KIND) {
+ if ((Types_IsRecord(currType) && Types_IsRecord(Trees_Type(symbol)))
+ || (Types_IsPointer(currType) && Types_IsPointer(Trees_Type(symbol)))) {
+ if (Types_Extends(currType, Trees_Type(symbol))) {
+ Trees_SetLeft(extendedType, currSelector);
+ Trees_SetType(extendedType, currSelector);
+ currType = extendedType;
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "extended type expected: %s\n", Trees_Name(extendedType));
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ if (Types_IsRecord(currType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "record type expected in type guard: %s\n", Trees_Name(extendedType));
+ exit(EXIT_FAILURE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "pointer type expected in type guard: %s\n", Trees_Name(extendedType));
+ exit(EXIT_FAILURE);
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "type name expected: %s\n", Trees_Name(extendedType));
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "undeclared identifier: %s\n", Trees_Name(extendedType));
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "identifier expected in type guard\n");
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "unexpected comma in type guard\n");
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "unexpected parenthesis in designator which is not a record, pointer or procedure\n");
+ exit(EXIT_FAILURE);
+ }
+ break;
+ default:
+ assert(0);
+ }
+ prevSelector = currSelector;
+ currSelector = Trees_Right(currSelector);
+ }
+
+ if (currSelector == NULL) {
+ Trees_SetType(currType, designator);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "unexpected selector after procedure call\n");
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void RemoveActualParameters(Trees_Node *designator, Trees_Node *actualParameters)
+{
+ Trees_Node currSelector;
+
+ currSelector = FirstSelector(*designator);
+ assert(currSelector != NULL);
+ if (Trees_Right(currSelector) == NULL) {
+ *actualParameters = Trees_Left(currSelector);
+ Trees_SetRight(NULL, *designator);
+ } else {
+ while (Trees_Right(Trees_Right(currSelector)) != NULL) {
+ currSelector = Trees_Right(currSelector);
+ }
+ *actualParameters = Trees_Left(Trees_Right(currSelector));
+ Trees_SetRight(NULL, currSelector);
+ }
+}
+
+
+static Trees_Node ExpressionConstValue(int relation, Trees_Node expA, Trees_Node expB)
+{
+ Trees_Node result = NULL;
+
+ switch (relation) {
+ case '=':
+ switch (Trees_Symbol(expA)) {
+ case TRUE:
+ case FALSE:
+ if (IsBoolean(expB)) {
+ result = Trees_NewLeaf((Trees_Symbol(expA) == Trees_Symbol(expB))? TRUE: FALSE);
+ }
+ break;
+ case TREES_CHAR_CONSTANT:
+ if (IsString(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) == Trees_String(expB)[0])? TRUE: FALSE);
+ } else if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) == Trees_Char(expB))? TRUE: FALSE);
+ }
+ break;
+ case INTEGER:
+ if (IsInteger(expB)) {
+ result = Trees_NewLeaf((Trees_Integer(expA) == Trees_Integer(expB))? TRUE: FALSE);
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ result = Trees_NewLeaf((Trees_Real(expA) == Trees_Real(expB))? TRUE: FALSE);
+ }
+ break;
+ case TREES_SET_CONSTANT:
+ if (IsSet(expB)) {
+ result = Trees_NewLeaf((Trees_Set(expA) == Trees_Set(expB))? TRUE: FALSE);
+ }
+ break;
+ case STRING:
+ if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_String(expA)[0] == Trees_Char(expB))? TRUE: FALSE);
+ } else if (IsString(expB)) {
+ result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) == 0)? TRUE: FALSE);
+ }
+ break;
+ }
+ break;
+ case '#':
+ switch (Trees_Symbol(expA)) {
+ case TRUE:
+ case FALSE:
+ if (IsBoolean(expB)) {
+ result = Trees_NewLeaf((Trees_Symbol(expA) != Trees_Symbol(expB))? TRUE: FALSE);
+ }
+ break;
+ case TREES_CHAR_CONSTANT:
+ if (IsString(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) != Trees_String(expB)[0])? TRUE: FALSE);
+ } else if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) != Trees_Char(expB))? TRUE: FALSE);
+ }
+ break;
+ case INTEGER:
+ if (IsInteger(expB)) {
+ result = Trees_NewLeaf((Trees_Integer(expA) != Trees_Integer(expB))? TRUE: FALSE);
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ result = Trees_NewLeaf((Trees_Real(expA) != Trees_Real(expB))? TRUE: FALSE);
+ }
+ break;
+ case TREES_SET_CONSTANT:
+ if (IsSet(expB)) {
+ result = Trees_NewLeaf((Trees_Set(expA) != Trees_Set(expB))? TRUE: FALSE);
+ }
+ break;
+ case STRING:
+ if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_String(expA)[0] != Trees_Char(expB))? TRUE: FALSE);
+ } else if (IsString(expB)) {
+ result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) != 0)? TRUE: FALSE);
+ }
+ break;
+ }
+ break;
+ case '<':
+ switch (Trees_Symbol(expA)) {
+ case TREES_CHAR_CONSTANT:
+ if (IsString(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) < Trees_String(expB)[0])? TRUE: FALSE);
+ } else if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) < Trees_Char(expB))? TRUE: FALSE);
+ }
+ break;
+ case INTEGER:
+ if (IsInteger(expB)) {
+ result = Trees_NewLeaf((Trees_Integer(expA) < Trees_Integer(expB))? TRUE: FALSE);
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ result = Trees_NewLeaf((Trees_Real(expA) < Trees_Real(expB))? TRUE: FALSE);
+ }
+ break;
+ case STRING:
+ if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_String(expA)[0] < Trees_Char(expB))? TRUE: FALSE);
+ } else if (IsString(expB)) {
+ result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) < 0)? TRUE: FALSE);
+ }
+ break;
+ }
+ break;
+ case LE:
+ switch (Trees_Symbol(expA)) {
+ case TREES_CHAR_CONSTANT:
+ if (IsString(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) <= Trees_String(expB)[0])? TRUE: FALSE);
+ } else if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) <= Trees_Char(expB))? TRUE: FALSE);
+ }
+ break;
+ case INTEGER:
+ if (IsInteger(expB)) {
+ result = Trees_NewLeaf((Trees_Integer(expA) <= Trees_Integer(expB))? TRUE: FALSE);
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ result = Trees_NewLeaf((Trees_Real(expA) <= Trees_Real(expB))? TRUE: FALSE);
+ }
+ break;
+ case STRING:
+ if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_String(expA)[0] <= Trees_Char(expB))? TRUE: FALSE);
+ } else if (IsString(expB)) {
+ result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) <= 0)? TRUE: FALSE);
+ }
+ break;
+ }
+ break;
+ case '>':
+ switch (Trees_Symbol(expA)) {
+ case TREES_CHAR_CONSTANT:
+ if (IsString(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) > Trees_String(expB)[0])? TRUE: FALSE);
+ } else if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) > Trees_Char(expB))? TRUE: FALSE);
+ }
+ break;
+ case INTEGER:
+ if (IsInteger(expB)) {
+ result = Trees_NewLeaf((Trees_Integer(expA) > Trees_Integer(expB))? TRUE: FALSE);
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ result = Trees_NewLeaf((Trees_Real(expA) > Trees_Real(expB))? TRUE: FALSE);
+ }
+ break;
+ case STRING:
+ if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_String(expA)[0] > Trees_Char(expB))? TRUE: FALSE);
+ } else if (IsString(expB)) {
+ result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) > 0)? TRUE: FALSE);
+ }
+ break;
+ }
+ break;
+ case GE:
+ switch (Trees_Symbol(expA)) {
+ case TREES_CHAR_CONSTANT:
+ if (IsString(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) >= Trees_String(expB)[0])? TRUE: FALSE);
+ } else if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_Char(expA) >= Trees_Char(expB))? TRUE: FALSE);
+ }
+ break;
+ case INTEGER:
+ if (IsInteger(expB)) {
+ result = Trees_NewLeaf((Trees_Integer(expA) >= Trees_Integer(expB))? TRUE: FALSE);
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ result = Trees_NewLeaf((Trees_Real(expA) >= Trees_Real(expB))? TRUE: FALSE);
+ }
+ break;
+ case STRING:
+ if (IsChar(expB)) {
+ result = Trees_NewLeaf((Trees_String(expA)[0] >= Trees_Char(expB))? TRUE: FALSE);
+ } else if (IsString(expB)) {
+ result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) >= 0)? TRUE: FALSE);
+ }
+ break;
+ }
+ break;
+ case IN:
+ if (IsInteger(expA)) {
+ Range_CheckSetElement(Trees_Integer(expA));
+ if (IsSet(expB)) {
+ result = Trees_NewLeaf(OBNC_IN(Trees_Integer(expA), Trees_Set(expB))? TRUE: FALSE);
+ }
+ }
+ break;
+ }
+ if (result != NULL) {
+ Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), result);
+ }
+
+ return result;
+}
+
+
+static Trees_Node SimpleExpressionConstValue(int operator, Trees_Node expA, Trees_Node expB)
+{
+ Trees_Node result = NULL;
+
+ switch (operator) {
+ case '+':
+ switch (Trees_Symbol(expA)) {
+ case INTEGER:
+ if (expB == NULL) {
+ result = expA;
+ } else if (IsInteger(expB)) {
+ Range_CheckIntSum(Trees_Integer(expA), Trees_Integer(expB));
+ result = Trees_NewInteger(Trees_Integer(expA) + Trees_Integer(expB));
+ }
+ break;
+ case REAL:
+ if (expB == NULL) {
+ result = expA;
+ } else if (IsReal(expB)) {
+ Range_CheckRealSum(Trees_Real(expA), Trees_Real(expB));
+ result = Trees_NewReal(Trees_Real(expA) + Trees_Real(expB));
+ }
+ break;
+ case TREES_SET_CONSTANT:
+ if (expB == NULL) {
+ result = expA;
+ } else if (IsSet(expB)) {
+ result = Trees_NewSet(Trees_Set(expA) | Trees_Set(expB));
+ }
+ break;
+ }
+ break;
+ case '-':
+ switch (Trees_Symbol(expA)) {
+ case INTEGER:
+ if (expB == NULL) {
+ Range_CheckIntDiff(0, Trees_Integer(expA));
+ result = Trees_NewInteger(-Trees_Integer(expA));
+ } else if (IsInteger(expB)) {
+ Range_CheckIntDiff(Trees_Integer(expA), Trees_Integer(expB));
+ result = Trees_NewInteger(Trees_Integer(expA) - Trees_Integer(expB));
+ }
+ break;
+ case REAL:
+ if (expB == NULL) {
+ Range_CheckRealDiff(0.0, Trees_Real(expA));
+ result = Trees_NewReal(-Trees_Real(expA));
+ } else if (IsReal(expB)) {
+ Range_CheckRealDiff(Trees_Real(expA), Trees_Real(expB));
+ result = Trees_NewReal(Trees_Real(expA) - Trees_Real(expB));
+ }
+ break;
+ case TREES_SET_CONSTANT:
+ if (expB == NULL) {
+ result = Trees_NewSet(~Trees_Set(expA));
+ } else if (IsSet(expB)) {
+ result = Trees_NewSet(Trees_Set(expA) & ~Trees_Set(expB));
+ }
+ break;
+ }
+ break;
+ case OR:
+ if (IsBoolean(expA) && IsBoolean(expB)) {
+ result = (Trees_Symbol(expA) == TRUE)? expA: expB;
+ }
+ break;
+ }
+
+ return result;
+}
+
+
+static Trees_Node TermConstValue(int operator, Trees_Node expA, Trees_Node expB)
+{
+ Trees_Node result = NULL;
+
+ switch (operator) {
+ case '*':
+ switch (Trees_Symbol(expA)) {
+ case INTEGER:
+ if (IsInteger(expB)) {
+ Range_CheckIntProd(Trees_Integer(expA), Trees_Integer(expB));
+ result = Trees_NewInteger(Trees_Integer(expA) * Trees_Integer(expB));
+ }
+ break;
+ case REAL:
+ if (IsReal(expB)) {
+ Range_CheckRealProd(Trees_Real(expA), Trees_Real(expB));
+ result = Trees_NewReal(Trees_Real(expA) * Trees_Real(expB));
+ }
+ break;
+ case TREES_SET_CONSTANT:
+ if (IsSet(expB)) {
+ result = Trees_NewSet(Trees_Set(expA) & Trees_Set(expB));
+ }
+ break;
+ }
+ break;
+ case '/':
+ switch (Trees_Symbol(expA)) {
+ case REAL:
+ if (IsReal(expA) && IsReal(expB)) {
+ if (Trees_Real(expB) != 0) {
+ result = Trees_NewReal(Trees_Real(expA) / Trees_Real(expB));
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: division by zero\n");
+ }
+ }
+ break;
+ case TREES_SET_CONSTANT:
+ if (IsSet(expB)) {
+ result = Trees_NewSet(Trees_Set(expA) ^ Trees_Set(expB));
+ }
+ break;
+ }
+ break;
+ case DIV:
+ if (IsInteger(expA) && IsInteger(expB)) {
+ if (Trees_Integer(expB) > 0) {
+ result = Trees_NewInteger(OBNC_DIV(Trees_Integer(expA), Trees_Integer(expB)));
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "positive divisor expected in DIV expression: %" OBNC_INT_MOD "d\n", Trees_Integer(expB));
+ exit(EXIT_FAILURE);
+ }
+ }
+ break;
+ case MOD:
+ if (IsInteger(expA) && IsInteger(expB)) {
+ if (Trees_Integer(expB) > 0) {
+ result = Trees_NewInteger(OBNC_MOD(Trees_Integer(expA), Trees_Integer(expB)));
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "positive divisor expected in MOD expression: %" OBNC_INT_MOD "d\n", Trees_Integer(expB));
+ exit(EXIT_FAILURE);
+ }
+ }
+ break;
+ case '&':
+ if (IsBoolean(expA) && IsBoolean(expB)) {
+ if (Trees_Symbol(expA) == TRUE) {
+ result = expB;
+ } else {
+ result = expA;
+ }
+ }
+ break;
+ }
+
+ return result;
+}
+
+
+static const char *DesignatorString(Trees_Node designator)
+{
+ const char *baseName;
+ char *result;
+
+ assert(IsDesignator(designator));
+
+ baseName = Trees_Name(BaseIdent(designator));
+ NEW_ARRAY(result, strlen(baseName) + strlen("...") + 1);
+ if (FirstSelector(designator) != NULL) {
+ sprintf(result, "%s...", baseName);
+ } else {
+ sprintf(result, "%s", baseName);
+ }
+ return result;
+}
+
+
+static const char *OperatorString(int operator)
+{
+ const char *result = "";
+
+ switch (operator) {
+ case '+':
+ result = "+";
+ break;
+ case '-':
+ result = "-";
+ break;
+ case '*':
+ result = "*";
+ break;
+ case '/':
+ result = "/";
+ break;
+ case DIV:
+ result = "DIV";
+ break;
+ case MOD:
+ result = "MOD";
+ break;
+ case OR:
+ result = "OR";
+ break;
+ case '&':
+ result = "&";
+ break;
+ case '~':
+ result = "~";
+ break;
+ case '=':
+ result = "=";
+ break;
+ case '#':
+ result = "#";
+ break;
+ case '<':
+ result = "<";
+ break;
+ case LE:
+ result = "<=";
+ break;
+ case '>':
+ result = ">";
+ break;
+ case GE:
+ result = ">=";
+ break;
+ case IN:
+ result = "IN";
+ break;
+ case IS:
+ result = "IS";
+ break;
+ default:
+ assert(0);
+ }
+ return result;
+}
+
+
+/*functions for statement productions*/
+
+static int Writable(Trees_Node designator)
+{
+ Trees_Node ident, type;
+ int kind, result;
+
+ assert(IsDesignator(designator));
+
+ ident = BaseIdent(designator);
+ kind = Trees_Kind(ident);
+ type = Trees_Type(ident);
+ result = ((kind == TREES_VARIABLE_KIND) && ! Trees_Imported(ident))
+ || (kind == TREES_VAR_PARAM_KIND)
+ || ((kind == TREES_VALUE_PARAM_KIND) && ! Types_IsArray(type) && ! Types_IsRecord(type));
+ return result;
+}
+
+
+static char *AssignmentErrorContext(int context, int paramPos)
+{
+ char *result;
+
+ NEW_ARRAY(result, 64);
+ switch (context) {
+ case ASSIGNMENT_CONTEXT:
+ strcpy(result, "assignment");
+ break;
+ case PARAM_SUBST_CONTEXT:
+ assert(paramPos >= 0);
+ sprintf(result, "substitution of parameter %d", paramPos + 1);
+ break;
+ case PROC_RESULT_CONTEXT:
+ strcpy(result, "return clause");
+ break;
+ default:
+ assert(0);
+ }
+ return result;
+}
+
+
+static void ValidateAssignment(Trees_Node expression, Trees_Node targetType, int context, int paramPos)
+{
+ const char *errorContext;
+
+ assert(expression != NULL);
+ assert(targetType != NULL);
+ assert(context >= 0);
+ assert(paramPos >= 0);
+ if (Types_AssignmentCompatible(expression, targetType)) {
+ if (Types_IsByte(targetType) && IsInteger(expression)) {
+ Range_CheckByte(Trees_Integer(expression));
+ }
+ } else {
+ errorContext = AssignmentErrorContext(context, paramPos);
+ if (IsString(expression) && Types_IsCharacterArray(targetType)
+ && !Types_IsOpenArray(targetType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "destination array to small in %s\n", errorContext);
+ exit(EXIT_FAILURE);
+ } else if (Types_IsPredeclaredProcedure(Trees_Type(expression))
+ && Types_IsProcedure(targetType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "non-predeclared procedure expected in %s\n", errorContext);
+ exit(EXIT_FAILURE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible types in %s: %s -> %s\n",
+ errorContext, TypeString(Trees_Type(expression)), TypeString(targetType));
+ exit(EXIT_FAILURE);
+ }
+ }
+}
+
+
+static void ValidateActualParameter(Trees_Node actualParam, Trees_Node formalParam, int paramPos, Trees_Node procDesignator)
+{
+ Trees_Node formalType, actualType;
+
+ formalType = Trees_Type(formalParam);
+ actualType = Trees_Type(actualParam);
+
+ if ((Trees_Kind(formalParam) == TREES_VALUE_PARAM_KIND)
+ || (IsDesignator(actualParam) && Writable(actualParam))) {
+ if (Types_IsOpenArray(formalType)) {
+ if (! Types_ArrayCompatible(actualType, formalType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "array compatible types expected in substitution of parameter %d in %s: %s -> %s\n", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType));
+ exit(EXIT_FAILURE);
+ }
+ } else if (Trees_Kind(formalParam) == TREES_VALUE_PARAM_KIND) {
+ if (! Types_AssignmentCompatible(actualParam, formalType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "assignment compatible types expected in substitution of parameter %d in %s: %s -> %s\n", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType));
+ exit(EXIT_FAILURE);
+ }
+ } else if (Trees_Kind(formalParam) == TREES_VAR_PARAM_KIND) {
+ if (Types_IsRecord(formalType)) {
+ if (Types_IsRecord(actualType)) {
+ if (! Types_Extends(formalType, actualType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "incompatible record types in substitution of parameter %d in %s: %s -> %s\n", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType));
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "record expected in substitution of parameter %d in %s: %s -> %s\n", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType));
+ }
+ } else {
+ if (! Types_Same(actualType, formalType)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "same types expected in substitution of parameter %d in %s: %s -> %s\n", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType));
+ exit(EXIT_FAILURE);
+ }
+ }
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "writable variable expected in substitution of parameter %d in %s\n",
+ paramPos + 1, DesignatorString(procDesignator));
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void ValidateProcedureCall(Trees_Node expList, Trees_Node fpList, Trees_Node procDesignator)
+{
+ Trees_Node exp, formalParam, fpType;
+ int pos;
+
+ pos = 0;
+ while ((expList != NULL) && (fpList != NULL)) {
+ exp = Trees_Left(expList);
+ CheckIsValueExpression(exp);
+ formalParam = Trees_Left(fpList);
+ fpType = Trees_Type(formalParam);
+ ValidateActualParameter(exp, formalParam, pos, procDesignator);
+
+ if (Types_IsChar(fpType) && (Trees_Symbol(exp) == STRING)) {
+ Trees_SetLeft(Trees_NewChar(Trees_String(exp)[0]), expList);
+ }
+ expList = Trees_Right(expList);
+ fpList = Trees_Right(fpList);
+ pos++;
+ }
+ if ((expList == NULL) && (fpList != NULL)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "too few actual parameters in procedure call: %s\n", DesignatorString(procDesignator));
+ exit(EXIT_FAILURE);
+ } else if ((expList != NULL) && (fpList == NULL)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "too many actual parameters in procedure call: %s\n", DesignatorString(procDesignator));
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static Trees_Node PredeclaredProcedureAST(const char procName[], Trees_Node expList, int isFunctionCall)
+{
+ static const struct { const char *name; int symbol; } symbols[] = {
+ {"ABS", TREES_ABS_PROC},
+ {"ASR", TREES_ASR_PROC},
+ {"ASSERT", TREES_ASSERT_PROC},
+ {"CHR", TREES_CHR_PROC},
+ {"DEC", TREES_DEC_PROC},
+ {"EXCL", TREES_EXCL_PROC},
+ {"FLOOR", TREES_FLOOR_PROC},
+ {"FLT", TREES_FLT_PROC},
+ {"INC", TREES_INC_PROC},
+ {"INCL", TREES_INCL_PROC},
+ {"LEN", TREES_LEN_PROC},
+ {"LSL", TREES_LSL_PROC},
+ {"NEW", TREES_NEW_PROC},
+ {"ODD", TREES_ODD_PROC},
+ {"ORD", TREES_ORD_PROC},
+ {"PACK", TREES_PACK_PROC},
+ {"ROR", TREES_ROR_PROC},
+ {"UNPK", TREES_UNPK_PROC}};
+
+ int paramCount, pos, symbol;
+ Trees_Node curr, resultType, result;
+ Trees_Node param[2], paramTypes[2];
+
+ /*set actual parameters*/
+ paramCount = 0;
+ curr = expList;
+ while ((paramCount < LEN(param)) && (curr != NULL)) {
+ param[paramCount] = Trees_Left(curr);
+ paramTypes[paramCount] = Trees_Type(Trees_Left(curr));
+ paramCount++;
+ curr = Trees_Right(curr);
+ }
+
+ /*find procedure symbol*/
+ pos = 0;
+ while ((pos < LEN(symbols)) && (strcmp(symbols[pos].name, procName) != 0)) {
+ pos++;
+ }
+ assert(pos < LEN(symbols));
+ symbol = symbols[pos].symbol;
+
+ /*validate parameters and build syntax tree*/
+ result = NULL;
+ resultType = NULL;
+ switch (symbol) {
+ case TREES_ABS_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ switch (Trees_Symbol(Types_Structure(paramTypes[0]))) {
+ case TREES_INTEGER_TYPE:
+ if (IsInteger(param[0])) {
+ result = Trees_NewInteger(OBNC_ABS_INT(Trees_Integer(param[0])));
+ }
+ break;
+ case TREES_REAL_TYPE:
+ if (IsReal(param[0])) {
+ result = Trees_NewReal(OBNC_ABS_FLT(Trees_Real(param[0])));
+ }
+ break;
+ case TREES_BYTE_TYPE:
+ /*do nothing*/
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "numeric parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ resultType = paramTypes[0];
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_ODD_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ if (Types_IsInteger(paramTypes[0])) {
+ if (IsInteger(param[0])) {
+ result = Trees_NewInteger(OBNC_ODD(Trees_Integer(param[0])));
+ }
+ resultType = Trees_NewLeaf(TREES_BOOLEAN_TYPE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_LEN_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ if (Types_IsArray(paramTypes[0])) {
+ if (! Types_IsOpenArray(paramTypes[0])) {
+ result = Types_ArrayLength(paramTypes[0]);
+ }
+ resultType = Trees_NewLeaf(TREES_INTEGER_TYPE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "array parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_LSL_PROC: /*fall through*/
+ case TREES_ASR_PROC: /*fall through*/
+ case TREES_ROR_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 2) {
+ if (Types_IsInteger(paramTypes[0])) {
+ if (Types_IsInteger(paramTypes[1])) {
+ if (IsInteger(param[1])) {
+ switch (symbol) {
+ case TREES_LSL_PROC:
+ Range_CheckLSL(Trees_Integer(param[1]));
+ break;
+ case TREES_ASR_PROC:
+ Range_CheckASR(Trees_Integer(param[1]));
+ break;
+ case TREES_ROR_PROC:
+ Range_CheckROR(Trees_Integer(param[1]));
+ break;
+ default:
+ assert(0);
+ }
+ }
+ if (IsInteger(param[0]) && IsInteger(param[1])) {
+ switch (symbol) {
+ case TREES_LSL_PROC:
+ result = Trees_NewInteger(OBNC_LSL(Trees_Integer(param[0]), Trees_Integer(param[1])));
+ break;
+ case TREES_ASR_PROC:
+ result = Trees_NewInteger(OBNC_ASR(Trees_Integer(param[0]), Trees_Integer(param[1])));
+ break;
+ case TREES_ROR_PROC:
+ result = Trees_NewInteger(OBNC_ROR(Trees_Integer(param[0]), Trees_Integer(param[1])));
+ break;
+ default:
+ assert(0);
+ }
+ }
+ resultType = paramTypes[0];
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer expression expected as second parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer expression expected as first parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "two parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_FLOOR_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ if (Types_IsReal(paramTypes[0])) {
+ if (IsReal(param[0])) {
+ OBNC_LONGR double x = Trees_Real(param[0]);
+ Range_CheckFLOOR(x);
+ result = Trees_NewInteger(OBNC_FLOOR(x));
+ }
+ resultType = Trees_NewLeaf(TREES_INTEGER_TYPE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "real-valued parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_FLT_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ if (Types_IsInteger(paramTypes[0])) {
+ if (IsInteger(param[0])) {
+ result = Trees_NewReal(OBNC_FLT(Trees_Integer(param[0])));
+ }
+ resultType = Trees_NewLeaf(TREES_REAL_TYPE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_ORD_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ switch (Trees_Symbol(Types_Structure(paramTypes[0]))) {
+ case TREES_CHAR_TYPE:
+ /*do nothing*/
+ break;
+ case TREES_STRING_TYPE:
+ if (Types_StringLength(paramTypes[0]) <= 1) {
+ result = Trees_NewInteger(Trees_String(param[0])[0]);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "single-character string parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_BOOLEAN_TYPE:
+ if (Trees_Symbol(param[0]) == TRUE) {
+ result = Trees_NewInteger(1);
+ } else if (Trees_Symbol(param[0]) == FALSE) {
+ result = Trees_NewInteger(0);
+ }
+ break;
+ case TREES_SET_TYPE:
+ if (IsSet(param[0])) {
+ result = Trees_NewInteger(Trees_Set(param[0]));
+ }
+ break;
+ default:
+ Oberon_PrintContext();
+ fprintf(stderr, "character parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ resultType = Trees_NewLeaf(TREES_INTEGER_TYPE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_CHR_PROC:
+ if (isFunctionCall) {
+ if (paramCount == 1) {
+ if (Types_IsInteger(paramTypes[0])) {
+ if (IsInteger(param[0])) {
+ int i = Trees_Integer(param[0]);
+ Range_CheckCHR(i);
+ result = Trees_NewChar(OBNC_CHR(i));
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ resultType = Trees_NewLeaf(TREES_CHAR_TYPE);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_INC_PROC: /*fall through*/
+ case TREES_DEC_PROC:
+ if (! isFunctionCall) {
+ if ((paramCount == 1) || (paramCount == 2)) {
+ if (IsDesignator(param[0])) {
+ if (Types_IsInteger(paramTypes[0])) {
+ if (Writable(param[0])) {
+ if ((paramCount == 2) && ! Types_IsInteger(paramTypes[1])) {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer expression expected as second parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "writable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "variable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one or two parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_INCL_PROC: /*fall through*/
+ case TREES_EXCL_PROC:
+ if (! isFunctionCall) {
+ if (paramCount == 2) {
+ if (IsDesignator(param[0])) {
+ if (Types_IsSet(paramTypes[0])) {
+ if (Writable(param[0])) {
+ if (IsInteger(param[1])) {
+ Range_CheckSetElement(Trees_Integer(param[1]));
+ } else if (! Types_IsInteger(paramTypes[1])) {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer expression expected as second parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "writable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "set expression expected as first parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "variable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "two parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_ASSERT_PROC:
+ if (! isFunctionCall) {
+ if (paramCount == 1) {
+ if (Types_IsBoolean(paramTypes[0])) {
+ result = param[0];
+ if (Trees_Symbol(param[0]) == TRUE) {
+ result = Trees_NewLeaf(TRUE);
+ } else if (Trees_Symbol(param[0]) == FALSE) {
+ result = Trees_NewLeaf(FALSE);
+ }
+ result = Trees_NewNode(
+ TREES_ASSERT_PROC,
+ result,
+ Trees_NewNode(TREES_FILE_POSITION,
+ Trees_NewString(inputFilename),
+ Trees_NewInteger(yylineno)));
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "boolean parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_NEW_PROC:
+ if (! isFunctionCall) {
+ if (paramCount == 1) {
+ if (IsDesignator(param[0])) {
+ if (Trees_Symbol(Types_Structure(paramTypes[0])) == POINTER) {
+ if (! Writable(param[0])) {
+ Oberon_PrintContext();
+ fprintf(stderr, "writable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "pointer parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "variable expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "one parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_PACK_PROC:
+ if (! isFunctionCall) {
+ if (paramCount == 2) {
+ if (IsDesignator(param[0])) {
+ if (Types_IsReal(paramTypes[0])) {
+ if (Writable(param[0])) {
+ if (! Types_IsInteger(paramTypes[1])) {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer expression expected as second parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "writable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "real-valued expression expected as first parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "variable parameter expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "two parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ case TREES_UNPK_PROC:
+ if (! isFunctionCall) {
+ if (paramCount == 2) {
+ if (IsDesignator(param[0]) && IsDesignator(param[1])) {
+ if (Types_IsReal(paramTypes[0])) {
+ if (Writable(param[0])) {
+ if (Types_IsInteger(paramTypes[1])) {
+ if (! Writable(param[1])) {
+ Oberon_PrintContext();
+ fprintf(stderr, "second parameter is read-only: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "integer expression expected as second parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "first parameter is read-only: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "real-valued expression expected as first parameter: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "two variable parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "two parameters expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", procName);
+ exit(EXIT_FAILURE);
+ }
+ break;
+ default:
+ assert(0);
+ }
+
+ if (result == NULL) {
+ if (paramCount == 1) {
+ result = Trees_NewNode(symbol, param[0], NULL);
+ } else {
+ result = Trees_NewNode(symbol, param[0], param[1]);
+ }
+ }
+ Trees_SetType(resultType, result);
+
+ return result;
+}
+
+
+static void HandleProcedureCall(Trees_Node designator, Trees_Node expList, int isFunctionCall, Trees_Node *ast)
+{
+ Trees_Node ident, designatorTypeStruct, fpList, resultType;
+
+ ident = BaseIdent(designator);
+ if (Types_IsPredeclaredProcedure(Trees_Type(ident))) {
+ *ast = PredeclaredProcedureAST(Trees_Name(ident), expList, isFunctionCall);
+ if (*ast == NULL) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: procedure expected\n");
+ exit(EXIT_FAILURE);
+ }
+ } else {
+ /*handle non-predeclared procedure*/
+ designatorTypeStruct = Types_Structure(Trees_Type(designator));
+ if (Types_IsProcedure(designatorTypeStruct)) {
+ fpList =Types_Parameters(designatorTypeStruct);
+ resultType = Types_ResultType(designatorTypeStruct);
+ ValidateProcedureCall(expList, fpList, designator);
+ *ast = Trees_NewNode(TREES_PROCEDURE_CALL, designator, expList);
+ if (isFunctionCall) {
+ if (resultType != NULL) {
+ Trees_SetType(resultType, *ast);
+ } else {
+ Oberon_PrintContext();
+ fprintf(stderr, "function procedure expected: %s\n", Trees_Name(ident));
+ exit(EXIT_FAILURE);
+ }
+ } else if (resultType != NULL) {
+ Oberon_PrintContext();
+ fprintf(stderr, "proper procedure expected: %s\n", Trees_Name(ident));
+ exit(EXIT_FAILURE);
+ }
+ }
+ }
+ assert(*ast != NULL);
+}
+
+
+static void CheckIntegerLabelDisjointness(Trees_Node rangeA, Trees_Node rangeB)
+{
+ int aMin, aMax, bMin, bMax;
+
+ if (Trees_Symbol(rangeA) == DOTDOT) {
+ aMin = Trees_Integer(Trees_Left(rangeA));
+ aMax = Trees_Integer(Trees_Right(rangeA));
+ } else {
+ aMin = Trees_Integer(rangeA);
+ aMax = Trees_Integer(rangeA);
+ }
+ if (Trees_Symbol(rangeB) == DOTDOT) {
+ bMin = Trees_Integer(Trees_Left(rangeB));
+ bMax = Trees_Integer(Trees_Right(rangeB));
+ } else {
+ bMin = Trees_Integer(rangeB);
+ bMax = Trees_Integer(rangeB);
+ }
+
+ if ((aMin >= bMin) && (aMin <= bMax)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "case label defined twice: %d\n", aMin);
+ exit(EXIT_FAILURE);
+ } else if ((bMin >= aMin) && (bMin <= aMax)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "case label defined twice: %d\n", bMin);
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void CheckCharLabelDisjointness(Trees_Node rangeA, Trees_Node rangeB)
+{
+ char aMin, aMax, bMin, bMax;
+
+ if (Trees_Symbol(rangeA) == DOTDOT) {
+ aMin = Trees_Char(Trees_Left(rangeA));
+ aMax = Trees_Char(Trees_Right(rangeA));
+ } else {
+ aMin = Trees_Char(rangeA);
+ aMax = Trees_Char(rangeA);
+ }
+ if (Trees_Symbol(rangeB) == DOTDOT) {
+ bMin = Trees_Char(Trees_Left(rangeB));
+ bMax = Trees_Char(Trees_Right(rangeB));
+ } else {
+ bMin = Trees_Char(rangeB);
+ bMax = Trees_Char(rangeB);
+ }
+
+ if ((aMin >= bMin) && (aMin <= bMax)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "case label defined twice: %c\n", aMin);
+ exit(EXIT_FAILURE);
+ } else if ((bMin >= aMin) && (bMin <= aMax)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "case label defined twice: %c\n", bMin);
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void CheckCaseLabelUniqueness(Trees_Node newLabelRange)
+{
+ int labelSymbol;
+ Trees_Node labelList, definedLabelRange;
+
+ if (Trees_Symbol(newLabelRange) == DOTDOT) {
+ labelSymbol = Trees_Symbol(Trees_Left(newLabelRange));
+ } else {
+ labelSymbol = Trees_Symbol(newLabelRange);
+ }
+
+ labelList = currentlyDefinedCaseLabels;
+ while (labelList != NULL) {
+ definedLabelRange = Trees_Left(labelList);
+ switch (labelSymbol) {
+ case INTEGER:
+ CheckIntegerLabelDisjointness(definedLabelRange, newLabelRange);
+ break;
+ case TREES_CHAR_CONSTANT:
+ CheckCharLabelDisjointness(definedLabelRange, newLabelRange);
+ break;
+ case IDENT:
+ if (Types_Same(definedLabelRange, newLabelRange)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "type label defined twice: %s\n", Trees_Name(newLabelRange));
+ exit(EXIT_FAILURE);
+ }
+ break;
+ default:
+ assert(0);
+ }
+ labelList = Trees_Right(labelList);
+ }
+}
+
+
+/*functions for module productions*/
+
+static void ExportSymbolTable(const char symfilePath[])
+{
+ static char tempSymfilePath[PATH_MAX + 1];
+
+ if (! Files_Exists(".obnc")) {
+ Files_CreateDir(".obnc");
+ }
+ sprintf(tempSymfilePath, ".obnc/%s.sym.%d", inputModuleName, getpid());
+ Table_Export(tempSymfilePath);
+ Files_Move(tempSymfilePath, symfilePath);
+}
diff --git a/src/Path.c b/src/Path.c
new file mode 100644
index 0000000..8e6dc36
--- /dev/null
+++ b/src/Path.c
@@ -0,0 +1,144 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Path.h"
+#include "Config.h"
+#include "Files.h"
+#include "Util.h"
+#include
+#include
+#include
+#include
+#include
+#include
+
+static void Append(const char extra[], char s[], int sLen)
+{
+ int sStrLen, extraStrLen;
+
+ sStrLen = strlen(s);
+ extraStrLen = strlen(extra);
+ if (sStrLen + extraStrLen < sLen) {
+ strcpy(s + sStrLen, extra);
+ } else {
+ fprintf(stderr, "target array too short for concatenation (length %d): %s\n", sLen, s);
+ fprintf(stderr, "source string: \"%s\"\n", extra);
+ exit(EXIT_FAILURE);
+ }
+}
+
+
+static void GetModulePrefix(const char module[], char prefix[], int prefixLen)
+{
+ int i;
+
+ i = 0;
+ while (((module[i] >= 'a') && (module[i] <= 'z')) || ((module[i] >= '0') && (module[i] <= '9'))) {
+ assert(i < prefixLen);
+ prefix[i] = module[i];
+ i++;
+ }
+ if ((module[i] >= 'A') && (module[i] <= 'Z')) {
+ prefix[i] = '\0';
+ } else {
+ prefix[0] = '\0';
+ }
+}
+
+
+static void HandlePath(const char module[], int level, char dirPath[], int dirPathLen, int *found)
+{
+ char symfilePath[PATH_MAX + 1], modulePrefix[FILENAME_MAX + 1];
+
+ *found = 0;
+ symfilePath[0] = '\0';
+ Append(dirPath, symfilePath, LEN(symfilePath));
+ Append("/.obnc/", symfilePath, LEN(symfilePath));
+ Append(module, symfilePath, LEN(symfilePath));
+ Append(".sym", symfilePath, LEN(symfilePath));
+ *found = Files_Exists(symfilePath);
+ if (! *found) {
+ symfilePath[0] = '\0';
+ Append(dirPath, symfilePath, LEN(symfilePath));
+ Append("/", symfilePath, LEN(symfilePath));
+ Append(module, symfilePath, LEN(symfilePath));
+ Append(".sym", symfilePath, LEN(symfilePath));
+ *found = Files_Exists(symfilePath);
+ if (! *found) {
+ symfilePath[0] = '\0';
+ Append(dirPath, symfilePath, LEN(symfilePath));
+ Append("/", symfilePath, LEN(symfilePath));
+ Append(module, symfilePath, LEN(symfilePath));
+ Append(".obn", symfilePath, LEN(symfilePath));
+ *found = Files_Exists(symfilePath);
+ if (! *found & (level == 0)) {
+ GetModulePrefix(module, modulePrefix, LEN(modulePrefix));
+ Append("/", dirPath, dirPathLen);
+ Append(modulePrefix, dirPath, dirPathLen);
+ HandlePath(module, 1, dirPath, dirPathLen, found);
+ }
+ }
+ }
+}
+
+
+void Path_Get(const char module[], char dirPath[], int dirPathLen)
+{
+ const char *impPaths;
+ int found, pathStart, pathEnd;
+
+ assert(module != NULL);
+ assert(dirPath != NULL);
+ assert(dirPathLen > 0);
+
+ dirPath[0] = '\0';
+ Append(".", dirPath, dirPathLen);
+
+ /*search current directory*/
+ HandlePath(module, 0, dirPath, dirPathLen, &found);
+ if (! found) {
+ /*search OBNC_IMPORT_PATH*/
+ impPaths = getenv("OBNC_IMPORT_PATH");
+ if (impPaths != NULL) {
+ pathStart = 0;
+ do {
+ pathEnd = pathStart;
+ while ((impPaths[pathEnd] != '\0') && (impPaths[pathEnd] != ':')) {
+ pathEnd++;
+ }
+ if (pathEnd > pathStart) {
+ memcpy(dirPath, impPaths + pathStart, pathEnd - pathStart);
+ dirPath[pathEnd - pathStart] = '\0';
+ HandlePath(module, 0, dirPath, dirPathLen, &found);
+ }
+ pathStart = pathEnd + 1;
+ } while (! found && (impPaths[pathEnd] != '\0'));
+ }
+ if (! found) {
+ /*search install path*/
+ dirPath[0] = '\0';
+ Append(Config_Prefix(), dirPath, dirPathLen);
+ Append("/", dirPath, dirPathLen);
+ Append(Config_LibDir(), dirPath, dirPathLen);
+ Append("/obnc", dirPath, dirPathLen);
+ HandlePath(module, 0, dirPath, dirPathLen, &found);
+ if (! found) {
+ dirPath[0] = '\0';
+ }
+ }
+ }
+}
diff --git a/src/Path.h b/src/Path.h
new file mode 100644
index 0000000..9ac8784
--- /dev/null
+++ b/src/Path.h
@@ -0,0 +1,23 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef PATH_H
+#define PATH_H
+
+void Path_Get(const char module[], char dirPath[], int dirPathLen);
+
+#endif
diff --git a/src/Range.c b/src/Range.c
new file mode 100644
index 0000000..ec22d5a
--- /dev/null
+++ b/src/Range.c
@@ -0,0 +1,216 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Range.h"
+#include "Oberon.h"
+#include
+#include
+#include
+
+#ifdef OBNC_CONFIG_USE_LONG_INT
+ #define INTEGER_MIN LONG_MIN
+ #define INTEGER_MAX LONG_MAX
+#else
+ #define INTEGER_MIN INT_MIN
+ #define INTEGER_MAX INT_MAX
+#endif
+
+#ifdef OBNC_CONFIG_USE_LONG_REAL
+ #define REAL_MAX LDBL_MAX
+#else
+ #define REAL_MAX DBL_MAX
+#endif
+
+#define SHIFT_COUNT_MAX (CHAR_BIT * sizeof (OBNC_LONGI int) - 1)
+#define SET_ELEMENT_MAX (CHAR_BIT * sizeof (OBNC_LONGI unsigned int) - 1)
+
+void Range_CheckIntSum(OBNC_LONGI int a, OBNC_LONGI int b)
+{
+ if ((b > 0) && (a > INTEGER_MAX - b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: %" OBNC_INT_MOD "d + %" OBNC_INT_MOD "d > %" OBNC_INT_MOD "d\n", a, b, INTEGER_MAX);
+ } else if ((b < 0) && (a < INTEGER_MIN - b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: %" OBNC_INT_MOD "d + (%" OBNC_INT_MOD "d) < %" OBNC_INT_MOD "d\n", a, b, INTEGER_MIN);
+ }
+}
+
+
+void Range_CheckIntDiff(OBNC_LONGI int a, OBNC_LONGI int b)
+{
+ if ((b < 0) && (a > INTEGER_MAX + b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: %" OBNC_INT_MOD "d - (%" OBNC_INT_MOD "d) > %" OBNC_INT_MOD "d\n", a, b, INTEGER_MAX);
+ } else if ((b > 0) && (a < INTEGER_MIN + b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: %" OBNC_INT_MOD "d - %" OBNC_INT_MOD "d < %" OBNC_INT_MOD "d\n", a, b, INTEGER_MIN);
+ }
+}
+
+
+void Range_CheckIntProd(OBNC_LONGI int a, OBNC_LONGI int b)
+{
+ if (b > 0) {
+ if ((a > 0) && (a > INTEGER_MAX / b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: %" OBNC_INT_MOD "d * %" OBNC_INT_MOD "d > %" OBNC_INT_MOD "d\n", a, b, INTEGER_MAX);
+ } else if ((a < 0) && (a < INTEGER_MIN / b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: (%" OBNC_INT_MOD "d) * %" OBNC_INT_MOD "d < %" OBNC_INT_MOD "d\n", a, b, INTEGER_MIN);
+ }
+ } else if (b < 0) {
+ if ((a > 0) && (a < INTEGER_MIN / b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: %" OBNC_INT_MOD "d * (%" OBNC_INT_MOD "d) < %" OBNC_INT_MOD "d\n", a, b, INTEGER_MIN);
+ } else if ((a < 0) && (a < INTEGER_MAX / b)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: integer overflow: (%" OBNC_INT_MOD "d) * (%" OBNC_INT_MOD "d) > %" OBNC_INT_MOD "d\n", a, b, INTEGER_MAX);
+ }
+ }
+}
+
+
+void Range_CheckLSL(OBNC_LONGI int n)
+{
+ if (n < 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: negative left shift count: %" OBNC_INT_MOD "d < 0\n", n);
+ } else if (n > SHIFT_COUNT_MAX ) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: left shift count exceeds maximum: %" OBNC_INT_MOD "d > %lu\n", n, (long unsigned) SHIFT_COUNT_MAX);
+ }
+}
+
+
+void Range_CheckASR(OBNC_LONGI int n)
+{
+ if (n < 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: negative right shift count: %" OBNC_INT_MOD "d < 0\n", n);
+ } else if (n > SHIFT_COUNT_MAX) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: right shift count exceeds maximum: %" OBNC_INT_MOD "d > %lu\n", n, (long unsigned) SHIFT_COUNT_MAX);
+ }
+}
+
+
+void Range_CheckROR(OBNC_LONGI int n)
+{
+ if (n < 1) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: non-positive rotation: %" OBNC_INT_MOD "d < 1\n", n);
+ } else if (n > SHIFT_COUNT_MAX) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: rotation exceeds maximum: %" OBNC_INT_MOD "d > %lu\n", n, (long unsigned) SHIFT_COUNT_MAX);
+ }
+}
+
+
+void Range_CheckFLOOR(OBNC_LONGR double x)
+{
+ if (x < (OBNC_LONGR double) INT_MIN) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: parameter in FLOOR too large for truncation to INTEGER: %" OBNC_REAL_MOD_W "E < %" OBNC_REAL_MOD_W "E\n", x, (OBNC_LONGR double) INT_MIN);
+ } else if (x >= (OBNC_LONGR double) INT_MAX + 1.0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: parameter in FLOOR too large for truncation to INTEGER: %" OBNC_REAL_MOD_W "E >= %" OBNC_REAL_MOD_W "E\n", x, (OBNC_LONGR double) INT_MAX + 1.0);
+ }
+}
+
+
+void Range_CheckCHR(OBNC_LONGI int n)
+{
+ if (n < 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: negative parameter in CHR: %" OBNC_INT_MOD "d\n", n);
+ exit(EXIT_FAILURE);
+ } else if (n > CHAR_MAX) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: parameter in CHR too large for conversion: %" OBNC_INT_MOD "d > %d\n", n, CHAR_MAX);
+ }
+}
+
+
+void Range_CheckRealSum(OBNC_LONGR double x, OBNC_LONGR double y)
+{
+ if ((y > 0.0) && (x > REAL_MAX - y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: %" OBNC_REAL_MOD_W "G + %" OBNC_REAL_MOD_W "G > %" OBNC_REAL_MOD_W "G\n", x, y, REAL_MAX);
+ } else if ((y < 0.0) && (x < -REAL_MAX - y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: %" OBNC_REAL_MOD_W "G + (%" OBNC_REAL_MOD_W "G) < %" OBNC_REAL_MOD_W "G\n", x, y, -REAL_MAX);
+ }
+}
+
+
+void Range_CheckRealDiff(OBNC_LONGR double x, OBNC_LONGR double y)
+{
+ if ((y < 0.0) && (x > REAL_MAX + y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: %" OBNC_REAL_MOD_W "G - (%" OBNC_REAL_MOD_W "G) > %" OBNC_REAL_MOD_W "G\n", x, y, REAL_MAX);
+ } else if ((y > 0.0) && (x < -REAL_MAX + y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: %" OBNC_REAL_MOD_W "G - %" OBNC_REAL_MOD_W "G < %" OBNC_REAL_MOD_W "G\n", x, y, -REAL_MAX);
+ }
+}
+
+
+void Range_CheckRealProd(OBNC_LONGR double x, OBNC_LONGR double y)
+{
+ if (y > 0.0) {
+ if ((x > 0.0) && (x > REAL_MAX / y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: %" OBNC_REAL_MOD_W "G * %" OBNC_REAL_MOD_W "G > %" OBNC_REAL_MOD_W "G\n", x, y, REAL_MAX);
+ } else if ((x < 0.0) && (x < -REAL_MAX / y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: (%" OBNC_REAL_MOD_W "G) * %" OBNC_REAL_MOD_W "G < %" OBNC_REAL_MOD_W "G\n", x, y, -REAL_MAX);
+ }
+ } else if (y < 0.0) {
+ if ((x > 0.0) && (x < -REAL_MAX / y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: %" OBNC_REAL_MOD_W "G * (%" OBNC_REAL_MOD_W "G) < %" OBNC_REAL_MOD_W "G\n", x, y, -REAL_MAX);
+ } else if ((x < 0.0) && (x < REAL_MAX / y)) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: real number overflow: (%" OBNC_REAL_MOD_W "G) * (%" OBNC_REAL_MOD_W "G) > %" OBNC_REAL_MOD_W "G\n", x, y, REAL_MAX);
+ }
+ }
+}
+
+
+void Range_CheckByte(OBNC_LONGI int n)
+{
+ if (n < 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: negative byte overflow: %" OBNC_INT_MOD "d < 0\n", n);
+ } else if (n > UCHAR_MAX) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: byte overflow: %" OBNC_INT_MOD "d > %d\n", n, UCHAR_MAX);
+ }
+}
+
+
+void Range_CheckSetElement(OBNC_LONGI int x)
+{
+ if (x < 0) {
+ Oberon_PrintContext();
+ fprintf(stderr, "error: negative set element: %" OBNC_INT_MOD "d\n", x);
+ exit(EXIT_FAILURE);
+ } else if (x > SET_ELEMENT_MAX) {
+ Oberon_PrintContext();
+ fprintf(stderr, "warning: set element exceededs maximum: %" OBNC_INT_MOD "d > %lu\n", x, (long unsigned) SET_ELEMENT_MAX);
+ }
+}
diff --git a/src/Range.h b/src/Range.h
new file mode 100644
index 0000000..71b086c
--- /dev/null
+++ b/src/Range.h
@@ -0,0 +1,49 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef RANGE_H
+#define RANGE_H
+
+#include "../lib/obnc/OBNC.h"
+
+void Range_CheckIntSum(OBNC_LONGI int a, OBNC_LONGI int b);
+
+void Range_CheckIntDiff(OBNC_LONGI int a, OBNC_LONGI int b);
+
+void Range_CheckIntProd(OBNC_LONGI int a, OBNC_LONGI int b);
+
+void Range_CheckLSL(OBNC_LONGI int n);
+
+void Range_CheckASR(OBNC_LONGI int n);
+
+void Range_CheckROR(OBNC_LONGI int n);
+
+void Range_CheckFLOOR(OBNC_LONGR double x);
+
+void Range_CheckCHR(OBNC_LONGI int n);
+
+void Range_CheckRealSum(OBNC_LONGR double x, OBNC_LONGR double y);
+
+void Range_CheckRealDiff(OBNC_LONGR double x, OBNC_LONGR double y);
+
+void Range_CheckRealProd(OBNC_LONGR double x, OBNC_LONGR double y);
+
+void Range_CheckByte(OBNC_LONGI int n);
+
+void Range_CheckSetElement(OBNC_LONGI int x);
+
+#endif
diff --git a/src/StackTrace.c b/src/StackTrace.c
new file mode 100644
index 0000000..7a938a7
--- /dev/null
+++ b/src/StackTrace.c
@@ -0,0 +1,28 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "StackTrace.h"
+
+#ifdef __linux__
+ #include "StackTraceLinux.c"
+#else
+
+void StackTrace_Init(void)
+{
+}
+
+#endif
diff --git a/src/StackTrace.h b/src/StackTrace.h
new file mode 100644
index 0000000..82e22a7
--- /dev/null
+++ b/src/StackTrace.h
@@ -0,0 +1,25 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#ifndef STACKTRACE_H
+#define STACKTRACE_H
+
+#define STACKTRACE_MAXLEN 10
+
+void StackTrace_Init(void);
+
+#endif
diff --git a/src/StackTraceLinux.c b/src/StackTraceLinux.c
new file mode 100644
index 0000000..f230cd0
--- /dev/null
+++ b/src/StackTraceLinux.c
@@ -0,0 +1,120 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "StackTrace.h"
+#include "Oberon.h"
+#include "Util.h"
+#include /*GNU specific*/
+#include /*POSIX*/
+#include
+#include
+#include
+#include
+
+static void ScanFilenameAndOffset(const char line[], char **filename, char **offset, int *done)
+{
+ const char *leftParenPtr, *leftBracketPtr, *rightBracketPtr;
+ int exeFileLen, offsetLen;
+
+ *filename = NULL;
+ *offset = NULL;
+ *done = 0;
+ leftParenPtr = strrchr(line, '(');
+ if (leftParenPtr != NULL) {
+ /*scan filename*/
+ exeFileLen = leftParenPtr - line + 1;
+ NEW_ARRAY(*filename, exeFileLen);
+ memcpy(*filename, line, exeFileLen - 1);
+ (*filename)[exeFileLen - 1] = '\0';
+
+ /*scan file offset*/
+ leftBracketPtr = strrchr(line, '[');
+ if (leftBracketPtr != NULL) {
+ rightBracketPtr = strrchr(line, ']');
+ if (rightBracketPtr != 0) {
+ offsetLen = rightBracketPtr - leftBracketPtr - 1 + 1;
+ NEW_ARRAY(*offset, offsetLen);
+ memcpy(*offset, leftBracketPtr + 1, offsetLen - 1);
+ (*offset)[offsetLen - 1] = '\0';
+ *done = 1;
+ }
+ }
+ }
+}
+
+
+static void PrintSourceFilePosition(const char binFilename[], const char offset[])
+{
+ const char *commandFormat;
+ int commandLen, error;
+ char *command;
+
+ commandFormat = "addr2line -f -e %s %s | grep -v '^?' | sed 's|^/|\t/|' >&2";
+ commandLen = strlen(commandFormat) + (strlen(binFilename) - strlen("%s")) + (strlen(offset) - strlen("%s")) + 1;
+ NEW_ARRAY(command, commandLen);
+ sprintf(command, commandFormat, binFilename, offset);
+ error = system(command);
+ if (error) {
+ fprintf(stderr, "command to print stack trace failed: %s\n", command);
+ }
+}
+
+
+static void PrintStackTrace(int signum)
+{
+ void *returnAddresses[STACKTRACE_MAXLEN];
+ size_t count;
+ char **lines;
+ int lineNum, done;
+ char *filename, *offset;
+
+ Oberon_PrintContext();
+ fprintf(stderr, "\n");
+ count = backtrace(returnAddresses, LEN(returnAddresses));
+ lines = backtrace_symbols(returnAddresses, count);
+ fprintf(stderr, "Fatal signal raised, stack trace:\n");
+ for (lineNum = 0; lineNum < count; lineNum++) {
+ ScanFilenameAndOffset(lines[lineNum], &filename, &offset, &done);
+ if (done) {
+ PrintSourceFilePosition(filename, offset);
+ } else {
+ fprintf(stderr, "warning: failed getting filename and offset from backtrace\n");
+ }
+ }
+ free(lines);
+}
+
+
+void StackTrace_Init(void)
+{
+ static int initialized = 0;
+ static const int fatalSignals[] = {SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, /*SIGKILL,*/ SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2};
+ int i;
+ void (*prevHandler)(int signum);
+
+ if (! initialized) {
+ /*register signal handler for fatal signals*/
+ for (i = 0; i < LEN(fatalSignals); i++) {
+ prevHandler = signal(fatalSignals[i], PrintStackTrace);
+ if (prevHandler == SIG_ERR) {
+ fprintf(stderr, "warning: setting signal handler for PrintStackTrace failed: signal: %d\n", fatalSignals[i]);
+ } else if (prevHandler != NULL) {
+ fprintf(stderr, "replacing previous signal handler with PrintStackTrace\n");
+ }
+ }
+ }
+}
diff --git a/src/Table.c b/src/Table.c
new file mode 100644
index 0000000..3c29912
--- /dev/null
+++ b/src/Table.c
@@ -0,0 +1,1161 @@
+/*Copyright (C) 2017 Karl Landstrom
+
+This file is part of OBNC.
+
+OBNC is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+OBNC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with OBNC. If not, see .*/
+
+#include "Table.h"
+#include "Config.h"
+#include "Files.h"
+#include "Maps.h"
+#include "Trees.h"
+#include "Types.h"
+#include "Util.h"
+#include "../lib/obnc/OBNC.h"
+#include "y.tab.h"
+#include
+#include
+#include
+#include
+#include