From 8bf244e32a0d505720396fbb7df26f824c7f77eb Mon Sep 17 00:00:00 2001
From: Gaius Mulley <gaiusmod2@gmail.com>
Date: Wed, 2 Aug 2023 00:34:29 +0100
Subject: [PATCH] PR modula2/110161 Comparing a typed procedure variable to 0
 gives ICE or assertion

This patch allows a proc type to be compared against an address.

gcc/m2/ChangeLog:

	PR modula2/110161
	* gm2-compiler/M2Check.mod (checkProcTypeEquivalence): New
	procedure function.
	(checkTypeKindEquivalence): Call checkProcTypeEquivalence
	if either left or right is a proc type.
	* gm2-compiler/M2Quads.mod (BuildRelOp): Create
	combinedTok prior to creating the range check quadruple.
	Use combinedTok when creating the range check quadruple.

gcc/testsuite/ChangeLog:

	PR modula2/110161
	* gm2/pim/fail/badxproc.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
---
 gcc/m2/gm2-compiler/M2Check.mod         | 39 ++++++++++++++++++++-----
 gcc/m2/gm2-compiler/M2Quads.mod         |  5 ++--
 gcc/testsuite/gm2/pim/fail/badxproc.mod |  8 +++++
 3 files changed, 43 insertions(+), 9 deletions(-)
 create mode 100644 gcc/testsuite/gm2/pim/fail/badxproc.mod

diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index f7e72d3f667..af2c7c7ccad 100644
--- a/gcc/m2/gm2-compiler/M2Check.mod
+++ b/gcc/m2/gm2-compiler/M2Check.mod
@@ -901,6 +901,37 @@ BEGIN
 END checkPointerType ;
 
 
+(*
+   checkProcTypeEquivalence - allow proctype to be compared against another
+                              proctype or procedure.  It is legal to be compared
+                              against an address.
+*)
+
+PROCEDURE checkProcTypeEquivalence (result: status; tinfo: tInfo;
+                                    left, right: CARDINAL) : status ;
+BEGIN
+   IF isFalse (result)
+   THEN
+      RETURN result
+   ELSIF IsProcedure (left) AND IsProcType (right)
+   THEN
+      RETURN checkProcedure (result, tinfo, right, left)
+   ELSIF IsProcType (left) AND IsProcedure (right)
+   THEN
+      RETURN checkProcedure (result, tinfo, left, right)
+   ELSIF IsProcType (left) AND IsProcType (right)
+   THEN
+      RETURN checkProcType (result, tinfo, left, right)
+   ELSIF (left = Address) OR (right = Address)
+   THEN
+      RETURN true
+   ELSE
+      RETURN false
+   END
+END checkProcTypeEquivalence ;
+
+
+
 (*
    checkTypeKindEquivalence -
 *)
@@ -928,15 +959,9 @@ BEGIN
       ELSIF IsEnumeration (left) AND IsEnumeration (right)
       THEN
          RETURN checkEnumerationEquivalence (result, left, right)
-      ELSIF IsProcedure (left) AND IsProcType (right)
-      THEN
-         RETURN checkProcedure (result, tinfo, right, left)
-      ELSIF IsProcType (left) AND IsProcedure (right)
-      THEN
-         RETURN checkProcedure (result, tinfo, left, right)
       ELSIF IsProcType (left) OR IsProcType (right)
       THEN
-         RETURN checkProcType (result, tinfo, left, right)
+         RETURN checkProcTypeEquivalence (result, tinfo, right, left)
       ELSIF IsReallyPointer (left) AND IsReallyPointer (right)
       THEN
          RETURN checkPointerType (result, left, right)
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 031ee894710..c11e61fbb0c 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -12969,11 +12969,13 @@ BEGIN
 
       CheckVariableOrConstantOrProcedure (rightpos, right) ;
       CheckVariableOrConstantOrProcedure (leftpos, left) ;
+      combinedTok := MakeVirtualTok (optokpos, leftpos, rightpos) ;
 
       IF (left#NulSym) AND (right#NulSym)
       THEN
          (* BuildRange will check the expression later on once gcc knows about all data types.  *)
-         BuildRange (InitTypesExpressionCheck (optokpos, left, right, TRUE, Op = InTok))
+         BuildRange (InitTypesExpressionCheck (combinedTok, left, right, TRUE,
+                                               Op = InTok))
       END ;
 
       (* Must dereference LeftValue operands.  *)
@@ -12993,7 +12995,6 @@ BEGIN
          doIndrX (leftpos, t, left) ;
          left := t
       END ;
-      combinedTok := MakeVirtualTok (optokpos, leftpos, rightpos) ;
 
       IF DebugTokPos
       THEN
diff --git a/gcc/testsuite/gm2/pim/fail/badxproc.mod b/gcc/testsuite/gm2/pim/fail/badxproc.mod
new file mode 100644
index 00000000000..54a0931e656
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/badxproc.mod
@@ -0,0 +1,8 @@
+MODULE badxproc ;
+
+TYPE xProc = PROCEDURE(): BOOLEAN;
+VAR x: xProc;
+
+BEGIN
+  IF x = 0 THEN END;
+END badxproc.