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

PR modula2/114333 set type comparison against a cardinal should cause an error

Browse source 
The type checker M2Check.mod needs extending to detect if a set, array or
record is in either operand at the end of the cascaded test list.

gcc/m2/ChangeLog:

	PR modula2/114333
	* gm2-compiler/M2Check.mod (checkUnbounded): New procedure
	function.
	(checkArrayTypeEquivalence): Extend checking to cover unbounded
	arrays, arrays and constants.
	(IsTyped): Simplified the expression and corrected a test for
	IsConstructor.
	(checkTypeKindViolation): New procedure function.
	(doCheckPair): Call checkTypeKindViolation.
	* gm2-compiler/M2GenGCC.mod (CodeStatement): Remove parameters
	to CodeEqu and CodeNotEqu.
	(PerformCodeIfEqu): New procedure.
	(CodeIfEqu): Rewrite.
	(PerformCodeIfNotEqu): New procedure.
	(CodeIfNotEqu): Rewrite.
	* gm2-compiler/M2Quads.mod (BuildRelOpFromBoolean): Correct
	comment.

gcc/testsuite/ChangeLog:

	PR modula2/114333
	* gm2/cse/pass/testcse54.mod: New test.
	* gm2/iso/run/pass/array9.mod: New test.
	* gm2/iso/run/pass/strcons3.mod: New test.
	* gm2/iso/run/pass/strcons4.mod: New test.
	* gm2/pim/fail/badset1.mod: New test.
	* gm2/pim/fail/badset2.mod: New test.
	* gm2/pim/fail/badset3.mod: New test.
	* gm2/pim/fail/badset4.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
This commit is contained in:
Gaius Mulley 2024-03-14 11:23:42 +00:00
parent ddf852dac2
commit b7f70cfdb6
11 changed files with 400 additions and 108 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -46,7 +46,8 @@ FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType,
GetDeclaredMod, IsSubrange, GetArraySubscript, IsConst,
IsReallyPointer, IsPointer, IsParameter, ModeOfAddr,
GetMode, GetType, IsUnbounded, IsComposite, IsConstructor,
IsParameter, IsConstString, IsConstLitInternal, IsConstLit ;
IsParameter, IsConstString, IsConstLitInternal, IsConstLit,
GetStringLength ;
FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ;
FROM M2System IMPORT Address ;
@ -258,7 +259,35 @@ END checkSubrange ;
(*
checkArrayTypeEquivalence -
checkUnbounded - check to see if the unbounded is type compatible with right.
This is only allowed during parameter passing.
*)
PROCEDURE checkUnbounded (result: status; tinfo: tInfo; unbounded, right: CARDINAL) : status ;
VAR
lLow, rLow,
lHigh, rHigh: CARDINAL ;
BEGIN
(* Firstly check to see if we have resolved this as false. *)
IF isFalse (result)
THEN
RETURN result
ELSE
Assert (IsUnbounded (unbounded)) ;
IF tinfo^.kind = parameter
THEN
(* --fixme-- we should check the unbounded data type against the type of right. *)
RETURN true
ELSE
(* Not allowed to use an unbounded symbol (type) in an expression or assignment. *)
RETURN false
END
END
END checkUnbounded ;
(*
checkArrayTypeEquivalence - check array and unbounded array type equivalence.
*)
PROCEDURE checkArrayTypeEquivalence (result: status; tinfo: tInfo;
@ -273,7 +302,7 @@ BEGIN
THEN
lSub := GetArraySubscript (left) ;
rSub := GetArraySubscript (right) ;
result := checkPair (result, tinfo, GetType (left), GetType (right)) ;
result := checkPair (result, tinfo, GetSType (left), GetSType (right)) ;
IF (lSub # NulSym) AND (rSub # NulSym)
THEN
result := checkSubrange (result, tinfo, getSType (lSub), getSType (rSub))
@ -284,8 +313,22 @@ BEGIN
THEN
RETURN true
ELSE
result := checkPair (result, tinfo, GetType (left), GetType (right))
result := checkUnbounded (result, tinfo, left, right)
END
ELSIF IsUnbounded (right) AND (IsArray (left) OR IsUnbounded (left))
THEN
IF IsGenericSystemType (getSType (right)) OR IsGenericSystemType (getSType (left))
THEN
RETURN true
ELSE
result := checkUnbounded (result, tinfo, right, left)
END
ELSIF IsArray (left) AND IsConst (right)
THEN
result := checkPair (result, tinfo, GetType (left), GetType (right))
ELSIF IsArray (right) AND IsConst (left)
THEN
result := checkPair (result, tinfo, GetType (left), GetType (right))
END ;
RETURN result
END checkArrayTypeEquivalence ;
@ -547,12 +590,12 @@ END checkBaseTypeEquivalence ;
(*
IsTyped -
IsTyped - returns TRUE if sym will have a type.
*)
PROCEDURE IsTyped (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN IsVar (sym) OR IsVar (sym) OR IsParameter (sym) OR
RETURN IsVar (sym) OR IsParameter (sym) OR IsConstructor (sym) OR
(IsConst (sym) AND IsConstructor (sym)) OR IsParameter (sym) OR
(IsConst (sym) AND (GetType (sym) # NulSym))
END IsTyped ;
@ -630,16 +673,26 @@ BEGIN
RETURN result
ELSIF IsConstString (left)
THEN
typeRight := GetDType (right) ;
IF typeRight = NulSym
IF IsConstString (right)
THEN
RETURN result
ELSIF IsSet (typeRight) OR IsEnumeration (typeRight) OR IsProcedure (typeRight) OR
IsRecord (typeRight)
RETURN true
ELSIF IsTyped (right)
THEN
RETURN false
ELSE
RETURN doCheckPair (result, tinfo, Char, typeRight)
typeRight := GetDType (right) ;
IF typeRight = NulSym
THEN
RETURN result
ELSIF IsSet (typeRight) OR IsEnumeration (typeRight) OR
IsProcedure (typeRight) OR IsRecord (typeRight)
THEN
RETURN false
ELSIF IsArray (typeRight)
THEN
RETURN doCheckPair (result, tinfo, Char, GetType (typeRight))
ELSIF GetStringLength (tinfo^.token, left) = 1
THEN
RETURN doCheckPair (result, tinfo, Char, typeRight)
END
END
END ;
RETURN result
@ -772,6 +825,30 @@ BEGIN
END checkSystemEquivalence ;
(*
checkTypeKindViolation - returns false if one operand left or right is
a set, record or array.
*)
PROCEDURE checkTypeKindViolation (result: status; tinfo: tInfo;
left, right: CARDINAL) : status ;
BEGIN
IF isFalse (result) OR (result = visited)
THEN
RETURN result
ELSE
(* We have checked IsSet (left) and IsSet (right) etc in doCheckPair. *)
IF (IsSet (left) OR IsSet (right)) OR
(IsRecord (left) OR IsRecord (right)) OR
(IsArray (left) OR IsArray (right))
THEN
RETURN false
END
END ;
RETURN result
END checkTypeKindViolation ;
(*
doCheckPair -
*)
@ -810,7 +887,11 @@ BEGIN
result := checkGenericTypeEquivalence (result, left, right) ;
IF NOT isKnown (result)
THEN
result := checkTypeKindEquivalence (result, tinfo, left, right)
result := checkTypeKindEquivalence (result, tinfo, left, right) ;
IF NOT isKnown (result)
THEN
result := checkTypeKindViolation (result, tinfo, left, right)
END
END
END
END

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

@ -511,8 +511,8 @@ BEGIN
LogicalXorOp : CodeSetSymmetricDifference (q) |
LogicalDiffOp : CodeSetLogicalDifference (q) |
IfLessOp : CodeIfLess (q, op1, op2, op3) |
IfEquOp : CodeIfEqu (q, op1, op2, op3) |
IfNotEquOp : CodeIfNotEqu (q, op1, op2, op3) |
IfEquOp : CodeIfEqu (q) |
IfNotEquOp : CodeIfNotEqu (q) |
IfGreEquOp : CodeIfGreEqu (q, op1, op2, op3) |
IfLessEquOp : CodeIfLessEqu (q, op1, op2, op3) |
IfGreOp : CodeIfGre (q, op1, op2, op3) |
@ -2489,17 +2489,8 @@ END FoldBuiltinFunction ;
(*
CodeParam - builds a parameter list.
NOTE that we almost can treat VAR and NON VAR parameters the same, expect for
some types:
procedure parameters
unbounded parameters
these require special attention and thus it is easier to test individually
for VAR and NON VAR parameters.
NOTE that we CAN ignore ModeOfAddr though
Note that we can ignore ModeOfAddr as any lvalue will
have been created in a preceeding quadruple.
*)
PROCEDURE CodeParam (quad: CARDINAL) ;
@ -7298,51 +7289,159 @@ BEGIN
END ComparisonMixTypes ;
(*
PerformCodeIfEqu -
*)
PROCEDURE PerformCodeIfEqu (quad: CARDINAL) ;
VAR
tl, tr : Tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
overflow : BOOLEAN ;
op : QuadOperator ;
BEGIN
(* Ensure that any remaining undeclared constant literal is declared. *)
GetQuadOtok (quad, combined, op,
left, right, dest, overflow,
leftpos, rightpos, destpos) ;
location := TokenToLocation (combined) ;
IF IsConst (left) AND IsConst (right)
THEN
PushValue (left) ;
PushValue (right) ;
IF Equ (combined)
THEN
BuildGoto (location, string (CreateLabelName (dest)))
ELSE
(* Fall through. *)
END
ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
THEN
CodeIfSetEqu (quad, left, right, dest)
ELSE
IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
MetaErrorT2 (combined,
'equality tests between composite types not allowed {%1Eatd} and {%2atd}',
left, right)
ELSE
ConvertBinaryOperands (location,
tl, tr,
ComparisonMixTypes (SkipType (GetType (left)),
SkipType (GetType (right)),
combined),
left, right) ;
DoJump (location, BuildEqualTo (location, tl, tr), NIL,
string (CreateLabelName (dest)))
END
END
END PerformCodeIfEqu ;
(*
PerformCodeIfNotEqu -
*)
PROCEDURE PerformCodeIfNotEqu (quad: CARDINAL) ;
VAR
tl, tr : Tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
overflow : BOOLEAN ;
op : QuadOperator ;
BEGIN
(* Ensure that any remaining undeclared constant literal is declared. *)
GetQuadOtok (quad, combined, op,
left, right, dest, overflow,
leftpos, rightpos, destpos) ;
location := TokenToLocation (combined) ;
IF IsConst (left) AND IsConst (right)
THEN
PushValue (left) ;
PushValue (right) ;
IF NotEqu (combined)
THEN
BuildGoto (location, string (CreateLabelName (dest)))
ELSE
(* Fall through. *)
END
ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
THEN
CodeIfSetNotEqu (left, right, dest)
ELSE
IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
MetaErrorT2 (combined,
'inequality tests between composite types not allowed {%1Eatd} and {%2atd}',
left, right)
ELSE
ConvertBinaryOperands (location,
tl, tr,
ComparisonMixTypes (SkipType (GetType (left)),
SkipType (GetType (right)),
combined),
left, right) ;
DoJump (location, BuildNotEqualTo (location, tl, tr), NIL,
string (CreateLabelName (dest)))
END
END
END PerformCodeIfNotEqu ;
(*
IsValidExpressionRelOp -
*)
PROCEDURE IsValidExpressionRelOp (quad: CARDINAL) : BOOLEAN ;
CONST
Verbose = FALSE ;
VAR
lefttype, righttype,
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
overflow : BOOLEAN ;
op : QuadOperator ;
BEGIN
(* Ensure that any remaining undeclared constant literal is declared. *)
GetQuadOtok (quad, combined, op,
left, right, dest, overflow,
leftpos, rightpos, destpos) ;
DeclareConstant (leftpos, left) ;
DeclareConstant (rightpos, right) ;
DeclareConstructor (leftpos, quad, left) ;
DeclareConstructor (rightpos, quad, right) ;
lefttype := GetType (left) ;
righttype := GetType (right) ;
IF ExpressionTypeCompatible (combined, "", left, right,
StrictTypeChecking, FALSE)
THEN
RETURN TRUE
ELSE
IF Verbose
THEN
MetaErrorT2 (combined,
'expression mismatch between {%1Etad} and {%2tad} seen during comparison',
left, right)
END ;
RETURN FALSE
END
END IsValidExpressionRelOp ;
(*
CodeIfEqu - codes the quadruple if op1 = op2 then goto op3
*)
PROCEDURE CodeIfEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
VAR
tl, tr: Tree ;
location : location_t ;
PROCEDURE CodeIfEqu (quad: CARDINAL) ;
BEGIN
location := TokenToLocation(CurrentQuadToken) ;
(* firstly ensure that any constant literal is declared *)
DeclareConstant(CurrentQuadToken, op1) ;
DeclareConstant(CurrentQuadToken, op2) ;
DeclareConstructor(CurrentQuadToken, quad, op1) ;
DeclareConstructor(CurrentQuadToken, quad, op2) ;
IF IsConst(op1) AND IsConst(op2)
IF IsValidExpressionRelOp (quad)
THEN
PushValue(op1) ;
PushValue(op2) ;
IF Equ(CurrentQuadToken)
THEN
BuildGoto(location, string(CreateLabelName(op3)))
ELSE
(* fall through *)
END
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
THEN
CodeIfSetEqu(quad, op1, op2, op3)
ELSE
IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2))
THEN
MetaErrorT2 (CurrentQuadToken,
'equality tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2)
ELSE
ConvertBinaryOperands(location,
tl, tr,
ComparisonMixTypes (SkipType (GetType (op1)),
SkipType (GetType (op2)),
CurrentQuadToken),
op1, op2) ;
DoJump(location, BuildEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
END
PerformCodeIfEqu (quad)
END
END CodeIfEqu ;
@ -7351,48 +7450,11 @@ END CodeIfEqu ;
CodeIfNotEqu - codes the quadruple if op1 # op2 then goto op3
*)
PROCEDURE CodeIfNotEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
VAR
tl, tr : Tree ;
location: location_t ;
PROCEDURE CodeIfNotEqu (quad: CARDINAL) ;
BEGIN
location := TokenToLocation(CurrentQuadToken) ;
(* firstly ensure that any constant literal is declared *)
DeclareConstant(CurrentQuadToken, op1) ;
DeclareConstant(CurrentQuadToken, op2) ;
DeclareConstructor(CurrentQuadToken, quad, op1) ;
DeclareConstructor(CurrentQuadToken, quad, op2) ;
IF IsConst(op1) AND IsConst(op2)
IF IsValidExpressionRelOp (quad)
THEN
PushValue(op1) ;
PushValue(op2) ;
IF NotEqu(CurrentQuadToken)
THEN
BuildGoto(location, string(CreateLabelName(op3)))
ELSE
(* fall through *)
END
ELSIF IsConstSet(op1) OR (IsVar(op1) AND IsSet(SkipType(GetType(op1)))) OR
IsConstSet(op2) OR (IsVar(op2) AND IsSet(SkipType(GetType(op2))))
THEN
CodeIfSetNotEqu (op1, op2, op3)
ELSE
IF IsComposite(op1) OR IsComposite(op2)
THEN
MetaErrorT2 (CurrentQuadToken,
'inequality tests between composite types not allowed {%1Eatd} and {%2atd}',
op1, op2)
ELSE
ConvertBinaryOperands(location,
tl, tr,
ComparisonMixTypes (SkipType (GetType (op1)),
SkipType (GetType (op2)),
CurrentQuadToken),
op1, op2) ;
DoJump(location,
BuildNotEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
END
PerformCodeIfNotEqu (quad)
END
END CodeIfNotEqu ;

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

@ -12898,7 +12898,7 @@ BEGIN
PushBooltok (Merge (NextQuad-1, t1), Merge (NextQuad-2, f1), tokpos)
ELSIF (OperandT (2) = HashTok) OR (OperandT (2) = LessGreaterTok)
THEN
(* are the two boolean expressions the different? *)
(* are the two boolean expressions different? *)
PopBool (t1, f1) ;
PopT (Tok) ;
PopBool (t2, f2) ;

7
gcc/testsuite/gm2/cse/pass/testcse54.mod Normal file
View file

@ -0,0 +1,7 @@
MODULE testcse54 ;
VAR
a: ARRAY [0..10] OF CHAR ;
BEGIN
a := 'hello'
END testcse54.

28
gcc/testsuite/gm2/iso/run/pass/array9.mod Normal file
View file

@ -0,0 +1,28 @@
(* Copyright (C) 2009 Free Software Foundation, Inc. *)
(* This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License along
with gm2; see the file COPYING. If not, write to the Free Software
Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
MODULE array9 ;
PROCEDURE assign (a: ARRAY OF ARRAY OF CARDINAL) ;
END assign ;
VAR
e: ARRAY [1..5] OF ARRAY [0..29] OF CARDINAL ;
BEGIN
assign(e)
END array9.

30
gcc/testsuite/gm2/iso/run/pass/strcons3.mod Normal file
View file

@ -0,0 +1,30 @@
(* Copyright (C) 2024 Free Software Foundation, Inc. *)
(* This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License along
with gm2; see the file COPYING. If not, write to the Free Software
Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
MODULE strcons3 ;
TYPE
NameType = ARRAY [0..24] OF CHAR ;
PersonType = RECORD
name: NameType ;
END ;
VAR
person: PersonType ;
BEGIN
person := PersonType{"Blaise Pascal"}
END strcons3.

36
gcc/testsuite/gm2/iso/run/pass/strcons4.mod Normal file
View file

@ -0,0 +1,36 @@
(* Copyright (C) 2024 Free Software Foundation, Inc. *)
(* This file is part of GNU Modula-2.
GNU Modula-2 is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License along
with gm2; see the file COPYING. If not, write to the Free Software
Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
MODULE strcons4 ;
TYPE
NameType = ARRAY [0..24] OF CHAR ;
DateType = RECORD
year, month, day: CARDINAL ;
END ;
PersonType = RECORD
name: NameType ;
DateOfBirth: DateType ;
END ;
VAR
date : DateType ;
person: PersonType ;
BEGIN
date := DateType{1623, 6, 19} ;
person := PersonType{"Blaise Pascal", date} ;
END strcons4.

13
gcc/testsuite/gm2/pim/fail/badset1.mod Normal file
View file

@ -0,0 +1,13 @@
MODULE badset1 ;
FROM libc IMPORT printf ;
VAR
s: SET OF [1..10] ;
c: CARDINAL ;
BEGIN
IF c = s
THEN
printf ("broken\n")
END
END badset1.

13
gcc/testsuite/gm2/pim/fail/badset2.mod Normal file
View file

@ -0,0 +1,13 @@
MODULE badset2 ;
FROM libc IMPORT printf ;
VAR
s: SET OF [1..10] ;
c: CARDINAL ;
BEGIN
IF c # s
THEN
printf ("broken\n")
END
END badset2.

11
gcc/testsuite/gm2/pim/fail/badset3.mod Normal file
View file

@ -0,0 +1,11 @@
MODULE badset3 ;
VAR
s10: SET OF [1..10] ;
s20: SET OF [1..20] ;
BEGIN
IF s10 = s20
THEN
END
END badset3.

11
gcc/testsuite/gm2/pim/fail/badset4.mod Normal file
View file

@ -0,0 +1,11 @@
MODULE badset4 ;
VAR
s10: SET OF [1..10] ;
s20: SET OF [1..20] ;
BEGIN
IF s10 > s20
THEN
END
END badset4.