https://gcc.gnu.org/g:7be54613e8a1b1080f0480cf061baa73317a26d3
commit r15-7200-g7be54613e8a1b1080f0480cf061baa73317a26d3
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Sat Jan 25 00:05:48 2025 +0000
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 <gaiusm...@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2MetaError.mod | 7 ++-
gcc/m2/gm2-compiler/M2Quads.mod | 90 ++++++++++++++++++---------
gcc/m2/gm2-compiler/P3Build.bnf | 7 +--
gcc/testsuite/gm2.dg/pim/fail/badopaque.mod | 15 +++++
gcc/testsuite/gm2.dg/pim/fail/badopaque2.mod | 17 +++++
gcc/testsuite/gm2.dg/pim/fail/dg-pim-fail.exp | 34 ++++++++++
gcc/testsuite/gm2.dg/pim/fail/opaquedefs.def | 7 +++
gcc/testsuite/gm2.dg/pim/fail/opaquedefs.mod | 13 ++++
gcc/testsuite/lib/gm2-dg.exp | 2 +
9 files changed, 157 insertions(+), 35 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod
b/gcc/m2/gm2-compiler/M2MetaError.mod
index 11874861e66d..22bc77f6ad00 100644
--- 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 fd3482b1f2d2..785a6e9885a8 100644
--- 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 b68f3e1192c6..d181f2381dfb 100644
--- 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
index 000000000000..1d67bf9e6817
--- /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
index 000000000000..80f9324d2404
--- /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
index 000000000000..09ea4f755102
--- /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
index 000000000000..3432a655be33
--- /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
index 000000000000..7c253292a2d2
--- /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 62081f863252..eaed554014f8 100644
--- 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 } {
}
}
}
+
