FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

modula2: detect string and pointer formal and actual parameter incompatibility

Browse source 
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>
This commit is contained in:
Gaius Mulley 2024-01-26 19:04:48 +00:00
parent c34ab549d8
commit eb619490b0
7 changed files with 169 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

108
gcc/m2/gm2-compiler/M2Check.mod
View file

@ -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) ;

5
gcc/m2/gm2-compiler/M2GCCDeclare.mod
View file

@ -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 ') ;

61
gcc/m2/gm2-compiler/M2GenGCC.mod
View file

@ -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 ;

29
gcc/m2/gm2-compiler/M2Quads.mod
View file

@ -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))

1
gcc/m2/gm2-compiler/SymbolTable.mod
View file

@ -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 *)

20
gcc/testsuite/gm2/pim/fail/badpointer4.mod Normal file
View file

@ -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.

6
gcc/testsuite/gm2/pim/fail/strconst.def Normal file
View file

@ -0,0 +1,6 @@
DEFINITION MODULE strconst ;
CONST
Hello = "hello world" ;
END strconst.