https://gcc.gnu.org/g:e9a81addd5b7d018e173fa8d59aafc2f84e41d8b
commit r16-104-ge9a81addd5b7d018e173fa8d59aafc2f84e41d8b
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Thu Apr 24 02:39:36 2025 +0100
PR modula2/119914 No error message generated when passing a Ztype to an
unbounded array
This patch detects constants ZType, RType, CType being passed to unbounded
arrays and generates an error message highlighting the formal and
actual parameters in error.
gcc/m2/ChangeLog:
PR modula2/119914
* gm2-compiler/M2Check.mod (checkConstMeta): Add check for
Ztype, Rtype and Ctype and unbounded arrays.
(IsZRCType): New procedure function.
(isZRC): Add comment.
* gm2-compiler/M2Quads.mod:
* gm2-compiler/M2Range.mod (gdbinit): New procedure.
(BreakWhenRangeCreated): Ditto.
(CheckBreak): Ditto.
(InitRange): Call CheckBreak.
(Init): Add gdbhook and initialize interactive watch point.
* gm2-compiler/SymbolTable.def (GetNthParamAnyClosest): New
procedure function.
* gm2-compiler/SymbolTable.mod (BreakSym): Remove constant.
(BreakSym): Add Variable.
(stop): Remove.
(gdbhook): New procedure.
(BreakWhenSymCreated): Ditto.
(CheckBreak): Ditto.
(NewSym): Call CheckBreak.
(Init): Add gdbhook and initialize interactive watch point.
(MakeProcedure): Replace guarded call to stop with CheckBreak.
(GetNthParamChoice): New procedure function.
(GetNthParamOrdered): Ditto.
(GetNthParamAnyClosest): Ditto.
(GetOuterModuleScope): Ditto.
gcc/testsuite/ChangeLog:
PR modula2/119914
* gm2/pim/fail/constintarraybyte.mod: New test.
Signed-off-by: Gaius Mulley <gaiusm...@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2Check.mod | 21 +++-
gcc/m2/gm2-compiler/M2Quads.mod | 10 +-
gcc/m2/gm2-compiler/M2Range.mod | 43 ++++++-
gcc/m2/gm2-compiler/SymbolTable.def | 16 +++
gcc/m2/gm2-compiler/SymbolTable.mod | 137 ++++++++++++++++++++---
gcc/testsuite/gm2/pim/fail/constintarraybyte.mod | 10 ++
6 files changed, 217 insertions(+), 20 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index 528c51deaf36..d86ef8e88656 100644
--- a/gcc/m2/gm2-compiler/M2Check.mod
+++ b/gcc/m2/gm2-compiler/M2Check.mod
@@ -803,7 +803,12 @@ BEGIN
THEN
typeRight := GetDType (right) ;
typeLeft := GetDType (left) ;
- RETURN doCheckPair (result, tinfo, typeLeft, typeRight)
+ IF IsZRCType (typeLeft) AND IsUnbounded (typeRight)
+ THEN
+ RETURN false
+ ELSE
+ RETURN doCheckPair (result, tinfo, typeLeft, typeRight)
+ END
END ;
RETURN result
END checkConstMeta ;
@@ -868,7 +873,19 @@ END checkSubrangeTypeEquivalence ;
(*
- isZRC -
+ IsZRCType - return TRUE if type is a ZType, RType or a CType.
+*)
+
+PROCEDURE IsZRCType (type: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN (type = CType) OR (type = ZType) OR (type = RType)
+END IsZRCType ;
+
+
+(*
+ isZRC - return TRUE if zrc is a ZType, RType or a CType
+ and sym is either a complex type when zrc = CType
+ or is not a composite type when zrc is a RType or ZType.
*)
PROCEDURE isZRC (zrc, sym: CARDINAL) : BOOLEAN ;
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 9bb8c4d35a64..402265718974 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -69,6 +69,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode,
GetSymName, IsUnknown,
GetArraySubscript, GetDimension,
GetParam,
GetNth, GetNthParamAny,
+ GetNthParamAnyClosest,
GetFirstUsed, GetDeclaredMod,
GetQuads, GetReadQuads, GetWriteQuads,
GetWriteLimitQuads, GetReadLimitQuads,
@@ -5676,7 +5677,8 @@ BEGIN
WHILE i<=ParamTotal DO
IF i <= NoOfParamAny (Proc)
THEN
- FormalI := GetParam(Proc, i) ;
+ (* FormalI := GetParam(Proc, i) ; *)
+ FormalI := GetNthParamAnyClosest (Proc, i, GetCurrentModule ()) ;
IF CompilerDebugging
THEN
n1 := GetSymName(FormalI) ;
@@ -5801,7 +5803,7 @@ BEGIN
MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was
declared as a {%2d}', call, GetNth (call, i), i)
END ;
BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i,
- GetParam (CheckedProcedure, i),
+ GetNthParamAnyClosest
(CheckedProcedure, i, GetCurrentModule ()),
GetParam (ProcType, i),
ParamCheckId)) ;
INC(i)
END
@@ -6150,7 +6152,7 @@ BEGIN
MetaErrorStringT2 (tokpos, Msg, ProcedureSym, ParameterNo) ;
IF NoOfParamAny (ProcedureSym) >= ParameterNo
THEN
- FormalParam := GetNthParamAny (ProcedureSym, ParameterNo) ;
+ FormalParam := GetNthParamAnyClosest (ProcedureSym, ParameterNo,
GetCurrentModule ()) ;
IF IsUnboundedParamAny (ProcedureSym, ParameterNo)
THEN
MetaErrorT2 (GetVarDeclFullTok (FormalParam), 'formal parameter
{%1ad} has an open array type {%2tad}',
@@ -6205,7 +6207,7 @@ BEGIN
MetaErrorStringT2 (tokpos, Msg, ProcedureSym, ParameterNo) ;
IF NoOfParamAny (ProcedureSym) >= ParameterNo
THEN
- FormalParam := GetNthParamAny (ProcedureSym, ParameterNo) ;
+ FormalParam := GetNthParamAnyClosest (ProcedureSym, ParameterNo,
GetCurrentModule ()) ;
IF IsUnboundedParamAny (ProcedureSym, ParameterNo)
THEN
MetaErrorT2 (GetVarDeclFullTok (FormalParam), '{%W}formal parameter
{%1ad} has an open array type {%2tad}',
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index 2a5bfabecd1c..8e3943ae11c2 100644
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -154,6 +154,34 @@ TYPE
VAR
TopOfRange: CARDINAL ;
RangeIndex: Index ;
+ BreakRange: CARDINAL ;
+
+
+PROCEDURE gdbhook ;
+END gdbhook ;
+
+
+(*
+ BreakWhenRangeCreated - to be called interactively by gdb.
+*)
+
+PROCEDURE BreakWhenRangeCreated (r: CARDINAL) ;
+BEGIN
+ BreakRange := r
+END BreakWhenRangeCreated ;
+
+
+(*
+ CheckBreak - if sym = BreakRange then call gdbhook.
+*)
+
+PROCEDURE CheckBreak (r: CARDINAL) ;
+BEGIN
+ IF BreakRange = r
+ THEN
+ gdbhook
+ END
+END CheckBreak ;
(*
@@ -302,6 +330,7 @@ BEGIN
THEN
InternalError ('out of memory error')
ELSE
+ CheckBreak (r) ;
WITH p^ DO
type := none ;
des := NulSym ;
@@ -3746,7 +3775,19 @@ END WriteRangeCheck ;
PROCEDURE Init ;
BEGIN
TopOfRange := 0 ;
- RangeIndex := InitIndex(1)
+ RangeIndex := InitIndex(1) ;
+ BreakWhenRangeCreated (0) ; (* Disable the intereactive range watch. *)
+ (* To examine the range when it is created run cc1gm2 from gdb
+ and set a break point on gdbhook.
+ (gdb) break gdbhook
+ (gdb) run
+ Now below interactively call BreakWhenRangeCreated with the symbol
+ under investigation. *)
+ gdbhook ;
+ (* Now is the time to interactively call gdb, for example:
+ (gdb) print BreakWhenRangeCreated (1234)
+ (gdb) cont
+ and you will arrive at gdbhook when this symbol is created. *)
END Init ;
diff --git a/gcc/m2/gm2-compiler/SymbolTable.def
b/gcc/m2/gm2-compiler/SymbolTable.def
index 85a36727c6ed..2a9865add94a 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.def
+++ b/gcc/m2/gm2-compiler/SymbolTable.def
@@ -3478,4 +3478,20 @@ PROCEDURE UsesOptArgAny (Sym: CARDINAL) : BOOLEAN ;
PROCEDURE GetProcedureKindDesc (kind: ProcedureKind) : String ;
+(*
+ GetNthParamAnyClosest - returns the nth parameter from the order
+ proper procedure, forward declaration
+ or definition module procedure.
+ It chooses the parameter which is closest
+ in source terms to currentmodule.
+ The same module will return using the order
+ proper procedure, forward procedure, definition
module.
+ Whereas an imported procedure will choose from
+ DefProcedure, ProperProcedure, ForwardProcedure.
+*)
+
+PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL;
+ currentmodule: CARDINAL) : CARDINAL ;
+
+
END SymbolTable.
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod
b/gcc/m2/gm2-compiler/SymbolTable.mod
index 826d2d39de10..551bbecc7886 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -122,8 +122,6 @@ CONST
UnboundedAddressName = "_m2_contents" ;
UnboundedHighName = "_m2_high_%d" ;
- BreakSym = 203 ;
-
TYPE
ProcAnyBoolean = PROCEDURE (CARDINAL, ProcedureKind) : BOOLEAN ;
ProcAnyCardinal = PROCEDURE (CARDINAL, ProcedureKind) : CARDINAL ;
@@ -930,6 +928,7 @@ VAR
(* passes and reduce duplicate *)
(* errors. *)
ConstLitArray : Indexing.Index ;
+ BreakSym : CARDINAL ; (* Allows interactive debugging. *)
(*
@@ -1032,11 +1031,34 @@ END FinalSymbol ;
(*
- stop - a debugger convenience hook.
+ gdbhook - a debugger convenience hook.
+*)
+
+PROCEDURE gdbhook ;
+END gdbhook ;
+
+
+(*
+ BreakWhenSymCreated - to be called interactively by gdb.
*)
-PROCEDURE stop ;
-END stop ;
+PROCEDURE BreakWhenSymCreated (sym: CARDINAL) ;
+BEGIN
+ BreakSym := sym
+END BreakWhenSymCreated ;
+
+
+(*
+ CheckBreak - if sym = BreakSym then call gdbhook.
+*)
+
+PROCEDURE CheckBreak (sym: CARDINAL) ;
+BEGIN
+ IF sym = BreakSym
+ THEN
+ gdbhook
+ END
+END CheckBreak ;
(*
@@ -1053,10 +1075,7 @@ BEGIN
SymbolType := DummySym
END ;
PutIndice(Symbols, sym, pSym) ;
- IF sym = BreakSym
- THEN
- stop
- END ;
+ CheckBreak (sym) ;
INC(FreeSymbol)
END NewSym ;
@@ -1660,6 +1679,18 @@ PROCEDURE Init ;
VAR
pCall: PtrToCallFrame ;
BEGIN
+ BreakWhenSymCreated (NulSym) ; (* Disable the intereactive sym watch. *)
+ (* To examine the symbol table when a symbol is created run cc1gm2 from gdb
+ and set a break point on gdbhook.
+ (gdb) break gdbhook
+ (gdb) run
+ Now below interactively call BreakWhenSymCreated with the symbol
+ under investigation. *)
+ gdbhook ;
+ (* Now is the time to interactively call gdb, for example:
+ (gdb) print BreakWhenSymCreated (1234)
+ (gdb) cont
+ and you will arrive at gdbhook when this symbol is created. *)
AnonymousName := 0 ;
CurrentError := NIL ;
InitTree (ConstLitPoolTree) ;
@@ -3959,10 +3990,7 @@ VAR
BEGIN
tok := CheckTok (tok, 'procedure') ;
Sym := DeclareSym(tok, ProcedureName) ;
- IF Sym = BreakSym
- THEN
- stop
- END ;
+ CheckBreak (Sym) ;
IF NOT IsError(Sym)
THEN
pSym := GetPsym(Sym) ;
@@ -6925,6 +6953,89 @@ BEGIN
END GetNthParamAny ;
+(*
+ GetNthParamChoice - returns the parameter definition from
+ sym:ParamNo:kind or NulSym.
+*)
+
+PROCEDURE GetNthParamChoice (sym: CARDINAL; ParamNo: CARDINAL;
+ kind: ProcedureKind) : CARDINAL ;
+BEGIN
+ IF GetProcedureParametersDefined (sym, kind)
+ THEN
+ RETURN GetNthParam (sym, kind, ParamNo)
+ ELSE
+ RETURN NulSym
+ END
+END GetNthParamChoice ;
+
+
+(*
+ GetNthParamOrdered - returns the parameter definition from list {a, b, c}
+ in order.
+ sym:ParamNo:{a,b,c} or NulSym.
+*)
+
+PROCEDURE GetNthParamOrdered (sym: CARDINAL; ParamNo: CARDINAL;
+ a, b, c: ProcedureKind) : CARDINAL ;
+VAR
+ param: CARDINAL ;
+BEGIN
+ param := GetNthParamChoice (sym, ParamNo, a) ;
+ IF param = NulSym
+ THEN
+ param := GetNthParamChoice (sym, ParamNo, b) ;
+ IF param = NulSym
+ THEN
+ param := GetNthParamChoice (sym, ParamNo, c)
+ END
+ END ;
+ RETURN param
+END GetNthParamOrdered ;
+
+
+(*
+ GetNthParamAnyClosest - returns the nth parameter from the order
+ proper procedure, forward declaration
+ or definition module procedure.
+ It chooses the parameter which is closest
+ in source terms to currentmodule.
+ The same module will return using the order
+ proper procedure, forward procedure, definition
module.
+ Whereas an imported procedure will choose from
+ DefProcedure, ProperProcedure, ForwardProcedure.
+*)
+
+PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL;
+ currentmodule: CARDINAL) : CARDINAL ;
+BEGIN
+ IF GetOuterModuleScope (currentmodule) = GetOuterModuleScope (sym)
+ THEN
+ (* Same module. *)
+ RETURN GetNthParamOrdered (sym, ParamNo,
+ ProperProcedure, ForwardProcedure,
DefProcedure)
+ ELSE
+ (* Procedure is imported. *)
+ RETURN GetNthParamOrdered (sym, ParamNo,
+ DefProcedure, ProperProcedure,
ForwardProcedure)
+ END
+END GetNthParamAnyClosest ;
+
+
+(*
+ GetOuterModuleScope - returns the outer module symbol scope for sym.
+*)
+
+PROCEDURE GetOuterModuleScope (sym: CARDINAL) : CARDINAL ;
+BEGIN
+ WHILE NOT (IsDefImp (sym) OR
+ (IsModule (sym) AND (GetScope (sym) = NulSym))) DO
+ sym := GetScope (sym)
+ END ;
+ RETURN sym
+END GetOuterModuleScope ;
+
+
(*
The Following procedures fill in the symbol table with the
symbol entities.
diff --git a/gcc/testsuite/gm2/pim/fail/constintarraybyte.mod
b/gcc/testsuite/gm2/pim/fail/constintarraybyte.mod
new file mode 100644
index 000000000000..cbcc80480a75
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/constintarraybyte.mod
@@ -0,0 +1,10 @@
+MODULE constintarraybyte ;
+
+FROM FormatStrings IMPORT Sprintf1 ;
+FROM DynamicStrings IMPORT String, InitString ;
+
+VAR
+ s: String ;
+BEGIN
+ s := Sprintf1 (InitString("abc%x\n"), 42)
+END constintarraybyte.
