From eb619490b01baa2fc2b5ee98d15516c4a2372e74 Mon Sep 17 00:00:00 2001 From: Gaius Mulley Date: Fri, 26 Jan 2024 19:04:48 +0000 Subject: [PATCH] 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 --- gcc/m2/gm2-compiler/M2Check.mod | 108 +++++++++++++++++---- gcc/m2/gm2-compiler/M2GCCDeclare.mod | 5 +- gcc/m2/gm2-compiler/M2GenGCC.mod | 61 ++++++------ gcc/m2/gm2-compiler/M2Quads.mod | 29 +++--- gcc/m2/gm2-compiler/SymbolTable.mod | 1 + gcc/testsuite/gm2/pim/fail/badpointer4.mod | 20 ++++ gcc/testsuite/gm2/pim/fail/strconst.def | 6 ++ 7 files changed, 169 insertions(+), 61 deletions(-) create mode 100644 gcc/testsuite/gm2/pim/fail/badpointer4.mod create mode 100644 gcc/testsuite/gm2/pim/fail/strconst.def diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index d4560819a5dc..a296766ba35c 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 ; @@ -101,6 +102,52 @@ VAR errors : Index ; +(* + 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 643374db0a64..dae5a6b34bd2 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 ced4724f4c0f..92ca39f71b58 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 45e2769af793..a666a4e3a5bd 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 e219980117e7..d939d581a640 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 *) diff --git a/gcc/testsuite/gm2/pim/fail/badpointer4.mod b/gcc/testsuite/gm2/pim/fail/badpointer4.mod new file mode 100644 index 000000000000..b5fb8ad89682 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badpointer4.mod @@ -0,0 +1,20 @@ +MODULE badpointer4 ; + +FROM DynamicStrings IMPORT String ; +FROM strconst IMPORT Hello ; + + +PROCEDURE testproc (s: String) ; +BEGIN +END testproc ; + + +PROCEDURE foo ; +BEGIN + testproc (Hello) +END foo ; + + +BEGIN + foo +END badpointer4. diff --git a/gcc/testsuite/gm2/pim/fail/strconst.def b/gcc/testsuite/gm2/pim/fail/strconst.def new file mode 100644 index 000000000000..867e00665070 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/strconst.def @@ -0,0 +1,6 @@ +DEFINITION MODULE strconst ; + +CONST + Hello = "hello world" ; + +END strconst. -- 2.47.2