PR modula2/119914 No error message generated when passing a Ztype to an unbounded...

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>

diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index 528c51deaf36429c01e173d0b92def9aa50a67bf..d86ef8e886566d1925432607e31f4f484164b56f 100644 (file)
--- 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 9bb8c4d35a64d855fad5cf19bf9665e205f2229b..4022657189742dc417043f4fd5fe0d75e80eb02a 100644 (file)
--- 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 2a5bfabecd1ca7acc4d3298020afa00476b1f2e1..8e3943ae11c2801c619ff248ff61989518bb87c7 100644 (file)
--- 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 85a36727c6ed4f8e3d67508b8f88bc5080933b30..2a9865add94a3bced753688a2542f4dd44a59d13 100644 (file)
--- 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 826d2d39de10fae42d7c4f1e1c66512fd13cac9e..551bbecc788670ae8c92726ff7d3eb3f37933480 100644 (file)
--- 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 (file)
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.