public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-4000] modula2: introduce case checking when switching on subranges
@ 2023-09-14 18:36 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2023-09-14 18:36 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:4e1c5d5faf6b3dd32a9c8644d4fbf6471b7d9705
commit r14-4000-g4e1c5d5faf6b3dd32a9c8644d4fbf6471b7d9705
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Thu Sep 14 19:35:24 2023 +0100
modula2: introduce case checking when switching on subranges
This patch extends the -Wcase-enum warning to catch missing elements
from subranges. The patch also includes removal of unused parameters
from M2SymInit.mod and M2CaseList.mod.
gcc/m2/ChangeLog:
* gm2-compiler/M2CaseList.mod (appendString): New procedure.
(appendEnum): Re-implement.
(NoOfSetElements): New procedure function.
(isPrintableChar): New procedure function.
(appendTree): New procedure.
(SubrangeErrors): New procedure.
(EmitMissingRangeErrors): Call SubrangeErrors if appropriate.
* gm2-compiler/M2SymInit.mod (SetFieldInitializedNo): Avoid
using a temporary variable once.
(IsLocalVar): Comment out.
(RecordContainsVarient): Remove fieldtype.
(GenerateNoteFlow): Remove lst parameter.
(CheckDeferredRecordAccess): Remove lst parameter.
(CheckUnary): Remove lst parameter. Remove procSym.
(CheckBinary): Remove lst parameter. Remove procSym.
(CheckIndrX): Remove lst parameter. Remove procSym.
(CheckXIndr): Remove bblst and procSym parameters.
(CheckRecordField): Remove procSym, op1tok, op2tok and op2.
(CheckBecomes): Remove procSym and bblst.
(CheckComparison): Remove procSym and bblst.
(CheckAddr): Remove procSym parameter.
* gm2-gcc/m2expr.cc (m2expr_CSTIntToString): New function.
(m2expr_CSTIntToChar): New function.
* gm2-gcc/m2expr.def (CSTIntToString): New procedure function
declaration.
(CSTIntToChar): New procedure function declaration.
* gm2-gcc/m2expr.h (m2expr_CSTIntToChar): New prototype.
(m2expr_CSTIntToString): New prototype.
gcc/testsuite/ChangeLog:
* gm2/switches/case/fail/subrangecase.mod: New test.
* gm2/switches/case/fail/subrangecase2.mod: New test.
* gm2/switches/case/fail/subrangecase3.mod: New test.
* gm2/switches/case/fail/subrangecase4.mod: New test.
* gm2/switches/case/fail/subrangecase5.mod: New test.
* gm2/switches/case/fail/subrangecase6.mod: New test.
* gm2/switches/case/pass/subrangecase.mod: New test.
* gm2/switches/case/pass/subrangecase2.mod: New test.
* gm2/switches/case/pass/subrangecase3.mod: New test.
* gm2/switches/case/pass/subrangecase4.mod: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2CaseList.mod | 207 +++++++++++++++++++--
gcc/m2/gm2-compiler/M2SymInit.mod | 111 ++++++-----
gcc/m2/gm2-gcc/m2expr.cc | 20 ++
gcc/m2/gm2-gcc/m2expr.def | 15 +-
gcc/m2/gm2-gcc/m2expr.h | 3 +
.../gm2/switches/case/fail/subrangecase.mod | 24 +++
.../gm2/switches/case/fail/subrangecase2.mod | 22 +++
.../gm2/switches/case/fail/subrangecase3.mod | 23 +++
.../gm2/switches/case/fail/subrangecase4.mod | 23 +++
.../gm2/switches/case/fail/subrangecase5.mod | 23 +++
.../gm2/switches/case/fail/subrangecase6.mod | 23 +++
.../gm2/switches/case/pass/subrangecase.mod | 24 +++
.../gm2/switches/case/pass/subrangecase2.mod | 22 +++
.../gm2/switches/case/pass/subrangecase3.mod | 23 +++
.../gm2/switches/case/pass/subrangecase4.mod | 21 +++
15 files changed, 506 insertions(+), 78 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod
index 18ea1fecf2b..910fcc6c4b4 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -32,18 +32,19 @@ FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, ForeachIndiceInInde
FROM Lists IMPORT InitList, IncludeItemIntoList, RemoveItemFromList, NoOfItemsInList, GetItemFromList ;
FROM NameKey IMPORT KeyToCharStar ;
FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ;
-FROM DynamicStrings IMPORT InitString, InitStringCharStar, ConCat, Mark, KillString ;
+FROM DynamicStrings IMPORT InitString, InitStringCharStar, InitStringChar, ConCat, Mark, KillString ;
FROM m2tree IMPORT Tree ;
FROM m2block IMPORT RememberType ;
FROM m2type IMPORT GetMinFrom ;
-FROM m2expr IMPORT GetIntegerOne ;
+FROM m2expr IMPORT GetIntegerOne, CSTIntToString, CSTIntToChar ;
FROM Storage IMPORT ALLOCATE ;
-FROM M2Base IMPORT IsExpressionCompatible ;
+FROM M2Base IMPORT IsExpressionCompatible, Char ;
FROM M2Printf IMPORT printf1 ;
FROM M2LexBuf IMPORT TokenToLocation ;
FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType,
- ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth ;
+ ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth,
+ IsSubrange ;
TYPE
RangePair = POINTER TO RECORD
@@ -822,14 +823,23 @@ BEGIN
END ErrorRanges ;
+(*
+ appendString -
+*)
+
+PROCEDURE appendString (str: String) ;
+BEGIN
+ errorString := ConCat (errorString, str)
+END appendString ;
+
+
(*
appendEnum -
*)
PROCEDURE appendEnum (enum: CARDINAL) ;
BEGIN
- errorString := ConCat (errorString,
- Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum)))))
+ appendString (Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum)))))
END appendEnum ;
@@ -839,7 +849,7 @@ END appendEnum ;
PROCEDURE appendStr (str: ARRAY OF CHAR) ;
BEGIN
- errorString := ConCat (errorString, Mark (InitString (str)))
+ appendString (Mark (InitString (str)))
END appendStr ;
@@ -879,6 +889,157 @@ BEGIN
END EnumerateErrors ;
+(*
+ NoOfSetElements - return the number of set elements.
+*)
+
+PROCEDURE NoOfSetElements (set: SetRange) : Tree ;
+BEGIN
+ PushInt (0) ;
+ WHILE set # NIL DO
+ IF ((set^.low # NIL) AND (set^.high = NIL)) OR
+ ((set^.low = NIL) AND (set^.high # NIL))
+ THEN
+ PushInt (1) ;
+ Addn
+ ELSIF (set^.low # NIL) AND (set^.high # NIL)
+ THEN
+ PushIntegerTree (set^.high) ;
+ PushIntegerTree (set^.low) ;
+ Sub ;
+ PushInt (1) ;
+ Addn ;
+ Addn
+ END ;
+ set := set^.next
+ END ;
+ RETURN PopIntegerTree ()
+END NoOfSetElements ;
+
+
+(*
+ isPrintableChar - a cautious isprint.
+*)
+
+PROCEDURE isPrintableChar (value: Tree) : BOOLEAN ;
+BEGIN
+ CASE CSTIntToChar (value) OF
+
+ 'a'..'z': RETURN TRUE |
+ 'A'..'Z': RETURN TRUE |
+ '0'..'9': RETURN TRUE |
+ '!', '@': RETURN TRUE |
+ '#', '$': RETURN TRUE |
+ '%', '^': RETURN TRUE |
+ '&', '*': RETURN TRUE |
+ '(', ')': RETURN TRUE |
+ '[', ']': RETURN TRUE |
+ '{', '}': RETURN TRUE |
+ '-', '+': RETURN TRUE |
+ '_', '=': RETURN TRUE |
+ ':', ';': RETURN TRUE |
+ "'", '"': RETURN TRUE |
+ ',', '.': RETURN TRUE |
+ '<', '>': RETURN TRUE |
+ '/', '?': RETURN TRUE |
+ '\', '|': RETURN TRUE |
+ '~', '`': RETURN TRUE |
+ ' ' : RETURN TRUE
+
+ ELSE
+ RETURN FALSE
+ END
+END isPrintableChar ;
+
+
+(*
+ appendTree -
+*)
+
+PROCEDURE appendTree (value: Tree; type: CARDINAL) ;
+BEGIN
+ IF SkipType (GetType (type)) = Char
+ THEN
+ IF isPrintableChar (value)
+ THEN
+ IF CSTIntToChar (value) = "'"
+ THEN
+ appendString (InitStringChar ('"')) ;
+ appendString (InitStringChar (CSTIntToChar (value))) ;
+ appendString (InitStringChar ('"'))
+ ELSE
+ appendString (InitStringChar ("'")) ;
+ appendString (InitStringChar (CSTIntToChar (value))) ;
+ appendString (InitStringChar ("'"))
+ END
+ ELSE
+ appendString (InitStringCharStar ('CHR (')) ;
+ appendString (InitStringCharStar (CSTIntToString (value))) ;
+ appendString (InitStringChar (')'))
+ END
+ ELSE
+ appendString (InitStringCharStar (CSTIntToString (value)))
+ END
+END appendTree ;
+
+
+(*
+ SubrangeErrors -
+*)
+
+PROCEDURE SubrangeErrors (subrangetype: CARDINAL; set: SetRange) ;
+VAR
+ sr : SetRange ;
+ rangeNo : CARDINAL ;
+ nMissing,
+ zero, one: Tree ;
+BEGIN
+ nMissing := NoOfSetElements (set) ;
+ PushInt (0) ;
+ zero := PopIntegerTree () ;
+ IF IsGreater (nMissing, zero)
+ THEN
+ PushInt (1) ;
+ one := PopIntegerTree () ;
+ IF IsGreater (nMissing, one)
+ THEN
+ errorString := InitString ('{%W}there are a total of ')
+ ELSE
+ errorString := InitString ('{%W}there is a total of ')
+ END ;
+ appendString (InitStringCharStar (CSTIntToString (nMissing))) ;
+ appendStr (' missing values in the subrange, the {%kCASE} statement needs labels (or an {%kELSE} statement)') ;
+ appendStr (' for the following values: ') ;
+ sr := set ;
+ rangeNo := 0 ;
+ WHILE sr # NIL DO
+ INC (rangeNo) ;
+ IF rangeNo > 1
+ THEN
+ IF sr^.next = NIL
+ THEN
+ appendStr (' and ')
+ ELSE
+ appendStr (', ')
+ END
+ END ;
+ IF sr^.low = NIL
+ THEN
+ appendTree (sr^.high, subrangetype)
+ ELSIF (sr^.high = NIL) OR IsEqual (sr^.low, sr^.high)
+ THEN
+ appendTree (sr^.low, subrangetype)
+ ELSE
+ appendTree (sr^.low, subrangetype) ;
+ appendStr ('..') ;
+ appendTree (sr^.high, subrangetype)
+ END ;
+ sr := sr^.next
+ END
+ END
+END SubrangeErrors ;
+
+
(*
EmitMissingRangeErrors - emits a singular/plural error message for an enumeration type.
*)
@@ -889,6 +1050,9 @@ BEGIN
IF IsEnumeration (type)
THEN
EnumerateErrors (ErrorRanges (type, set))
+ ELSIF IsSubrange (type)
+ THEN
+ SubrangeErrors (type, set)
END ;
IF errorString # NIL
THEN
@@ -958,21 +1122,24 @@ BEGIN
IF expression # NulSym
THEN
type := SkipType (GetType (expression)) ;
- IF (type # NulSym) AND IsEnumeration (type)
+ IF type # NulSym
THEN
- (* A case statement sequence without an else clause but
- selecting using an enumeration type. *)
- set := NewSet (type) ;
- set := ExcludeCaseRanges (set, p) ;
- IF set # NIL
+ IF IsEnumeration (type) OR IsSubrange (type)
THEN
- missing := TRUE ;
- MetaErrorT1 (tokenno,
- 'not all enumeration values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1Wad} or use an {%kELSE} clause',
- type) ;
- EmitMissingRangeErrors (tokenno, type, set)
- END ;
- set := DisposeRanges (set)
+ (* A case statement sequence without an else clause but
+ selecting using an enumeration type. *)
+ set := NewSet (type) ;
+ set := ExcludeCaseRanges (set, p) ;
+ IF set # NIL
+ THEN
+ missing := TRUE ;
+ MetaErrorT1 (tokenno,
+ 'not all {%1Wd} values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1ad} or use an {%kELSE} clause',
+ type) ;
+ EmitMissingRangeErrors (tokenno, type, set)
+ END ;
+ set := DisposeRanges (set)
+ END
END
END
END
diff --git a/gcc/m2/gm2-compiler/M2SymInit.mod b/gcc/m2/gm2-compiler/M2SymInit.mod
index 18a854b5bba..47026a87555 100644
--- a/gcc/m2/gm2-compiler/M2SymInit.mod
+++ b/gcc/m2/gm2-compiler/M2SymInit.mod
@@ -341,7 +341,6 @@ END TrySetInitialized ;
PROCEDURE SetFieldInitializedNo (desc: InitDesc;
fieldlist: List; level: CARDINAL) : BOOLEAN ;
VAR
- init : BOOLEAN ;
nsym : CARDINAL ;
fdesc: InitDesc ;
BEGIN
@@ -360,7 +359,9 @@ BEGIN
TrySetInitialized (desc) ;
RETURN desc^.initialized
ELSE
- init := SetFieldInitializedNo (fdesc, fieldlist, level + 1) ;
+ IF SetFieldInitializedNo (fdesc, fieldlist, level + 1)
+ THEN
+ END ;
TrySetInitialized (desc) ;
RETURN desc^.initialized
END
@@ -416,12 +417,12 @@ END IsGlobalVar ;
(*
IsLocalVar -
-*)
PROCEDURE IsLocalVar (procsym, varsym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN IsVar (varsym) AND (GetVarScope (varsym) = procsym)
END IsLocalVar ;
+*)
(*
@@ -446,8 +447,7 @@ END RecordFieldContainsVarient ;
PROCEDURE RecordContainsVarient (sym: CARDINAL; visited: List) : BOOLEAN ;
VAR
i,
- fieldsym,
- fieldtype: CARDINAL ;
+ fieldsym: CARDINAL ;
BEGIN
Assert (IsRecord (sym)) ;
i := 1 ;
@@ -597,7 +597,7 @@ END IssueConditional ;
GenerateNoteFlow -
*)
-PROCEDURE GenerateNoteFlow (lst: List; n: CARDINAL; warning: BOOLEAN) ;
+PROCEDURE GenerateNoteFlow (n: CARDINAL; warning: BOOLEAN) ;
VAR
i : CARDINAL ;
ip1Ptr,
@@ -666,10 +666,10 @@ END IsUniqueWarning ;
CheckDeferredRecordAccess -
*)
-PROCEDURE CheckDeferredRecordAccess (procsym: CARDINAL; tok: CARDINAL;
+PROCEDURE CheckDeferredRecordAccess (tok: CARDINAL;
sym: CARDINAL;
canDereference, warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
VAR
unique: BOOLEAN ;
BEGIN
@@ -701,7 +701,7 @@ BEGIN
Trace ("checkReadInit IsComponent (%d) is true)", sym) ;
IF (NOT GetVarComponentInitialized (sym, tok)) AND IsUniqueWarning (tok)
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access ',
' before it has been initialized',
@@ -716,7 +716,7 @@ BEGIN
unique := IsUniqueWarning (tok) ;
IF unique
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access the address of ',
' before it has been initialized',
@@ -727,7 +727,7 @@ BEGIN
THEN
IF unique
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access ', ' before it has been initialized',
sym, warning)
@@ -737,7 +737,7 @@ BEGIN
Trace ("checkReadInit call VarCheckReadInit using GetMode (%d)", sym) ;
IF (NOT VarCheckReadInit (sym, GetMode (sym))) AND IsUniqueWarning (tok)
THEN
- GenerateNoteFlow (lst, i, warning) ;
+ GenerateNoteFlow (i, warning) ;
IssueWarning (tok,
'attempting to access ',
' before it has been initialized',
@@ -1065,14 +1065,13 @@ END IsExempt ;
CheckBinary -
*)
-PROCEDURE CheckBinary (procSym,
- op1tok, op1,
+PROCEDURE CheckBinary (op1tok, op1,
op2tok, op2,
op3tok, op3: CARDINAL; warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
BEGIN
- CheckDeferredRecordAccess (procSym, op2tok, op2, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) ;
+ CheckDeferredRecordAccess (op2tok, op2, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) ;
SetVarInitialized (op1, FALSE, op1tok)
END CheckBinary ;
@@ -1081,12 +1080,11 @@ END CheckBinary ;
CheckUnary -
*)
-PROCEDURE CheckUnary (procSym,
- lhstok, lhs,
+PROCEDURE CheckUnary (lhstok, lhs,
rhstok, rhs: CARDINAL; warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
BEGIN
- CheckDeferredRecordAccess (procSym, rhstok, rhs, FALSE, warning, lst, i) ;
+ CheckDeferredRecordAccess (rhstok, rhs, FALSE, warning, i) ;
SetVarInitialized (lhs, FALSE, lhstok)
END CheckUnary ;
@@ -1095,15 +1093,15 @@ END CheckUnary ;
CheckXIndr -
*)
-PROCEDURE CheckXIndr (procSym, lhstok, lhs, type,
+PROCEDURE CheckXIndr (lhstok, lhs, type,
rhstok, rhs: CARDINAL; warning: BOOLEAN;
- bblst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
VAR
lst : List ;
content: CARDINAL ;
BEGIN
- CheckDeferredRecordAccess (procSym, rhstok, rhs, FALSE, warning, bblst, i) ;
- CheckDeferredRecordAccess (procSym, lhstok, lhs, FALSE, warning, bblst, i) ;
+ CheckDeferredRecordAccess (rhstok, rhs, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (lhstok, lhs, FALSE, warning, i) ;
(* Now see if we know what lhs is pointing to and set fields if necessary. *)
content := getContent (getLAlias (lhs), lhs, lhstok) ;
IF (content # NulSym) AND (content # lhs) AND (GetSType (content) = type)
@@ -1132,19 +1130,19 @@ END CheckXIndr ;
CheckIndrX -
*)
-PROCEDURE CheckIndrX (procSym, lhstok, lhs, type, rhstok, rhs: CARDINAL;
+PROCEDURE CheckIndrX (lhstok, lhs, rhstok, rhs: CARDINAL;
warning: BOOLEAN;
- lst: List; i: CARDINAL) ;
+ i: CARDINAL) ;
VAR
content: CARDINAL ;
BEGIN
- CheckDeferredRecordAccess (procSym, rhstok, rhs, FALSE, warning, lst, i) ;
+ CheckDeferredRecordAccess (rhstok, rhs, FALSE, warning, i) ;
content := getContent (getLAlias (rhs), rhs, rhstok) ;
IF content = NulSym
THEN
IncludeItemIntoList (ignoreList, lhs)
ELSE
- CheckDeferredRecordAccess (procSym, rhstok, content, TRUE, warning, lst, i) ;
+ CheckDeferredRecordAccess (rhstok, content, TRUE, warning, i) ;
SetVarInitialized (lhs, VarCheckReadInit (content, RightValue), lhstok) ;
IF IsReallyPointer (content)
THEN
@@ -1158,7 +1156,7 @@ END CheckIndrX ;
CheckRecordField -
*)
-PROCEDURE CheckRecordField (procSym, op1tok, op1, op2tok, op2: CARDINAL) ;
+PROCEDURE CheckRecordField (op1: CARDINAL) ;
BEGIN
PutVarInitialized (op1, LeftValue)
END CheckRecordField ;
@@ -1168,14 +1166,14 @@ END CheckRecordField ;
CheckBecomes -
*)
-PROCEDURE CheckBecomes (procSym, destok, des, exprtok, expr: CARDINAL;
- warning: BOOLEAN; bblst: List; i: CARDINAL) ;
+PROCEDURE CheckBecomes (destok, des, exprtok, expr: CARDINAL;
+ warning: BOOLEAN; i: CARDINAL) ;
VAR
lvalue: BOOLEAN ;
lst : List ;
vsym : CARDINAL ;
BEGIN
- CheckDeferredRecordAccess (procSym, exprtok, expr, FALSE, warning, bblst, i) ;
+ CheckDeferredRecordAccess (exprtok, expr, FALSE, warning, i) ;
SetupLAlias (des, expr) ;
SetVarInitialized (des, FALSE, destok) ;
(* Now see if we know what lhs is pointing to and set fields if necessary. *)
@@ -1200,11 +1198,11 @@ END CheckBecomes ;
CheckComparison -
*)
-PROCEDURE CheckComparison (procSym, op1tok, op1, op2tok, op2: CARDINAL;
- warning: BOOLEAN; lst: List; i: CARDINAL) ;
+PROCEDURE CheckComparison (op1tok, op1, op2tok, op2: CARDINAL;
+ warning: BOOLEAN; i: CARDINAL) ;
BEGIN
- CheckDeferredRecordAccess (procSym, op1tok, op1, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op2tok, op2, FALSE, warning, lst, i)
+ CheckDeferredRecordAccess (op1tok, op1, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op2tok, op2, FALSE, warning, i)
END CheckComparison ;
@@ -1212,7 +1210,7 @@ END CheckComparison ;
CheckAddr -
*)
-PROCEDURE CheckAddr (procSym, ptrtok, ptr, contenttok, content: CARDINAL) ;
+PROCEDURE CheckAddr (ptrtok, ptr, contenttok, content: CARDINAL) ;
BEGIN
SetVarInitialized (ptr, GetVarInitialized (content, contenttok), ptrtok) ;
SetupIndr (ptr, content)
@@ -1279,7 +1277,7 @@ BEGIN
IfLessOp,
IfLessEquOp,
IfGreOp,
- IfGreEquOp : CheckComparison (procSym, op1tok, op1, op2tok, op2, warning, lst, i) |
+ IfGreEquOp : CheckComparison (op1tok, op1, op2tok, op2, warning, i) |
TryOp,
ReturnOp,
CallOp,
@@ -1290,29 +1288,29 @@ BEGIN
(* Variable references. *)
InclOp,
- ExclOp : CheckDeferredRecordAccess (procSym, op1tok, op1, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op1tok, op1, TRUE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) |
- NegateOp : CheckUnary (procSym, op1tok, op1, op3tok, op3, warning, lst, i) |
- BecomesOp : CheckBecomes (procSym, op1tok, op1, op3tok, op3, warning, lst, i) |
+ ExclOp : CheckDeferredRecordAccess (op1tok, op1, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op1tok, op1, TRUE, warning, i) ;
+ CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) |
+ NegateOp : CheckUnary (op1tok, op1, op3tok, op3, warning, i) |
+ BecomesOp : CheckBecomes (op1tok, op1, op3tok, op3, warning, i) |
UnboundedOp,
FunctValueOp,
StandardFunctionOp,
HighOp,
SizeOp : SetVarInitialized (op1, FALSE, op1tok) |
- AddrOp : CheckAddr (procSym, op1tok, op1, op3tok, op3) |
+ AddrOp : CheckAddr (op1tok, op1, op3tok, op3) |
ReturnValueOp : SetVarInitialized (op1, FALSE, op1tok) |
NewLocalVarOp : |
- ParamOp : CheckDeferredRecordAccess (procSym, op2tok, op2, FALSE, warning, lst, i) ;
- CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) ;
+ ParamOp : CheckDeferredRecordAccess (op2tok, op2, FALSE, warning, i) ;
+ CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) ;
IF (op1 > 0) AND (op1 <= NoOfParam (op2)) AND
IsVarParam (op2, op1)
THEN
SetVarInitialized (op3, TRUE, op3tok)
END |
- ArrayOp : CheckDeferredRecordAccess (procSym, op3tok, op3, FALSE, warning, lst, i) ;
+ ArrayOp : CheckDeferredRecordAccess (op3tok, op3, FALSE, warning, i) ;
SetVarInitialized (op1, TRUE, op1tok) |
- RecordFieldOp : CheckRecordField (procSym, op1tok, op1, op2tok, op2) |
+ RecordFieldOp : CheckRecordField (op1) |
LogicalShiftOp,
LogicalRotateOp,
LogicalOrOp,
@@ -1333,12 +1331,11 @@ BEGIN
ModCeilOp,
DivFloorOp,
ModTruncOp,
- DivTruncOp : CheckBinary (procSym,
- op1tok, op1, op2tok, op2, op3tok, op3, warning, lst, i) |
- XIndrOp : CheckXIndr (procSym, op1tok, op1, op2, op3tok, op3, warning, lst, i) |
- IndrXOp : CheckIndrX (procSym, op1tok, op1, op2, op3tok, op3, warning, lst, i) |
+ DivTruncOp : CheckBinary (op1tok, op1, op2tok, op2, op3tok, op3, warning, i) |
+ XIndrOp : CheckXIndr (op1tok, op1, op2, op3tok, op3, warning, i) |
+ IndrXOp : CheckIndrX (op1tok, op1, op3tok, op3, warning, i) |
SaveExceptionOp : SetVarInitialized (op1, FALSE, op1tok) |
- RestoreExceptionOp: CheckDeferredRecordAccess (procSym, op1tok, op1, FALSE, warning, lst, i) |
+ RestoreExceptionOp: CheckDeferredRecordAccess (op1tok, op1, FALSE, warning, i) |
SubrangeLowOp,
SubrangeHighOp : InternalError ('quadruples should have been resolved') |
@@ -1514,7 +1511,7 @@ END DumpBBArray ;
DumpBBSequence -
*)
-PROCEDURE DumpBBSequence (procSym: CARDINAL; lst: List) ;
+PROCEDURE DumpBBSequence (lst: List) ;
VAR
arrayindex,
listindex, n: CARDINAL ;
@@ -1525,7 +1522,7 @@ BEGIN
printf0 (" checking sequence:");
WHILE listindex <= n DO
arrayindex := GetItemFromList (lst, listindex) ;
- printf1 (" [%d]", listindex) ;
+ printf2 (" lst[%d] -> %d", listindex, arrayindex) ;
INC (listindex)
END ;
printf0 ("\n")
@@ -1620,7 +1617,7 @@ VAR
BEGIN
IF Debugging
THEN
- DumpBBSequence (procSym, lst)
+ DumpBBSequence (lst)
END ;
initBlock ;
ForeachLocalSymDo (procSym, SetVarUninitialized) ;
diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 8021eb00671..32222d25615 100644
--- a/gcc/m2/gm2-gcc/m2expr.cc
+++ b/gcc/m2/gm2-gcc/m2expr.cc
@@ -57,6 +57,26 @@ static tree m2expr_Build4TruthAndIf (location_t location, tree a, tree b,
static int label_count = 0;
static GTY (()) tree set_full_complement;
+/* Return an integer string using base 10 and no padding. The string returned
+ will have been malloc'd. */
+
+char *
+m2expr_CSTIntToString (tree t)
+{
+ char val[100];
+
+ snprintf (val, 100, HOST_WIDE_INT_PRINT_UNSIGNED, TREE_INT_CST_LOW (t));
+ return xstrndup (val, 100);
+}
+
+/* Return the char representation of tree t. */
+
+char
+m2expr_CSTIntToChar (tree t)
+{
+ return (char) (TREE_INT_CST_LOW (t));
+}
+
/* CompareTrees returns -1 if e1 < e2, 0 if e1 == e2, and 1 if e1 > e2. */
int
diff --git a/gcc/m2/gm2-gcc/m2expr.def b/gcc/m2/gm2-gcc/m2expr.def
index 83e281331c4..e8027a6ca55 100644
--- a/gcc/m2/gm2-gcc/m2expr.def
+++ b/gcc/m2/gm2-gcc/m2expr.def
@@ -38,12 +38,25 @@ TYPE
(*
- init - initialise this module.
+ init - initialize this module.
*)
PROCEDURE init (location: location_t) ;
+(*
+ CSTIntToString - return an integer string using base 10 and no padding.
+ The string returned will have been malloc'd.
+*)
+
+PROCEDURE CSTIntToString (t: Tree) : ADDRESS ;
+
+(*
+ CSTIntToChar - return the CHAR representation of tree t.
+*)
+
+PROCEDURE CSTIntToChar (t: Tree) : CHAR ;
+
PROCEDURE CheckConstStrZtypeRange (location: location_t;
str: ADDRESS; base: CARDINAL) : BOOLEAN ;
diff --git a/gcc/m2/gm2-gcc/m2expr.h b/gcc/m2/gm2-gcc/m2expr.h
index 40fc84685cf..d15f00b58d6 100644
--- a/gcc/m2/gm2-gcc/m2expr.h
+++ b/gcc/m2/gm2-gcc/m2expr.h
@@ -35,6 +35,9 @@ along with GNU Modula-2; see the file COPYING3. If not see
#endif /* !__GNUG__. */
#endif /* !m2expr_c. */
+
+EXTERN char m2expr_CSTIntToChar (tree t);
+EXTERN char *m2expr_CSTIntToString (tree t);
EXTERN bool m2expr_StrToWideInt (location_t location, const char *str, unsigned int base,
widest_int &wval, bool issueError);
EXTERN void m2expr_BuildBinaryForeachWordDo (
diff --git a/gcc/testsuite/gm2/switches/case/fail/subrangecase.mod b/gcc/testsuite/gm2/switches/case/fail/subrangecase.mod
new file mode 100644
index 00000000000..2c3b56ebebf
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/subrangecase.mod
@@ -0,0 +1,24 @@
+MODULE subrangecase ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ (* 1910: | *)
+ 1911..1919: |
+ 1920: |
+
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase.
diff --git a/gcc/testsuite/gm2/switches/case/fail/subrangecase2.mod b/gcc/testsuite/gm2/switches/case/fail/subrangecase2.mod
new file mode 100644
index 00000000000..d0e3a3a1a5c
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/subrangecase2.mod
@@ -0,0 +1,22 @@
+MODULE subrangecase2 ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ 1911..1920: |
+
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase2.
diff --git a/gcc/testsuite/gm2/switches/case/fail/subrangecase3.mod b/gcc/testsuite/gm2/switches/case/fail/subrangecase3.mod
new file mode 100644
index 00000000000..5a34c0bea15
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/subrangecase3.mod
@@ -0,0 +1,23 @@
+MODULE subrangecase3 ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ 1910: |
+ 1912..1919: |
+
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase3.
diff --git a/gcc/testsuite/gm2/switches/case/fail/subrangecase4.mod b/gcc/testsuite/gm2/switches/case/fail/subrangecase4.mod
new file mode 100644
index 00000000000..f8c4ae17d92
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/subrangecase4.mod
@@ -0,0 +1,23 @@
+MODULE subrangecase4 ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ 1910: |
+ 1913..1918: |
+
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase4.
diff --git a/gcc/testsuite/gm2/switches/case/fail/subrangecase5.mod b/gcc/testsuite/gm2/switches/case/fail/subrangecase5.mod
new file mode 100644
index 00000000000..ded38cd9f43
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/subrangecase5.mod
@@ -0,0 +1,23 @@
+MODULE subrangecase5 ; (*!m2iso+gm2*)
+
+
+TYPE
+ alphabet = ['a'..'z'] ;
+
+
+PROCEDURE init (a: alphabet) ;
+BEGIN
+ CASE a OF
+
+ 'a',
+ 'e'..'x':
+
+ END
+END init ;
+
+
+VAR
+ a: alphabet ;
+BEGIN
+ init (a)
+END subrangecase5.
diff --git a/gcc/testsuite/gm2/switches/case/fail/subrangecase6.mod b/gcc/testsuite/gm2/switches/case/fail/subrangecase6.mod
new file mode 100644
index 00000000000..46e18c769b3
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/subrangecase6.mod
@@ -0,0 +1,23 @@
+MODULE subrangecase6 ; (*!m2iso+gm2*)
+
+
+TYPE
+ alphabet = [MIN (CHAR)..MAX (CHAR)] ;
+
+
+PROCEDURE init (a: alphabet) ;
+BEGIN
+ CASE a OF
+
+ 'a',
+ 'e'..'x':
+
+ END
+END init ;
+
+
+VAR
+ a: alphabet ;
+BEGIN
+ init (a)
+END subrangecase6.
diff --git a/gcc/testsuite/gm2/switches/case/pass/subrangecase.mod b/gcc/testsuite/gm2/switches/case/pass/subrangecase.mod
new file mode 100644
index 00000000000..50bbf6ae6c6
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/subrangecase.mod
@@ -0,0 +1,24 @@
+MODULE subrangecase ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ 1910: |
+ 1911..1919: |
+ 1920: |
+
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase.
diff --git a/gcc/testsuite/gm2/switches/case/pass/subrangecase2.mod b/gcc/testsuite/gm2/switches/case/pass/subrangecase2.mod
new file mode 100644
index 00000000000..cd14c0ce197
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/subrangecase2.mod
@@ -0,0 +1,22 @@
+MODULE subrangecase2 ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ 1910..1920: |
+
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase2.
diff --git a/gcc/testsuite/gm2/switches/case/pass/subrangecase3.mod b/gcc/testsuite/gm2/switches/case/pass/subrangecase3.mod
new file mode 100644
index 00000000000..2f4837360ae
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/subrangecase3.mod
@@ -0,0 +1,23 @@
+MODULE subrangecase3 ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ 1910..1919: |
+
+ ELSE
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase3.
diff --git a/gcc/testsuite/gm2/switches/case/pass/subrangecase4.mod b/gcc/testsuite/gm2/switches/case/pass/subrangecase4.mod
new file mode 100644
index 00000000000..8a2a6724bbb
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/subrangecase4.mod
@@ -0,0 +1,21 @@
+MODULE subrangecase4 ; (*!m2iso+gm2*)
+
+
+TYPE
+ DateRange = [1910..1920] ;
+
+
+PROCEDURE init (d: DateRange) ;
+BEGIN
+ CASE d OF
+
+ ELSE
+ END
+END init ;
+
+
+VAR
+ year: DateRange ;
+BEGIN
+ init (year)
+END subrangecase4.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-09-14 18:36 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-09-14 18:36 [gcc r14-4000] modula2: introduce case checking when switching on subranges Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).