PR modula2/118589 Opaque type fields are visible outside implementation module

This patch fixes a bug shown when a variable declared as an opaque type is
dereferenced outside the declaration module.  The fix also improves error
recovery.  In the error cases it ensures that an error symbol is created
and the appropriate virtual token is assigned.  Finally there is a new
testsuite directory gm2.dg which contains tests to check against expected
error messages.

gcc/m2/ChangeLog:

	PR modula2/118589
	* gm2-compiler/M2MetaError.mod (symDesc): Add opaque type
	description.
	* gm2-compiler/M2Quads.mod (BuildDesignatorPointerError): New
	procedure.
	(BuildDesignatorPointer): Reimplement.
	* gm2-compiler/P3Build.bnf (SubDesignator): Tidy up error message.
	Use MetaErrorT2 rather than WriteForma1 and use the token pos from
	the quad stack.

gcc/testsuite/ChangeLog:

	PR modula2/118589
	* lib/gm2-dg.exp (gm2.exp): load_lib.
	* gm2.dg/pim/fail/badopaque.mod: New test.
	* gm2.dg/pim/fail/badopaque2.mod: New test.
	* gm2.dg/pim/fail/dg-pim-fail.exp: New test.
	* gm2.dg/pim/fail/opaquedefs.def: New test.
	* gm2.dg/pim/fail/opaquedefs.mod: New test.

Signed-off-by: Gaius Mulley <[email protected]>

Author: Gaius Mulley

gcc/m2/gm2-compiler/M2MetaError.mod

@@ -1611,7 +1611,12 @@ BEGIN
       END
    ELSIF IsType(sym)
    THEN
-      RETURN InitString('type')
+      IF IsHiddenType (sym)
+      THEN
+         RETURN InitString('opaque type')
+      ELSE
+         RETURN InitString('type')
+      END
    ELSIF IsRecord(sym)
    THEN
       RETURN InitString('record')

gcc/m2/gm2-compiler/M2Quads.mod

@@ -63,6 +63,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
                         GetScope, GetCurrentScope,
                         GetSubrange, SkipTypeAndSubrange,
                         GetModule, GetMainModule,
+                        GetModuleScope, GetCurrentModuleScope,
                         GetCurrentModule, GetFileModule, GetLocalSym,
                         GetStringLength, GetString,
                         GetArraySubscript, GetDimension,
@@ -115,7 +116,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
                         PutDeclared,
                         MakeComponentRecord, MakeComponentRef,
                         IsSubscript, IsComponent, IsConstStringKnown,
-                        IsTemporary,
+                        IsTemporary, IsHiddenType,
                         IsAModula2Type,
                         PutLeftValueFrontBackType,
                         PushSize, PushValue, PopValue,
@@ -11427,6 +11428,24 @@ BEGIN
 END BuildDesignatorError ;
 
 
+(*
+   BuildDesignatorPointerError - removes the designator from the stack and replaces
+                                 it with an error symbol.
+*)
+
+PROCEDURE BuildDesignatorPointerError (type, rw: CARDINAL; tokpos: CARDINAL;
+                                       message: ARRAY OF CHAR) ;
+VAR
+   error: CARDINAL ;
+BEGIN
+   error := MakeError (tokpos, MakeKey (message)) ;
+   IF GetSType (type) # NulSym
+   THEN
+      type := GetSType (type)
+   END ;
+   PushTFrwtok (error, type, rw, tokpos)
+END BuildDesignatorPointerError ;
+
 
 (*
    BuildDesignatorArray - Builds the array referencing.
@@ -11819,13 +11838,13 @@ END DebugLocation ;
 PROCEDURE BuildDesignatorPointer (ptrtok: CARDINAL) ;
 VAR
    combinedtok,
-   exprtok    : CARDINAL ;
+   destok    : CARDINAL ;
    rw,
    Sym1, Type1,
    Sym2, Type2: CARDINAL ;
 BEGIN
-   PopTFrwtok (Sym1, Type1, rw, exprtok) ;
-   DebugLocation (exprtok, "expression") ;
+   PopTFrwtok (Sym1, Type1, rw, destok) ;
+   DebugLocation (destok, "des ptr expression") ;
 
    Type1 := SkipType (Type1) ;
    IF Type1 = NulSym
@@ -11834,33 +11853,44 @@ BEGIN
    ELSIF IsUnknown (Sym1)
    THEN
       MetaError1 ('{%1EMad} is undefined and therefore {%1ad}^ cannot be resolved', Sym1)
-   ELSIF IsPointer (Type1)
-   THEN
-      Type2 := GetSType (Type1) ;
-      Sym2 := MakeTemporary (ptrtok, LeftValue) ;
-      (*
-         Ok must reference by address
-         - but we contain the type of the referenced entity
-      *)
-      MarkAsRead (rw) ;
-      PutVarPointerCheck (Sym1, TRUE) ;
-      CheckPointerThroughNil (ptrtok, Sym1) ;
-      IF GetMode (Sym1) = LeftValue
-      THEN
-         rw := NulSym ;
-         PutLeftValueFrontBackType (Sym2, Type2, Type1) ;
-         GenQuadO (ptrtok, IndrXOp, Sym2, Type1, Sym1, FALSE)    (* Sym2 := *Sym1 *)
-      ELSE
-         PutLeftValueFrontBackType (Sym2, Type2, NulSym) ;
-         GenQuadO (ptrtok, BecomesOp, Sym2, NulSym, Sym1, FALSE) (* Sym2 :=  Sym1 *)
-      END ;
-      PutVarPointerCheck (Sym2, TRUE) ;       (* we should check this for *)
-                                     (* Sym2 later on (pointer via NIL)   *)
-      combinedtok := MakeVirtualTok (exprtok, exprtok, ptrtok) ;
-      PushTFrwtok (Sym2, Type2, rw, combinedtok) ;
-      DebugLocation (combinedtok, "pointer expression")
    ELSE
-      MetaError2 ('{%1ad} is not a pointer type but a {%2d}', Sym1, Type1)
+      combinedtok := MakeVirtual2Tok (destok, ptrtok) ;
+      IF IsPointer (Type1)
+      THEN
+         Type2 := GetSType (Type1) ;
+         Sym2 := MakeTemporary (ptrtok, LeftValue) ;
+         (*
+          Ok must reference by address
+          - but we contain the type of the referenced entity
+         *)
+         MarkAsRead (rw) ;
+         PutVarPointerCheck (Sym1, TRUE) ;
+         CheckPointerThroughNil (ptrtok, Sym1) ;
+         IF GetMode (Sym1) = LeftValue
+         THEN
+            rw := NulSym ;
+            PutLeftValueFrontBackType (Sym2, Type2, Type1) ;
+            GenQuadO (ptrtok, IndrXOp, Sym2, Type1, Sym1, FALSE)    (* Sym2 := *Sym1.  *)
+         ELSE
+            PutLeftValueFrontBackType (Sym2, Type2, NulSym) ;
+            GenQuadO (ptrtok, BecomesOp, Sym2, NulSym, Sym1, FALSE) (* Sym2 :=  Sym1.  *)
+         END ;
+         (* We should check this for Sym2 later on (pointer via NIL).   *)
+         PutVarPointerCheck (Sym2, TRUE) ;
+         PushTFrwtok (Sym2, Type2, rw, combinedtok) ;
+         DebugLocation (combinedtok, "pointer expression")
+      ELSIF IsHiddenType (Type1) AND (GetModuleScope (Type1) # GetCurrentModuleScope ())
+      THEN
+         MetaErrorT1 (ptrtok,
+                      '{%1Ead} is declared with an opaque type from a different module and cannot be dereferenced',
+                      Sym1) ;
+         MarkAsRead (rw) ;
+         BuildDesignatorPointerError (Type1, rw, combinedtok, 'bad opaque pointer dereference')
+      ELSE
+         MetaError2 ('{%1Ead} is not a pointer type but a {%2d}', Sym1, Type1) ;
+         MarkAsRead (rw) ;
+         BuildDesignatorPointerError (Type1, rw, combinedtok, 'bad pointer dereference')
+      END
    END
 END BuildDesignatorPointer ;
 

gcc/m2/gm2-compiler/P3Build.bnf

@@ -54,7 +54,7 @@ FROM DynamicStrings IMPORT String, InitString, KillString, Mark, ConCat, ConCatC
 FROM M2Printf IMPORT printf0, printf1 ;
 FROM M2Debug IMPORT Assert ;
 FROM P2SymBuild IMPORT BuildString, BuildNumber ;
-FROM M2MetaError IMPORT MetaErrorT0 ;
+FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT2 ;
 FROM M2CaseList IMPORT ElseCase ;
 
 FROM M2Reserved IMPORT tokToTok, toktype,
@@ -1085,15 +1085,14 @@ SubDesignator := "."                                                       % VAR
                                                                                 n1 := GetSymName(Sym) ;
                                                                                 IF IsModuleKnown(GetSymName(Sym))
                                                                                 THEN
-                                                                                   WriteFormat2('%a looks like a module which has not been globally imported (eg. suggest that you IMPORT %a ;)',
+                                                                                   WriteFormat2('%a looks like a module which has not been globally imported (eg. suggest that you IMPORT %a)',
                                                                                    n1, n1)
                                                                                 ELSE
                                                                                    WriteFormat1('%a is not a record variable', n1)
                                                                                 END
                                                                              ELSIF NOT IsRecord(Type)
                                                                              THEN
-                                                                                n1 := GetSymName(Type) ;
-                                                                                WriteFormat1('%a is not a record type', n1)
+                                                                                MetaErrorT2 (tok, "the type of {%1ad} is not a record (but {%2ad}) and therefore it has no field", Sym, Type) ;
                                                                              END ;
                                                                              StartScope(Type) %
                  Ident

gcc/testsuite/gm2.dg/pim/fail/badopaque.mod

@@ -0,0 +1,15 @@
+
+(* { dg-do compile } *)
+(* { dg-options "-g" } *)
+
+MODULE badopaque ;  
+
+FROM opaquedefs IMPORT OpaqueA ;
+
+VAR
+   a: OpaqueA ;
+   c: CARDINAL ;
+BEGIN
+   c := 123 ;
+   a^ := c     (* { dg-error "with an opaque type" }  *)
+END badopaque.

gcc/testsuite/gm2.dg/pim/fail/badopaque2.mod

@@ -0,0 +1,17 @@
+
+(* { dg-do compile } *)
+(* { dg-options "-g" } *)
+
+MODULE badopaque2 ;  
+
+FROM opaquedefs IMPORT OpaqueB ;
+
+VAR
+   b: OpaqueB ;
+   c: CARDINAL ;
+BEGIN
+   c := 123 ;
+   b^.width := c  (* { dg-bogus "unnamed" } *)
+   (* { dg-error "cannot be dereferenced" "b^.width" { target *-*-* } 14 } *)   
+   (* { dg-error "has no field" "no field" { target *-*-* } 14 } *)   
+END badopaque2.

gcc/testsuite/gm2.dg/pim/fail/dg-pim-fail.exp

@@ -0,0 +1,34 @@
+# Copyright (C) 2025 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+# 
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+# 
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+
+# Compile tests, no torture testing.
+#
+# These tests raise errors in the front end; torture testing doesn't apply.
+
+# Load support procs.
+load_lib gm2-dg.exp
+
+gm2_init_pim4 $srcdir/$subdir
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+
+dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] "" ""
+
+# All done.
+dg-finish

gcc/testsuite/gm2.dg/pim/fail/opaquedefs.def

@@ -0,0 +1,7 @@
+DEFINITION MODULE opaquedefs ;  
+
+TYPE
+   OpaqueA ;
+   OpaqueB ;   
+
+END opaquedefs.

gcc/testsuite/gm2.dg/pim/fail/opaquedefs.mod

@@ -0,0 +1,13 @@
+(* { dg-do compile } *)
+(* { dg-options "-g -c" } *)
+
+IMPLEMENTATION MODULE opaquedefs ;
+
+TYPE
+   OpaqueA = POINTER TO CARDINAL ;
+   OpaqueB = POINTER TO RECORD
+                           width : CARDINAL ;
+                           height: CARDINAL ;
+                        END ;
+
+END opaquedefs.

gcc/testsuite/lib/gm2-dg.exp

@@ -15,6 +15,7 @@
 # <http://www.gnu.org/licenses/>.
 
 load_lib gcc-dg.exp
+load_lib gm2.exp
 
 # Define gm2 callbacks for dg.exp.
 
@@ -75,3 +76,4 @@ proc gm2-dg-runtest { testcases flags default-extra-flags } {
 	}
     }
 }
+