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 <gaiusmod2@gmail.com>

diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod
index 11874861e66dcdcaa6842717a3d85baaf3752fcd..22bc77f6ad00c416181b460145282653430d0af3 100644 (file)
--- a/gcc/m2/gm2-compiler/M2MetaError.mod
+++ b/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')

diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index fd3482b1f2d2e7277451a381668e0473dd72a2d6..785a6e9885a8a5d5b51ffde5361a0dce868c857c 100644 (file)
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/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 ;
 

diff --git a/gcc/m2/gm2-compiler/P3Build.bnf b/gcc/m2/gm2-compiler/P3Build.bnf
index b68f3e1192c6403f67791097de0b4ec1545fb6a7..d181f2381dfb5ca82052beb8b3e128acb68fc47b 100644 (file)
--- a/gcc/m2/gm2-compiler/P3Build.bnf
+++ b/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

diff --git a/gcc/testsuite/gm2.dg/pim/fail/badopaque.mod b/gcc/testsuite/gm2.dg/pim/fail/badopaque.mod
new file mode 100644 (file)
index 0000000..1d67bf9
--- /dev/null
+++ b/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.

diff --git a/gcc/testsuite/gm2.dg/pim/fail/badopaque2.mod b/gcc/testsuite/gm2.dg/pim/fail/badopaque2.mod
new file mode 100644 (file)
index 0000000..80f9324
--- /dev/null
+++ b/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.

diff --git a/gcc/testsuite/gm2.dg/pim/fail/dg-pim-fail.exp b/gcc/testsuite/gm2.dg/pim/fail/dg-pim-fail.exp
new file mode 100644 (file)
index 0000000..09ea4f7
--- /dev/null
+++ b/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

diff --git a/gcc/testsuite/gm2.dg/pim/fail/opaquedefs.def b/gcc/testsuite/gm2.dg/pim/fail/opaquedefs.def
new file mode 100644 (file)
index 0000000..3432a65
--- /dev/null
+++ b/gcc/testsuite/gm2.dg/pim/fail/opaquedefs.def
@@ -0,0 +1,7 @@
+DEFINITION MODULE opaquedefs ;  
+
+TYPE
+   OpaqueA ;
+   OpaqueB ;   
+
+END opaquedefs.

diff --git a/gcc/testsuite/gm2.dg/pim/fail/opaquedefs.mod b/gcc/testsuite/gm2.dg/pim/fail/opaquedefs.mod
new file mode 100644 (file)
index 0000000..7c25329
--- /dev/null
+++ b/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.

diff --git a/gcc/testsuite/lib/gm2-dg.exp b/gcc/testsuite/lib/gm2-dg.exp
index 62081f8632528990e803ee6437e0bed31386e971..eaed554014f8fbe26e1f66ceefe70ab74ed8b9bb 100644 (file)
--- a/gcc/testsuite/lib/gm2-dg.exp
+++ b/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 } {
        }
     }
 }
+