diff options
author | Gaius Mulley <gaiusmod2@gmail.com> | 2024-01-26 19:04:48 +0000 |
---|---|---|
committer | Gaius Mulley <gaiusmod2@gmail.com> | 2024-01-26 19:04:48 +0000 |
commit | eb619490b01baa2fc2b5ee98d15516c4a2372e74 (patch) | |
tree | 64dc8c96889ed992daf2b2beb9bc6986832fc463 | |
parent | c34ab549d88da13ae16edccedd4218807afefb65 (diff) | |
download | gcc-eb619490b01baa2fc2b5ee98d15516c4a2372e74.zip gcc-eb619490b01baa2fc2b5ee98d15516c4a2372e74.tar.gz gcc-eb619490b01baa2fc2b5ee98d15516c4a2372e74.tar.bz2 |
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>
-rw-r--r-- | gcc/m2/gm2-compiler/M2Check.mod | 108 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2GCCDeclare.mod | 5 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2GenGCC.mod | 61 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.mod | 29 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/SymbolTable.mod | 1 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/badpointer4.mod | 20 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/strconst.def | 6 |
7 files changed, 169 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 *) diff --git a/gcc/testsuite/gm2/pim/fail/badpointer4.mod b/gcc/testsuite/gm2/pim/fail/badpointer4.mod new file mode 100644 index 0000000..b5fb8ad --- /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 0000000..867e006 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/strconst.def @@ -0,0 +1,6 @@ +DEFINITION MODULE strconst ; + +CONST + Hello = "hello world" ; + +END strconst. |