Non-VAR arguments are read-only in Eberon.

Type narrowing in ELSIF fix.

build.py

@@ -221,6 +221,18 @@ class compile_target(object):
     def __init__(self, options):
         compile_using_snapshot(options.file)
 
+class self_recompile_target(object):
+    name = 'self_recompile'
+    description = 'compile itself using current sources'
+
+    @staticmethod
+    def setup_options(parser):
+        pass
+
+    def __init__(self, options):
+        bin = os.path.join(root, 'bin')
+        recompile(bin)
+
 class html_target(object):
     name = 'html'
     description = 'build html page'
@@ -276,7 +288,7 @@ class snapshot_target(object):
             os.rename(snapshot_root, old_dir)
         os.rename(new_dir, snapshot_root)
 
-targets = [compile_target, html_target, tests_target, pre_commit_target, snapshot_target]
+targets = [compile_target, self_recompile_target, html_target, tests_target, pre_commit_target, snapshot_target]
 
 def build(target, options):
     targets[target](options)

src/eberon/EberonCast.ob

@@ -4,12 +4,10 @@ IMPORT Cast, EberonString, Types;
 PROCEDURE isOpenCharArray(type: Types.PType): BOOLEAN;
 VAR
     result: BOOLEAN;
-    array: Types.PArray;
 BEGIN
     IF type IS Types.PArray THEN
-        array := type(Types.PArray);
-        result := (Types.arrayElementsType(array^) = Types.basic.ch)
-                & (Types.arrayLength(array^) = Types.openArrayLength);
+        result := (Types.arrayElementsType(type^) = Types.basic.ch)
+                & (Types.arrayLength(type^) = Types.openArrayLength);
     END;
     RETURN result
 END isOpenCharArray;

src/eberon/eberon_context.js

@@ -126,10 +126,11 @@ var ResultVariable = Type.Variable.extend({
 });
 
 var TypeNarrowVariable = Type.Variable.extend({
-    init: function TypeNarrowVariable(type, isRef){
+    init: function TypeNarrowVariable(type, isRef, isReadOnly){
         this.__type = type;
         this.__invertedType = this.__type;
         this.__isRef = isRef;
+        this.__isReadOnly = isReadOnly;
 
         /*
         var d = e.designator();
@@ -146,7 +147,13 @@ var TypeNarrowVariable = Type.Variable.extend({
     isReference: function(){
         return this.__isRef;
     },
-    //idType: function(){return "temporary variable";},
+    isReadOnly: function(){
+        return this.__isReadOnly;
+    },
+    idType: function(){
+        return this.__isReadOnly ? "non-VAR formal parameter"
+                                 : Type.Variable.prototype.idType.call(this);
+    },
     promoteType: function(t){
         var result = this.__type;
         this.__type = t;
@@ -259,7 +266,7 @@ var TemplValueInit = Context.Chained.extend({
         this.__code = "var " + this.__id + " = ";
     },
     handleExpression: function(e){
-        var v = new TypeNarrowVariable(e.type(), false);
+        var v = new TypeNarrowVariable(e.type(), false, false);
         this.__symbol = Symbol.makeSymbol(this.__id, v);
         var type = e.type();
         if (type instanceof Type.Record)
@@ -606,8 +613,12 @@ var ProcOrMethodDecl = Context.ProcDecl.extend({
             : Context.ProcDecl.prototype._prolog.call(this);
     },
     _makeArgumentVariable: function(arg){
-        if (arg.isVar)
-            return new TypeNarrowVariable(arg.type, true);
+        if (!arg.isVar)
+            return new TypeNarrowVariable(arg.type, false, true);
+
+        if (arg.type instanceof Type.Record)
+            return new TypeNarrowVariable(arg.type, true, false);
+
         return Context.ProcDecl.prototype._makeArgumentVariable.call(this, arg);
     },
     setType: function(type){
@@ -921,6 +932,7 @@ var OperatorScopes = Class.extend({
             this.__context.language().stdSymbols);
         this.__context.pushScope(this.__scope);
 
+        this.__typePromotion.reset();
         this.__typePromotion.invert();
         this.__typePromotion = new TypePromotionHandler();
         this.__typePromotions.push(this.__typePromotion);

src/ob/Cast.ob

@@ -33,10 +33,11 @@ END CastOpDoNothing.make;
 *)
 PROCEDURE findBaseType(base: Types.PRecord; type: Types.PRecord): Types.PRecord;
 BEGIN
-    WHILE (type # NIL) & (type # base) DO
-        type := Types.recordBase(type^);
+    result <- type;
+    WHILE (result # NIL) & (result # base) DO
+        result := Types.recordBase(result^);
     END;
-    RETURN type
+    RETURN result
 END findBaseType;
 
 PROCEDURE findPointerBaseType*(base: Types.PPointer; type: Types.Pointer): Types.PPointer;
@@ -104,15 +105,14 @@ BEGIN
     IF t1 = t2 THEN
         result := TRUE;
     ELSIF (t1 IS Types.PArray) & (t2 IS Types.PArray) THEN
-        result := (Types.arrayLength(t1(Types.PArray)^) = Types.arrayLength(t2(Types.PArray)^)) 
-                & (areTypesMatch(Types.arrayElementsType(t1(Types.PArray)^), 
-                                 Types.arrayElementsType(t2(Types.PArray)^)));
+        result := (Types.arrayLength(t1^) = Types.arrayLength(t2^)) 
+                & (areTypesMatch(Types.arrayElementsType(t1^), 
+                                 Types.arrayElementsType(t2^)));
     ELSIF (t1 IS Types.PPointer) & (t2 IS Types.PPointer) THEN
-        result := areTypesMatch(Types.pointerBase(t1(Types.PPointer)^), 
-                                Types.pointerBase(t2(Types.PPointer)^));
+        result := areTypesMatch(Types.pointerBase(t1^), 
+                                Types.pointerBase(t2^));
     ELSIF (t1 IS Types.PDefinedProcedure) & (t2 IS Types.PDefinedProcedure) THEN
-        result := areProceduresMatch(t1(Types.PDefinedProcedure), 
-                                     t2(Types.PDefinedProcedure));
+        result := areProceduresMatch(t1, t2);
     END;
     RETURN result
 END areTypesExactlyMatchImpl;
@@ -155,7 +155,7 @@ BEGIN
         END;
     ELSIF from IS Types.PString THEN
         IF to = Types.basic.ch THEN
-            IF Types.stringAsChar(from(Types.PString)^, c) THEN
+            IF Types.stringAsChar(from^, c) THEN
                 op := makeCastOpStrToChar(c);
                 result := errNo;
             END;
@@ -163,15 +163,15 @@ BEGIN
             result := errNo;
         END;
     ELSIF (from IS Types.PArray) & (to IS Types.PArray) THEN
-        IF ((Types.arrayLength(from(Types.PArray)^) = Types.arrayLength(to(Types.PArray)^))
-                OR (Types.arrayLength(to(Types.PArray)^) = Types.openArrayLength))
-            & areTypesExactlyMatch(Types.arrayElementsType(from(Types.PArray)^), 
-                                   Types.arrayElementsType(to(Types.PArray)^)) THEN
+        IF ((Types.arrayLength(from^) = Types.arrayLength(to^))
+                OR (Types.arrayLength(to^) = Types.openArrayLength))
+            & areTypesExactlyMatch(Types.arrayElementsType(from^), 
+                                   Types.arrayElementsType(to^)) THEN
             result := errNo;
         END;
     ELSIF (from IS Types.PPointer) & (to IS Types.PPointer) THEN
         IF ~toVar THEN
-            IF findPointerBaseType(to(Types.PPointer), from(Types.PPointer)^) # NIL THEN
+            IF findPointerBaseType(to, from^) # NIL THEN
                 result := errNo;
             END;
         ELSIF areTypesExactlyMatchImpl(to, from) THEN
@@ -180,13 +180,13 @@ BEGIN
             result := errVarParameter;
         END;
     ELSIF (from IS Types.PRecord) & (to IS Types.PRecord) THEN
-        IF findBaseType(to(Types.PRecord), from(Types.PRecord)) # NIL THEN
+        IF findBaseType(to, from) # NIL THEN
             result := errNo;
         END;
     ELSIF (from = Types.nil) & matchesToNIL(to^) THEN
         result := errNo;
     ELSIF (from IS Types.PDefinedProcedure) & (to IS Types.PDefinedProcedure) THEN
-        IF areProceduresMatch(from(Types.PDefinedProcedure), to(Types.PDefinedProcedure)) THEN
+        IF areProceduresMatch(from, to) THEN
             result := errNo;
         END
     END;

src/ob/Code.ob

@@ -133,10 +133,11 @@ PROCEDURE putIndent(s: STRING; indent: INTEGER): STRING;
 VAR
     i: INTEGER;
 BEGIN
+    result <- s;
     FOR i := 0 TO indent - 1 DO
-        s := s + kTab;
+        result := result + kTab;
     END;
-    RETURN s
+    RETURN result
 END putIndent;
 
 PROCEDURE Generator.write(s: STRING);

src/ob/Procedure.ob

@@ -208,19 +208,20 @@ END makeCallGenerator;
 PROCEDURE GenArgCode.write(actual: Code.PExpression; expected: Types.PProcedureArgument; cast: Cast.PCastOp);
 VAR
     e: Code.PExpression;
+    coercedArg: Code.PExpression;
 BEGIN
     IF (expected # NIL) & expected.isVar THEN
-        actual := Code.refExpression(actual);
+        coercedArg := Code.refExpression(actual);
     ELSE
-        actual := Code.derefExpression(actual);
+        coercedArg := Code.derefExpression(actual);
     END;
     IF LEN(SELF.code) # 0 THEN
         SELF.code := SELF.code + ", ";
     END;
     IF cast # NIL THEN
-        e := cast.make(SELF.cx.rtl, actual);
+        e := cast.make(SELF.cx.rtl, coercedArg);
     ELSE
-        e := actual;
+        e := coercedArg;
     END;
     SELF.code := SELF.code + e.code();
 END GenArgCode.write;

test/expected/eberon/string.js

@@ -18,7 +18,7 @@ function pChar(c/*CHAR*/){
 }
 
 function pString(s/*STRING*/){
-	s = "\"";
+	RTL$.assert(s == s);
 }
 
 function pStringByRef(s/*VAR STRING*/){

test/input/eberon/string.ob

@@ -15,7 +15,9 @@ END pChar;
 
 PROCEDURE pString(s: STRING);
 BEGIN
-    s := 22X;
+    ASSERT(s = s);
+    (*ASSERT(s = "abc");*)
+    (*ASSERT(s = 22X);*)
 END pString;
 
 PROCEDURE pStringByRef(VAR s: STRING);

test/test_unit.js

@@ -1187,7 +1187,6 @@ return {
             "TYPE ProcType = PROCEDURE(): ProcType;"),
     pass("PROCEDURE p; END p",
          "PROCEDURE p; VAR i: INTEGER; BEGIN i := i + 1 END p",
-         "PROCEDURE p(a: INTEGER); BEGIN a := a + 1 END p",
          "PROCEDURE p(a1, a2: INTEGER); END p",
          "PROCEDURE p; BEGIN p() END p",
          "PROCEDURE p(a: INTEGER); BEGIN p(a) END p",
@@ -1249,8 +1248,6 @@ return {
          "PROCEDURE p(a: ARRAY OF T); BEGIN varInteger(a[0].p.i) END p"),
     fail(["PROCEDURE p(a: ARRAY OF INTEGER); BEGIN a[0] := 0 END p",
           "cannot assign to read-only variable"],
-         ["PROCEDURE p(a: ARRAY OF INTEGER); BEGIN p3(a) END p",
-          "read-only variable cannot be used as VAR parameter"],
          ["PROCEDURE p(a: ARRAY OF T); BEGIN a[0].i := 0 END p",
           "cannot assign to read-only variable"],
          ["PROCEDURE p(a: ARRAY OF T); BEGIN varInteger(a[0].i) END p",
@@ -1271,8 +1268,6 @@ return {
     fail(["PROCEDURE p(r: T); BEGIN r.i := 0 END p",
           "cannot assign to read-only variable"],
          ["PROCEDURE p(r: T); BEGIN intVar(r.i); END p",
-          "read-only variable cannot be used as VAR parameter"],
-         ["PROCEDURE p(r: T); BEGIN recordVar(r); END p",
           "read-only variable cannot be used as VAR parameter"]
         )
     ),
@@ -1293,9 +1288,7 @@ return {
 "open array assignment fails": testWithGrammar(
     grammar.procedureDeclaration,
     pass(),
-    fail(["PROCEDURE p(s1, s2: ARRAY OF CHAR); BEGIN s1 := s2 END p",
-          "cannot assign to read-only variable"],
-         ["PROCEDURE p(VAR s1, s2: ARRAY OF CHAR); BEGIN s1 := s2 END p",
+    fail(["PROCEDURE p(VAR s1, s2: ARRAY OF CHAR); BEGIN s1 := s2 END p",
           "'s1' is open 'ARRAY OF CHAR' and cannot be assigned"],
          ["PROCEDURE p(s1: ARRAY OF CHAR); VAR s2: ARRAY 10 OF CHAR; BEGIN s2 := s1 END p",
           "type mismatch: 's2' is 'ARRAY 10 OF CHAR' and cannot be assigned to 'ARRAY OF CHAR' expression"])
@@ -1335,8 +1328,7 @@ return {
 "string assignment to open array fails": testWithGrammar(
     grammar.procedureDeclaration,
     pass(),
-    fail(["PROCEDURE p(s: ARRAY OF CHAR); BEGIN s := \"abc\" END p", "cannot assign to read-only variable"],
-         ["PROCEDURE p(VAR s: ARRAY OF CHAR); BEGIN s := \"abc\" END p", "string cannot be assigned to open ARRAY OF CHAR"])
+    fail(["PROCEDURE p(VAR s: ARRAY OF CHAR); BEGIN s := \"abc\" END p", "string cannot be assigned to open ARRAY OF CHAR"])
     ),
 "scope": testWithGrammar(
     grammar.declarationSequence,

test/test_unit_eberon.js

@@ -494,7 +494,9 @@ exports.suite = {
             "IF (b IS PDerived) & bVar THEN b.flag := FALSE; END;",
             "IF bVar & (b IS PDerived) THEN b.flag := FALSE; END;",
             "IF FALSE THEN ELSIF b IS PDerived THEN b.flag := FALSE; END;",
-            "IF b IS PDerived THEN bVar := (b IS PDerived2) & b.flag2; b.flag := FALSE; END;"
+            "IF b IS PDerived THEN bVar := (b IS PDerived2) & b.flag2; b.flag := FALSE; END;",
+            "IF bVar THEN ELSIF b IS PDerived2 THEN ELSIF b IS PDerived THEN END;",
+            "IF bVar THEN ELSIF b IS PDerived THEN ELSIF b IS PDerived THEN ELSIF b IS PDerived THEN END;"
             ),
         temporaryValues.failStatements(
             "IF (b IS PDerived) OR bVar THEN b.flag := FALSE; END",
@@ -620,7 +622,37 @@ exports.suite = {
     },
     "type promotion for VAR arguments": testWithContext(
         context(grammar.declarationSequence, 
-                "TYPE Base = RECORD END; Derived = RECORD (Base) flag: BOOLEAN END;"),
-        pass("PROCEDURE p(VAR b: Base); BEGIN ASSERT((b IS Derived) & b.flag); END p;")
+                "TYPE Base = RECORD END; PBase = POINTER TO Base;"
+                + "Derived = RECORD (Base) flag: BOOLEAN END; PDerived = POINTER TO Derived;"),
+        pass("PROCEDURE p(VAR b: Base); BEGIN ASSERT((b IS Derived) & b.flag); END p;"),
+        fail(["PROCEDURE p(VAR b: PBase); BEGIN ASSERT((b IS PDerived) & b.flag); END p;",
+              "type 'Base' has no 'flag' field"])
+    ),
+    "type promotion for non-VAR arguments": testWithContext(
+        context(grammar.declarationSequence, 
+                "TYPE Base = RECORD END; PBase = POINTER TO Base;"
+                + "Derived = RECORD (Base) flag: BOOLEAN END; PDerived = POINTER TO Derived;"),
+        pass("PROCEDURE p(b: PBase); BEGIN ASSERT((b IS PDerived) & b.flag); END p;")
+    ),
+    "Non-VAR arguments cannot be modified": testWithContext(
+        context(grammar.declarationSequence, 
+                "TYPE PBase = POINTER TO RECORD END; T = RECORD i: INTEGER END;"
+                + "PROCEDURE pArrayRef(VAR a: ARRAY OF INTEGER); END pArrayRef;"
+                + "PROCEDURE recordVar(VAR r: T); END recordVar;"),
+        pass("PROCEDURE p(VAR i: INTEGER); BEGIN i := 0; END p;",
+             "PROCEDURE p(VAR b: PBase); BEGIN b := NIL; END p;"),
+        fail(["PROCEDURE p(i: INTEGER); BEGIN i := 0; END p;", 
+              "cannot assign to non-VAR formal parameter"],
+             ["PROCEDURE p(b: PBase); BEGIN b := NIL; END p;", 
+              "cannot assign to non-VAR formal parameter"],
+             ["PROCEDURE p(a: ARRAY OF INTEGER); BEGIN pArrayRef(a) END p",
+              "non-VAR formal parameter cannot be used as VAR parameter"],
+             ["PROCEDURE p(r: T); BEGIN recordVar(r); END p",
+              "non-VAR formal parameter cannot be used as VAR parameter"],
+             ["PROCEDURE p(s1, s2: ARRAY OF CHAR); BEGIN s1 := s2 END p",
+              "cannot assign to non-VAR formal parameter"],
+             ["PROCEDURE p(s: ARRAY OF CHAR); BEGIN s := \"abc\" END p", 
+              "cannot assign to non-VAR formal parameter"]
+            )
     )
 };

test/test_unit_oberon.js

@@ -60,5 +60,39 @@ exports.suite = {
             "PROCEDURE p; END p;"),
     pass(),
     fail(["p()()", "not parsed"])
-    )
+    ),
+"procedure arguments can be modified": testWithContext(
+    context(grammar.procedureDeclaration, ""),
+    pass("PROCEDURE p(a: INTEGER); BEGIN a := a + 1 END p")
+    ),
+"Non-VAR ARRAY parameter cannot be passed as VAR": testWithContext(
+    context(grammar.procedureDeclaration,
+            "PROCEDURE pArrayRef(VAR a: ARRAY OF INTEGER); END pArrayRef;"
+            ),
+    pass(),
+    fail(["PROCEDURE p(a: ARRAY OF INTEGER); BEGIN pArrayRef(a) END p",
+          "read-only variable cannot be used as VAR parameter"]
+         )
+    ),
+"Non-VAR RECORD parameter cannot be passed as VAR": testWithContext(
+    context(grammar.procedureDeclaration,
+            "TYPE T = RECORD i: INTEGER END;"
+            + "PROCEDURE recordVar(VAR r: T); END recordVar;"
+            ),
+    pass(),
+    fail(["PROCEDURE p(r: T); BEGIN recordVar(r); END p",
+          "read-only variable cannot be used as VAR parameter"]
+         )
+    ),
+"Non-VAR open array assignment fails": testWithGrammar(
+    grammar.procedureDeclaration,
+    pass(),
+    fail(["PROCEDURE p(s1, s2: ARRAY OF CHAR); BEGIN s1 := s2 END p",
+          "cannot assign to read-only variable"])
+    ),
+"string assignment to non-VAR open array fails": testWithGrammar(
+    grammar.procedureDeclaration,
+    pass(),
+    fail(["PROCEDURE p(s: ARRAY OF CHAR); BEGIN s := \"abc\" END p", "cannot assign to read-only variable"])
+    ),
 };