diff options
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/m2/gm2-compiler/M2Check.mod | 111 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2GenGCC.mod | 212 | ||||
-rw-r--r-- | gcc/m2/gm2-compiler/M2Quads.mod | 2 | ||||
-rw-r--r-- | gcc/testsuite/gm2/cse/pass/testcse54.mod | 7 | ||||
-rw-r--r-- | gcc/testsuite/gm2/iso/run/pass/array9.mod | 28 | ||||
-rw-r--r-- | gcc/testsuite/gm2/iso/run/pass/strcons3.mod | 30 | ||||
-rw-r--r-- | gcc/testsuite/gm2/iso/run/pass/strcons4.mod | 36 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/badset1.mod | 13 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/badset2.mod | 13 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/badset3.mod | 11 | ||||
-rw-r--r-- | gcc/testsuite/gm2/pim/fail/badset4.mod | 11 |
11 files changed, 383 insertions, 91 deletions
diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index 5b45ad3..20d463d 100644 --- a/gcc/m2/gm2-compiler/M2Check.mod +++ b/gcc/m2/gm2-compiler/M2Check.mod @@ -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 @@ -773,6 +826,30 @@ 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 diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod index aeba48d..7633b84 100644 --- a/gcc/m2/gm2-compiler/M2GenGCC.mod +++ b/gcc/m2/gm2-compiler/M2GenGCC.mod @@ -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) ; @@ -7299,101 +7290,172 @@ END ComparisonMixTypes ; (* - CodeIfEqu - codes the quadruple if op1 = op2 then goto op3 + PerformCodeIfEqu - *) -PROCEDURE CodeIfEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ; +PROCEDURE PerformCodeIfEqu (quad: CARDINAL) ; VAR - tl, tr: Tree ; - location : location_t ; + tl, tr : Tree ; + location : location_t ; + left, right, dest, combined, + leftpos, rightpos, destpos : CARDINAL ; + overflow : BOOLEAN ; + op : QuadOperator ; 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) + (* 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(op1) ; - PushValue(op2) ; - IF Equ(CurrentQuadToken) + PushValue (left) ; + PushValue (right) ; + IF Equ (combined) THEN - BuildGoto(location, string(CreateLabelName(op3))) + BuildGoto (location, string (CreateLabelName (dest))) ELSE - (* fall through *) + (* 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)))) + 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, op1, op2, op3) + CodeIfSetEqu (quad, left, right, dest) ELSE - IF IsComposite(GetType(op1)) OR IsComposite(GetType(op2)) + IF IsComposite (GetType (left)) OR IsComposite (GetType (right)) THEN - MetaErrorT2 (CurrentQuadToken, + MetaErrorT2 (combined, 'equality tests between composite types not allowed {%1Eatd} and {%2atd}', - op1, op2) + left, right) 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))) + 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 CodeIfEqu ; +END PerformCodeIfEqu ; (* - CodeIfNotEqu - codes the quadruple if op1 # op2 then goto op3 + PerformCodeIfNotEqu - *) -PROCEDURE CodeIfNotEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ; +PROCEDURE PerformCodeIfNotEqu (quad: CARDINAL) ; VAR - tl, tr : Tree ; - location: location_t ; + tl, tr : Tree ; + location : location_t ; + left, right, dest, combined, + leftpos, rightpos, destpos : CARDINAL ; + overflow : BOOLEAN ; + op : QuadOperator ; 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) + (* 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(op1) ; - PushValue(op2) ; - IF NotEqu(CurrentQuadToken) + PushValue (left) ; + PushValue (right) ; + IF NotEqu (combined) THEN - BuildGoto(location, string(CreateLabelName(op3))) + BuildGoto (location, string (CreateLabelName (dest))) ELSE - (* fall through *) + (* 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)))) + ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR + IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right)))) THEN - CodeIfSetNotEqu (op1, op2, op3) + CodeIfSetNotEqu (left, right, dest) ELSE - IF IsComposite(op1) OR IsComposite(op2) + IF IsComposite (GetType (left)) OR IsComposite (GetType (right)) THEN - MetaErrorT2 (CurrentQuadToken, + MetaErrorT2 (combined, 'inequality tests between composite types not allowed {%1Eatd} and {%2atd}', - op1, op2) + left, right) 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))) + 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) ; +BEGIN + IF IsValidExpressionRelOp (quad) + THEN + PerformCodeIfEqu (quad) + END +END CodeIfEqu ; + + +(* + CodeIfNotEqu - codes the quadruple if op1 # op2 then goto op3 +*) + +PROCEDURE CodeIfNotEqu (quad: CARDINAL) ; +BEGIN + IF IsValidExpressionRelOp (quad) + THEN + PerformCodeIfNotEqu (quad) + END END CodeIfNotEqu ; diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 3231f9f..0263074 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -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) ; diff --git a/gcc/testsuite/gm2/cse/pass/testcse54.mod b/gcc/testsuite/gm2/cse/pass/testcse54.mod new file mode 100644 index 0000000..5cc1e64 --- /dev/null +++ b/gcc/testsuite/gm2/cse/pass/testcse54.mod @@ -0,0 +1,7 @@ +MODULE testcse54 ; + +VAR + a: ARRAY [0..10] OF CHAR ; +BEGIN + a := 'hello' +END testcse54. diff --git a/gcc/testsuite/gm2/iso/run/pass/array9.mod b/gcc/testsuite/gm2/iso/run/pass/array9.mod new file mode 100644 index 0000000..dd3304e --- /dev/null +++ b/gcc/testsuite/gm2/iso/run/pass/array9.mod @@ -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. diff --git a/gcc/testsuite/gm2/iso/run/pass/strcons3.mod b/gcc/testsuite/gm2/iso/run/pass/strcons3.mod new file mode 100644 index 0000000..7950e64 --- /dev/null +++ b/gcc/testsuite/gm2/iso/run/pass/strcons3.mod @@ -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. diff --git a/gcc/testsuite/gm2/iso/run/pass/strcons4.mod b/gcc/testsuite/gm2/iso/run/pass/strcons4.mod new file mode 100644 index 0000000..1c0e350 --- /dev/null +++ b/gcc/testsuite/gm2/iso/run/pass/strcons4.mod @@ -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. diff --git a/gcc/testsuite/gm2/pim/fail/badset1.mod b/gcc/testsuite/gm2/pim/fail/badset1.mod new file mode 100644 index 0000000..de56fe3 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badset1.mod @@ -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. diff --git a/gcc/testsuite/gm2/pim/fail/badset2.mod b/gcc/testsuite/gm2/pim/fail/badset2.mod new file mode 100644 index 0000000..b8c798f --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badset2.mod @@ -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. diff --git a/gcc/testsuite/gm2/pim/fail/badset3.mod b/gcc/testsuite/gm2/pim/fail/badset3.mod new file mode 100644 index 0000000..fcbf177 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badset3.mod @@ -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. diff --git a/gcc/testsuite/gm2/pim/fail/badset4.mod b/gcc/testsuite/gm2/pim/fail/badset4.mod new file mode 100644 index 0000000..2382e4e --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badset4.mod @@ -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. |