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

6 files changed, 217 insertions, 20 deletions

diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index 528c51d..d86ef8e 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 9bb8c4d..4022657 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 2a5bfab..8e3943a 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 85a3672..2a9865a 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 826d2d3..551bbec 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) ;
@@ -6926,6 +6954,89 @@ 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 0000000..cbcc804
--- /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.