PR modula2/120497: error is generated for good code when returning a pointer var...

The return type checking needs to skip over the Lvalue part of the VAR
parameter or variable.

gcc/m2/ChangeLog:

	PR modula2/120497
	* gm2-compiler/M2Range.mod (IsAssignmentCompatible): Remove from
	import list.
	(FoldTypeReturnFunc): Rewrite to skip the Lvalue of a var
	variable.
	(CodeTypeReturnFunc): Ditto.
	(CodeTypeIndrX): Call AssignmentTypeCompatible rather than
	IsAssignmentCompatible.
	(FoldTypeIndrX): Ditto.

gcc/testsuite/ChangeLog:

	PR modula2/120497
	* gm2/pim/pass/ReturnType.mod: New test.
	* gm2/pim/pass/ReturnType2.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index fcca9727165f6372dd995001fe446bc683872aef..dcac2ba33c5332f55203a48a23486504b8963bba 100644 (file)
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -91,7 +91,6 @@ FROM M2Check IMPORT ParameterTypeCompatible, ExpressionTypeCompatible, Assignmen
 
 FROM M2Base IMPORT Nil, IsRealType, GetBaseTypeMinMax,
                    Cardinal, Integer, ZType, IsComplexType,
-                   IsAssignmentCompatible,
                    IsExpressionCompatible,
                    IsParameterCompatible,
                    ExceptionAssign,
@@ -1803,6 +1802,7 @@ END FoldRotate ;
 
 PROCEDURE FoldTypeReturnFunc (q: CARDINAL; tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ;
 VAR
+   valType,
    returnType: CARDINAL ;
 BEGIN
    returnType := GetType (func) ;
@@ -1816,18 +1816,25 @@ BEGIN
                        func, val) ;
          SubQuad(q)
       END
-   ELSIF AssignmentTypeCompatible (tokenNo, "", returnType, val, FALSE)
-   THEN
-      SubQuad (q)
    ELSE
-      IF NOT reportedError (r)
+      valType := val ;
+      IF IsVar (val) AND (GetMode (val) = LeftValue)
       THEN
-         MetaErrorsT2 (tokenNo,
-                       'the return type {%1Etad} used in procedure {%1Da}',
-                       'is incompatible with the returned expression {%1ad}}',
-                       func, val) ;
-         setReported (r) ;
-         FlushErrors
+         valType := GetType (val)
+      END ;
+      IF AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE)
+      THEN
+         SubQuad (q)
+      ELSE
+         IF NOT reportedError (r)
+         THEN
+            MetaErrorsT2 (tokenNo,
+                          'the return type {%1Etad} used in procedure {%1Da}',
+                          'is incompatible with the returned expression {%1ad}}',
+                          func, val) ;
+            setReported (r) ;
+            FlushErrors
+         END
       END
    END
 END FoldTypeReturnFunc ;
@@ -1877,7 +1884,7 @@ BEGIN
    ELSE
       exprType := GetType (expr)
    END ;
-   IF IsAssignmentCompatible (desType, exprType)
+   IF AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE)
    THEN
       SubQuad(q)
    ELSE
@@ -1986,16 +1993,35 @@ END CodeTypeAssign ;
 *)
 
 PROCEDURE CodeTypeReturnFunc (tokenNo: CARDINAL; func, val: CARDINAL; r: CARDINAL) ;
+VAR
+   valType,
+   returnType: CARDINAL ;
 BEGIN
-   IF NOT AssignmentTypeCompatible (tokenNo, "", GetType (func), val, FALSE)
+   returnType := GetType (func) ;
+   IF returnType = NulSym
    THEN
       IF NOT reportedError (r)
       THEN
          MetaErrorsT2 (tokenNo,
-                       'the return type {%1Etad} used in procedure function {%1Da}',
-                       'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}',
+                       'procedure {%1Da} is not a procedure function',
+                       '{%2ad} cannot be returned from {%1Da}',
                        func, val) ;
-         setReported (r)
+      END
+   ELSE
+      valType := val ;
+      IF IsVar (val) AND (GetMode (val) = LeftValue)
+      THEN
+         valType := GetType (val)
+      END ;
+      IF NOT AssignmentTypeCompatible (tokenNo, "", returnType, valType, FALSE)
+      THEN
+         IF NOT reportedError (r)
+         THEN
+            MetaErrorsT2 (tokenNo,
+                          'the return type {%1Etad} used in procedure function {%1Da}',
+                          'is incompatible with the returned expression {%2EUa} {%2tad:of type {%2tad}}',
+                          func, val)
+         END
       END
    END
 END CodeTypeReturnFunc ;
@@ -2010,7 +2036,7 @@ END CodeTypeReturnFunc ;
 
 PROCEDURE CodeTypeIndrX (tokenNo: CARDINAL; des, expr: CARDINAL; r: CARDINAL) ;
 BEGIN
-   IF NOT IsAssignmentCompatible (GetType (des), GetType (expr))
+   IF NOT AssignmentTypeCompatible (tokenNo, "", GetType (des), GetType (expr), FALSE)
    THEN
       IF NOT reportedError (r)
       THEN
@@ -2022,7 +2048,9 @@ BEGIN
                           des, expr) ;
          ELSE
             MetaErrorT2 (tokenNo,
-                         'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible',
+                         'assignment designator {%1Ea} {%1ta:of type {%1ta}}' +
+                         ' {%1d:is a {%1d}} and expression {%2a}' +
+                         ' {%2tad:of type {%2tad}} are incompatible',
                          des, expr)
          END ;
          setReported (r)

diff --git a/gcc/testsuite/gm2/pim/pass/ReturnType.mod b/gcc/testsuite/gm2/pim/pass/ReturnType.mod
new file mode 100644 (file)
index 0000000..149bc85
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/ReturnType.mod
@@ -0,0 +1,17 @@
+MODULE ReturnType ;
+
+TYPE
+   bar = POINTER TO CARDINAL ;
+
+
+PROCEDURE foo (VAR value: bar) : bar ;
+BEGIN
+   RETURN value
+END foo ;
+
+VAR
+   b: bar ;
+BEGIN
+   b := NIL ;
+   b := foo (b)
+END ReturnType.

diff --git a/gcc/testsuite/gm2/pim/pass/ReturnType2.mod b/gcc/testsuite/gm2/pim/pass/ReturnType2.mod
new file mode 100644 (file)
index 0000000..bab7f5b
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/pass/ReturnType2.mod
@@ -0,0 +1,19 @@
+MODULE ReturnType2 ;
+
+TYPE
+   bar = POINTER TO RECORD
+                       field: CARDINAL ;
+                    END ;
+
+
+PROCEDURE foo (VAR value: bar) : bar ;
+BEGIN
+   RETURN value
+END foo ;
+
+VAR
+   b: bar ;
+BEGIN
+   b := NIL ;
+   b := foo (b)
+END ReturnType2.