Do not allow to pass pointer to derived as VAR pointer to base

src/context.js

@@ -1684,7 +1684,7 @@ function isTypeRecursive(type, base){
     return false;
 }
 
-var RecordField = Class.extend({
+var RecordField = Type.Field.extend({
     init: function Context$RecordField(identdef, type, recordType){
         this.__identdef = identdef;
         this.__type = type;

src/eberon/eberon_context.js

@@ -134,8 +134,7 @@ var TempVariable = Type.Variable.extend({
     type: function(){
         return this.__type;
     },
-    isReadOnly: function(){return true;},
-    idType: function(){return "temporary variable";},
+    //idType: function(){return "temporary variable";},
     promoteType: function(t){
         var result = this.__type;
         this.__type = t;

src/ob/Cast.ob

@@ -170,8 +170,14 @@ BEGIN
             result := errNo;
         END;
     ELSIF (from IS Types.PPointer) & (to IS Types.PPointer) THEN
-        IF findPointerBaseType(to(Types.PPointer), from(Types.PPointer)^) # NIL THEN
+        IF ~toVar THEN
+            IF findPointerBaseType(to(Types.PPointer), from(Types.PPointer)^) # NIL THEN
+                result := errNo;
+            END;
+        ELSIF areTypesExactlyMatchImpl(to, from) THEN
             result := errNo;
+        ELSE
+            result := errVarParameter;
         END;
     ELSIF (from IS Types.PRecord) & (to IS Types.PRecord) THEN
         IF findBaseType(to(Types.PRecord), from(Types.PRecord)) # NIL THEN

src/ob/Types.ob

@@ -407,12 +407,12 @@ END Record.addField;
 
 PROCEDURE Record.findSymbol(id: STRING): PField;
 VAR
-    result: PField;
+    result: Object.PType;
 BEGIN
     IF ~JsMap.find(SELF.fields, id, result) & (SELF.base # NIL) THEN
         result := SELF.base.findSymbol(id);
     END;
-    RETURN result
+    RETURN result(PField)
 END Record.findSymbol;
 
 PROCEDURE recordBase*(r: Record): PRecord;

test/test_unit.js

@@ -782,10 +782,13 @@ return {
 "VAR parameter": testWithContext(
     context(grammar.statement,
             "CONST c = 123;"
+            + "TYPE Base = RECORD END; Derived = RECORD (Base) END; PBase = POINTER TO Base; PDerived = POINTER TO Derived;"
             + "VAR i1: INTEGER; b1: BOOLEAN; a1: ARRAY 5 OF INTEGER;"
                 + "r1: RECORD f1: INTEGER END;"
+                + "pBase: PBase; pDerived: PDerived;"
             + "PROCEDURE p1(VAR i: INTEGER); END p1;"
             + "PROCEDURE p2(VAR b: BOOLEAN); END p2;"
+            + "PROCEDURE procBasePointer(VAR p: PBase); END procBasePointer;"
             ),
     pass("p1(i1)",
          "p1(a1[0])",
@@ -797,7 +800,10 @@ return {
          ["p1(i1 * i1)", "expression cannot be used as VAR parameter"],
          ["p1(+i1)", "expression cannot be used as VAR parameter"],
          ["p1(-i1)", "expression cannot be used as VAR parameter"],
-         ["p2(~b1)", "expression cannot be used as VAR parameter"])
+         ["p2(~b1)", "expression cannot be used as VAR parameter"],
+         ["procBasePointer(pDerived)", 
+          "type mismatch for argument 1: cannot pass 'PDerived' as VAR parameter of type 'PBase'"]
+         )
     ),
 "procedure call": testWithContext(
     context(grammar.statement,

test/test_unit_eberon.js

@@ -27,6 +27,7 @@ var temporaryValues = {
         "TYPE Base = RECORD END;"
         + "Derived = RECORD (Base) flag: BOOLEAN END;"
         + "Derived2 = RECORD (Derived) flag2: BOOLEAN END;"
+        + "PBase = POINTER TO Base;"
         + "PDerived = POINTER TO Derived;"
         + "PDerived2 = POINTER TO Derived2;"
         + "VAR pBase: POINTER TO Base; bVar: BOOLEAN;"
@@ -426,14 +427,6 @@ exports.suite = {
               "'i' already declared in procedure scope"]
             )
         ),
-    "read-only": testWithContext(
-        context(grammar.declarationSequence,
-                ""),
-        pass(),
-        fail(["PROCEDURE p(); BEGIN v <- 0; v := 0; END p;", 
-              "cannot assign to temporary variable"]
-            )
-        ),
     "type promotion in expression": testWithContext(
         temporaryValues.context,
         temporaryValues.passExpressions(
@@ -531,6 +524,20 @@ exports.suite = {
         temporaryValues.failStatements(
             "WHILE b IS PDerived DO END; b.flag := FALSE;"
             )
+        ),
+    "type promotion cannot be reset by assignment": testWithContext(
+        temporaryValues.context,
+        pass(),
+        fail(["PROCEDURE p(); BEGIN b <- pBase; IF b IS PDerived THEN b := pBase; b.flag := FALSE; END; END p;",
+              "type mismatch: 'b' is 'PDerived' and cannot be assigned to 'POINTER TO Base' expression"]
+            )
+        ),
+    "type promotion cannot be reset by passing as VAR argument": testWithContext(
+        temporaryValues.context,
+        pass(),
+        fail(["PROCEDURE p(); PROCEDURE procBaseAsVar(VAR p: PBase); END procBaseAsVar;  BEGIN b <- pBase; IF b IS PDerived THEN procBaseAsVar(b); b.flag := FALSE; END; END p;",
+              "type mismatch for argument 1: cannot pass 'PDerived' as VAR parameter of type 'PBase'"]
+            )
         )
     }
 };