https://gcc.gnu.org/g:170717fa243ef466a99498113167627539af4553
commit r16-1029-g170717fa243ef466a99498113167627539af4553
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Sun Jun 1 01:05:55 2025 +0100
PR modula2/120497: error is generated for good code when returning a
pointer var variable
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 <gaiusm...@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2Range.mod | 64 +++++++++++++++++++++---------
gcc/testsuite/gm2/pim/pass/ReturnType.mod | 17 ++++++++
gcc/testsuite/gm2/pim/pass/ReturnType2.mod | 19 +++++++++
3 files changed, 82 insertions(+), 18 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index fcca9727165f..dcac2ba33c53 100644
--- 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
index 000000000000..149bc850e070
--- /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
index 000000000000..bab7f5bcb2ce
--- /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.
