modula2: detect string and pointer formal and actual parameter incompatibility

This patch improves the location accuracy of parameters and fixes bugs
in parameter checking in M2Check.  It also corrects the location
of constant declarations.

gcc/m2/ChangeLog:

	* gm2-compiler/M2Check.mod (dumpIndice): New procedure.
	(dumpIndex): New procedure.
	(dumptInfo): New procedure.
	(buildError4): Add comment and pass formal and actual to
	MetaError4.  Improve text describing error.
	(buildError2): Generate different error descriptions for
	the three error kinds.
	(checkConstMeta): Add block comment.  Add more meta checks
	and call doCheckPair to complete string const checking.
	Add tinfo parameter.
	(checkConstEquivalence): Add tinfo parameter.
	* gm2-compiler/M2GCCDeclare.mod (PrintVerboseFromList):
	Print the length of a const string.
	* gm2-compiler/M2GenGCC.mod (CodeParam): Remove parameters
	op1, op2 and op3.
	(doParam): Add paramtok parameter.  Use paramtok instead rather
	than CurrentQuadToken.
	(CodeParam): Rewrite.
	* gm2-compiler/M2Quads.mod (CheckProcedureParameters):
	Add comments explaining that const strings are not checked
	in M2Quads.mod.
	(FailParameter): Use MetaErrorT2 with tokpos rather than
	MetaError2.
	(doBuildBinaryOp): Assign OldPos and OperatorPos before the
	IF block.
	* gm2-compiler/SymbolTable.mod (PutConstString): Add call to
	InitWhereDeclaredTok.

gcc/testsuite/ChangeLog:

	* gm2/pim/fail/badpointer4.mod: New test.
	* gm2/pim/fail/strconst.def: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

5 files changed, 143 insertions, 61 deletions

diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index d456081..a296766 100644
--- a/gcc/m2/gm2-compiler/M2Check.mod
+++ b/gcc/m2/gm2-compiler/M2Check.mod
@@ -33,8 +33,8 @@ IMPLEMENTATION MODULE M2Check ;
 *)
 
 FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ;
-FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType ;
-FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex ;
+FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType, Char ;
+FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex, ForeachIndiceInIndexDo ;
 FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
 FROM M2MetaError IMPORT MetaErrorStringT2, MetaErrorStringT3, MetaErrorStringT4, MetaString2, MetaString3, MetaString4 ;
 FROM StrLib IMPORT StrEqual ;
@@ -48,6 +48,7 @@ FROM SymbolConversion IMPORT Mod2Gcc ;
 FROM DynamicStrings IMPORT String, InitString, KillString ;
 FROM M2LexBuf IMPORT GetTokenNo ;
 FROM Storage IMPORT ALLOCATE ;
+FROM SYSTEM IMPORT ADR ;
 FROM libc IMPORT printf ;
 
 
@@ -102,6 +103,52 @@ VAR
 
 
 (*
+   dumpIndice -
+*)
+
+PROCEDURE dumpIndice (ptr: pair) ;
+BEGIN
+   printf (" left (%d), right (%d), status ",
+           ptr^.left, ptr^.right);
+   CASE ptr^.pairStatus OF
+
+   true   :  printf ("true") |
+   false  :  printf ("false") |
+   unknown:  printf ("unknown") |
+   visited:  printf ("visited") |
+   unused :  printf ("unused")
+
+   END ;
+   printf ("\n")
+END dumpIndice ;
+
+
+(*
+   dumpIndex -
+*)
+
+PROCEDURE dumpIndex (name: ARRAY OF CHAR; index: Index) ;
+BEGIN
+   printf ("status: %s\n", ADR (name)) ;
+   ForeachIndiceInIndexDo (index, dumpIndice)
+END dumpIndex ;
+
+
+(*
+   dumptInfo -
+*)
+
+PROCEDURE dumptInfo (t: tInfo) ;
+BEGIN
+   printf ("actual (%d), formal (%d), left (%d), right (%d), procedure (%d)\n",
+           t^.actual, t^.formal, t^.left, t^.right, t^.procedure) ;
+   dumpIndex ('visited', t^.visited) ;
+   dumpIndex ('resolved', t^.resolved) ;
+   dumpIndex ('unresolved', t^.unresolved)
+END dumptInfo ;
+
+
+(*
    isKnown - returns BOOLEAN:TRUE if result is status:true or status:false.
 *)
 
@@ -283,7 +330,8 @@ END firstTime ;
 
 
 (*
-   buildError4 -
+   buildError4 - generate a MetaString4 error.  This is only used when checking
+                 parameter compatibility.
 *)
 
 PROCEDURE buildError4 (tinfo: tInfo; left, right: CARDINAL) ;
@@ -300,7 +348,7 @@ BEGIN
             of paramters passed to ParameterTypeCompatible.  *)
          s := MetaString4 (tinfo^.format,
                            tinfo^.procedure,
-                           tinfo^.left, tinfo^.right,
+                           tinfo^.formal, tinfo^.actual,
                            tinfo^.nth) ;
          ErrorString (tinfo^.error, s)
       END ;
@@ -308,7 +356,8 @@ BEGIN
       IF (left # tinfo^.left) OR (right # tinfo^.right)
       THEN
          tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
-         s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
+         s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible as formal and actual procedure parameters"),
+                           left, right) ;
          ErrorString (tinfo^.error, s)
       END
    END
@@ -316,7 +365,7 @@ END buildError4 ;
 
 
 (*
-   buildError2 -
+   buildError2 - generate a MetaString2 error.  This is called by all three kinds of errors.
 *)
 
 PROCEDURE buildError2 (tinfo: tInfo; left, right: CARDINAL) ;
@@ -327,17 +376,26 @@ BEGIN
    THEN
       IF tinfo^.error = NIL
       THEN
-         (* need to create top level error message first.  *)
+         (* Need to create top level error message first.  *)
          tinfo^.error := NewError (tinfo^.token) ;
          s := MetaString2 (tinfo^.format,
                            tinfo^.left, tinfo^.right) ;
          ErrorString (tinfo^.error, s)
       END ;
-      (* and also generate a sub error containing detail.  *)
+      (* Also generate a sub error containing detail.  *)
       IF (left # tinfo^.left) OR (right # tinfo^.right)
       THEN
          tinfo^.error := ChainError (tinfo^.token, tinfo^.error) ;
-         s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible in this context"), left, right) ;
+         CASE tinfo^.kind OF
+
+         parameter:  s := MetaString2 (InitString ("{%1Ead} and {%2ad} are incompatible as formal and actual procedure parameters"),
+                                       left, right) |
+         assignment: s := MetaString2 (InitString ("{%1Ead} and {%2ad} are assignment incompatible"),
+                                       left, right) |
+         expression: s := MetaString2 (InitString ("{%1Ead} and {%2ad} are expression incompatible"),
+                                       left, right)
+
+         END ;
          ErrorString (tinfo^.error, s)
       END
    END
@@ -548,11 +606,13 @@ END checkVarEquivalence ;
 
 
 (*
-   checkConstMeta -
+   checkConstMeta - performs a very course grained check against
+                    obviously incompatible type kinds.
+                    If left is a const string then it checks right against char.
 *)
 
-PROCEDURE checkConstMeta  (result: status;
-                           left, right: CARDINAL) : status ;
+PROCEDURE checkConstMeta (result: status; tinfo: tInfo;
+                          left, right: CARDINAL) : status ;
 VAR
    typeRight: CARDINAL ;
 BEGIN
@@ -566,9 +626,12 @@ BEGIN
       IF typeRight = NulSym
       THEN
          RETURN result
-      ELSIF IsSet (typeRight) OR IsEnumeration (typeRight)
+      ELSIF IsSet (typeRight) OR IsEnumeration (typeRight) OR IsProcedure (typeRight) OR
+            IsRecord (typeRight)
       THEN
          RETURN false
+      ELSE
+         RETURN doCheckPair (result, tinfo, Char, typeRight)
       END
    END ;
    RETURN result
@@ -583,7 +646,7 @@ END checkConstMeta ;
                            early on.  For example adding a string to an enum or set.
 *)
 
-PROCEDURE checkConstEquivalence (result: status;
+PROCEDURE checkConstEquivalence (result: status; tinfo: tInfo;
                                  left, right: CARDINAL) : status ;
 BEGIN
    IF isFalse (result)
@@ -595,10 +658,10 @@ BEGIN
       RETURN true
    ELSIF IsConst (left)
    THEN
-      RETURN checkConstMeta (result, left, right)
+      RETURN checkConstMeta (result, tinfo, left, right)
    ELSIF IsConst (right)
    THEN
-      RETURN checkConstMeta (result, right, left)
+      RETURN checkConstMeta (result, tinfo, right, left)
    END ;
    RETURN result
 END checkConstEquivalence ;
@@ -715,7 +778,7 @@ BEGIN
    THEN
       RETURN return (true, tinfo, left, right)
    ELSE
-      result := checkConstEquivalence (unknown, left, right) ;
+      result := checkConstEquivalence (unknown, tinfo, left, right) ;
       IF NOT isKnown (result)
       THEN
          result := checkVarEquivalence (unknown, tinfo, left, right) ;
@@ -1320,10 +1383,15 @@ VAR
    result     : status ;
    left, right: CARDINAL ;
 BEGIN
+   IF debugging
+   THEN
+      dumptInfo (tinfo)
+   END ;
    WHILE get (tinfo^.unresolved, left, right, unknown) DO
       IF debugging
       THEN
-         printf ("doCheck (%d, %d)\n", left, right)
+         printf ("doCheck (%d, %d)\n", left, right) ;
+         dumptInfo (tinfo)
       END ;
       (*
       IF in (tinfo^.visited, left, right)
@@ -1561,6 +1629,10 @@ BEGIN
    tinfo^.strict := FALSE ;
    tinfo^.isin := FALSE ;
    include (tinfo^.unresolved, actual, formal, unknown) ;
+   IF debugging
+   THEN
+      dumptInfo (tinfo)
+   END ;
    IF doCheck (tinfo)
    THEN
       deconstruct (tinfo) ;
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 643374d..dae5a6b 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -4060,6 +4060,7 @@ END PrintProcedure ;
 
 PROCEDURE PrintVerboseFromList (l: List; i: CARDINAL) ;
 VAR
+   len,
    type,
    low,
    high,
@@ -4227,7 +4228,9 @@ BEGIN
          ELSIF IsConstStringCnul (sym)
          THEN
             printf0(' a nul terminated C string')
-         END
+         END ;
+         len := GetStringLength (sym) ;
+         printf1(' length %d', len)
       ELSIF IsConstructor(sym)
       THEN
          printf0(' constant constructor ') ;
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index ced4724..92ca39f 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -520,7 +520,7 @@ BEGIN
    IndrXOp            : CodeIndrX (q, op1, op2, op3) |
    XIndrOp            : CodeXIndr (q) |
    CallOp             : CodeCall (CurrentQuadToken, op3) |
-   ParamOp            : CodeParam (q, op1, op2, op3) |
+   ParamOp            : CodeParam (q) |
    FunctValueOp       : CodeFunctValue (location, op1) |
    AddrOp             : CodeAddr (q, op1, op3) |
    SizeOp             : CodeSize (op1, op3) |
@@ -2376,14 +2376,14 @@ END FoldMakeAdr ;
              procedure, op2.  The number of the parameter is op1.
 *)
 
-PROCEDURE doParam (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE doParam (quad: CARDINAL; paramtok: CARDINAL; op1, op2, op3: CARDINAL) ;
 VAR
    location: location_t ;
 BEGIN
-   location := TokenToLocation (CurrentQuadToken) ;
-   DeclareConstant (CurrentQuadToken, op3) ;
-   DeclareConstructor (CurrentQuadToken, quad, op3) ;
-   BuildParam (location, CheckConvertCoerceParameter (CurrentQuadToken, op1, op2, op3))
+   location := TokenToLocation (paramtok) ;
+   DeclareConstant (paramtok, op3) ;
+   DeclareConstructor (paramtok, quad, op3) ;
+   BuildParam (location, CheckConvertCoerceParameter (paramtok, op1, op2, op3))
 END doParam ;
 
 
@@ -2433,7 +2433,7 @@ BEGIN
       REPEAT
          IF (op=ParamOp) AND (op1>0)
          THEN
-            doParam(n, op1, op2, op3)
+            doParam (tokenno, n, op1, op2, op3)
          ELSIF op=CallOp
          THEN
             procedure := op3
@@ -2499,8 +2499,21 @@ END FoldBuiltinFunction ;
                NOTE that we CAN ignore ModeOfAddr though
 *)
 
-PROCEDURE CodeParam (quad: CARDINAL; nth, procedure, parameter: CARDINAL) ;
+PROCEDURE CodeParam (quad: CARDINAL) ;
+VAR
+   nopos,
+   procedure,
+   parameter,
+   parampos  : CARDINAL ;
+   nth       : CARDINAL ;
+   compatible,
+   overflow  : BOOLEAN ;
+   op        : QuadOperator ;
 BEGIN
+   GetQuadOtok (quad, parampos, op,
+                nth, procedure, parameter, overflow,
+                nopos, nopos, nopos) ;
+   compatible := TRUE ;
    IF nth=0
    THEN
       CodeBuiltinFunction (quad, nth, procedure, parameter)
@@ -2509,41 +2522,27 @@ BEGIN
       THEN
          IF (nth <= NoOfParam (procedure))
          THEN
-            IF IsVarParam (procedure, nth) AND
-               (NOT ParameterTypeCompatible (CurrentQuadToken,
-                                             'parameter incompatibility when attempting to pass actual parameter {%2ad} to a {%kVAR} formal parameter {%3Ead} during call to procedure {%1ad}',
-                                             procedure, GetNthParam (procedure, nth), parameter, nth, TRUE))
-            THEN
-
-            ELSIF (NOT IsVarParam (procedure, nth)) AND
-               (NOT ParameterTypeCompatible (CurrentQuadToken,
-                                             'parameter incompatibility when attempting to pass actual parameter {%3Ead} to the {%4EN} formal parameter {%2ad} during call to procedure {%1ad}',
-                                             procedure, GetNthParam (procedure, nth), parameter, nth, FALSE))
-            THEN
-               (* use the AssignmentTypeCompatible as the rules are for assignment for non var parameters.  *)
-            ELSE
-               (* doParam (quad, nth, procedure, parameter) *)    (* --fixme--  enable when M2Check works.  *)
-            END
+            compatible := ParameterTypeCompatible (parampos,
+                                                   'parameter incompatibility when attempting to pass actual parameter {%2ad} to a {%kVAR} formal parameter {%3Ead} during call to procedure {%1ad}',
+                                                   procedure, GetNthParam (procedure, nth),
+                                                   parameter, nth, IsVarParam (procedure, nth))
          END
-      ELSE
-         (* doParam (quad, nth, procedure, parameter)     *)    (* --fixme--  enable when M2Check works.  *)
       END ;
 
-      (* --fixme  remove B EGIN  *)
       IF (nth <= NoOfParam (procedure)) AND
          IsVarParam (procedure, nth) AND IsConst (parameter)
       THEN
-         MetaErrorT1 (CurrentQuadToken,
+         MetaErrorT1 (parampos,
                       'cannot pass a constant {%1Ead} as a VAR parameter', parameter)
       ELSIF IsAModula2Type (parameter)
       THEN
-         MetaErrorT2 (CurrentQuadToken,
+         MetaErrorT2 (parampos,
                       'cannot pass a type {%1Ead} as a parameter to procedure {%2ad}',
                       parameter, procedure)
-      ELSE
-         doParam (quad, nth, procedure, parameter)
+      ELSIF compatible
+      THEN
+         doParam (quad, parampos, nth, procedure, parameter)
       END
-      (* --fixme  remove E ND  once M2Check works.  *)
    END
 END CodeParam ;
 
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 45e2769..a666a4e 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -3606,7 +3606,6 @@ BEGIN
       PopTrwtok (Des, w, destok) ;
       MarkAsWrite (w) ;
       CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
-      combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
       IF DebugTokPos
       THEN
          MetaErrorT1 (becomesTokNo, 'becomestok {%1Oad}', Des) ;
@@ -3629,7 +3628,7 @@ BEGIN
          CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
       END ;
       (* Simple assignment.  *)
-      MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ;
+      MoveWithMode (combinedtok, Des, Exp, Array, destok, exptok, checkOverflow) ;
       IF checkTypes
       THEN
          (*
@@ -5428,13 +5427,14 @@ BEGIN
                               Actual, FormalI, Proc, i)
             ELSIF IsConstString (Actual)
             THEN
-               IF (GetStringLength (Actual) = 0)   (* if = 0 then it maybe unknown at this time *)
+               IF (GetStringLength (Actual) = 0)   (* If = 0 then it maybe unknown at this time.  *)
                THEN
-                  (* dont check this yet *)
+                  (* We dont check this yet, it is checked in M2GenGCC.mod:CodeParam
+                     after the string has been created.  *)
                ELSIF IsArray(GetDType(FormalI)) AND (GetSType(GetDType(FormalI))=Char)
                THEN
-                  (* allow string literals to be passed to ARRAY [0..n] OF CHAR *)
-               ELSIF (GetStringLength(Actual) = 1)   (* if = 1 then it maybe treated as a char *)
+                  (* Allow string literals to be passed to ARRAY [0..n] OF CHAR.  *)
+               ELSIF (GetStringLength(Actual) = 1)   (* If = 1 then it maybe treated as a char.  *)
                THEN
                   CheckParameter (paramtok, Actual, Dim, FormalI, Proc, i, NIL)
                ELSIF NOT IsUnboundedParam(Proc, i)
@@ -5864,8 +5864,9 @@ VAR
    ExpectType: CARDINAL ;
    s, s1, s2 : String ;
 BEGIN
-   MetaError2 ('parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
-               ProcedureSym, ParameterNo) ;
+   MetaErrorT2 (tokpos,
+                'parameter mismatch between the {%2N} parameter of procedure {%1Ead}',
+                ProcedureSym, ParameterNo) ;
    s := InitString ('{%kPROCEDURE} {%1Eau} (') ;
    IF NoOfParam(ProcedureSym)>=ParameterNo
    THEN
@@ -5905,7 +5906,13 @@ BEGIN
    s := ConCat (s, Mark (InitString ('){%1Tau:% : {%1Tau}} ;'))) ;
    MetaErrorStringT1 (First, Dup (s), ProcedureSym) ;
    MetaErrorStringT1 (tokpos, s, ProcedureSym) ;
-   MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dtsd}', Given)
+   IF GetLType (Given) = NulSym
+   THEN
+      MetaError1 ('item being passed is {%1EDda} {%1Dad}', Given)
+   ELSE
+      MetaError1 ('item being passed is {%1EDda} {%1Dad} of type {%1Dts}',
+                  Given)
+   END
 END FailParameter ;
 
 
@@ -12461,6 +12468,8 @@ BEGIN
       ELSE
          (* CheckForGenericNulSet(e1, e2, t1, t2) *)
       END ;
+      OldPos := OperatorPos ;
+      OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
       IF (Operator = PlusTok) AND IsConstString(left) AND IsConstString(right)
       THEN
          (* handle special addition for constant strings *)
@@ -12469,8 +12478,6 @@ BEGIN
          value := MakeConstLitString (OperatorPos, makekey (string (s))) ;
          s := KillString (s)
       ELSE
-         OldPos := OperatorPos ;
-         OperatorPos := MakeVirtualTok (OperatorPos, leftpos, rightpos) ;
          IF checkTypes
          THEN
             BuildRange (InitTypesExpressionCheck (OperatorPos, left, right, FALSE, FALSE))
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index e219980..d939d58 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -5373,6 +5373,7 @@ BEGIN
 
       ConstStringSym: ConstString.Length := LengthKey (contents) ;
                       ConstString.Contents := contents ;
+                      InitWhereDeclaredTok (tok, ConstString.At) ;
                       InitWhereFirstUsedTok (tok, ConstString.At) |
 
       ConstVarSym   : (* ok altering this to ConstString *)