procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Gaius Mulley 2025-01-25 00:05:48 +00:00
parent 12b7220dc5
commit 7be54613e8
9 changed files with 157 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/m2/gm2-compiler/M2MetaError.mod
View file

@ -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')

90
gcc/m2/gm2-compiler/M2Quads.mod
View file

@ -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 ;

7
gcc/m2/gm2-compiler/P3Build.bnf
View file

@ -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

15
gcc/testsuite/gm2.dg/pim/fail/badopaque.mod Normal file
View file

@ -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.

17
gcc/testsuite/gm2.dg/pim/fail/badopaque2.mod Normal file
View file

@ -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.

34
gcc/testsuite/gm2.dg/pim/fail/dg-pim-fail.exp Normal file
View file

@ -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

7
gcc/testsuite/gm2.dg/pim/fail/opaquedefs.def Normal file
View file

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

13
gcc/testsuite/gm2.dg/pim/fail/opaquedefs.mod Normal file
View file

@ -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.

2
gcc/testsuite/lib/gm2-dg.exp
View file

@ -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 } {
}
}
}