public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-7794] [PATCH] modula2: new option -Wcase-enum and associated fixes
@ 2023-09-12 12:38 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2023-09-12 12:38 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:aa3db2ba4e366517143046ddf90fbb6527fcc6f3
commit r13-7794-gaa3db2ba4e366517143046ddf90fbb6527fcc6f3
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Tue Sep 12 13:04:20 2023 +0100
[PATCH] modula2: new option -Wcase-enum and associated fixes
This patch introduces -Wcase-enum which enumerates each missing
field in a case statement without an else clause providing the selector
expression type is an enum.
gcc/ChangeLog:
* doc/gm2.texi (Compiler options): Document new option
-Wcase-enum.
gcc/m2/ChangeLog:
* gm2-compiler/M2CaseList.def (PushCase): Rename parameters
r to rec and v to va. Add expr parameter.
(MissingCaseStatementBounds): New procedure function.
* gm2-compiler/M2CaseList.mod (RangePair): Add expression.
(PushCase): Rename parameters r to rec and v to va. Add
expr parameter.
(RemoveRange): New procedure function.
(SubBitRange): Detect the case when the range in the set matches
lo..hi.
(CheckLowHigh): New procedure.
(ExcludeCaseRanges): Rename parameter c to cd. Rename local
variables q to cl and r to rp.
(High): Remove.
(Low): Remove.
(DoEnumValues): Remove.
(IncludeElement): New procedure.
(IncludeElements): New procedure.
(ErrorRangeEnum): New procedure.
(ErrorRange): Remove.
(ErrorRanges): Remove.
(appendEnum): New procedure.
(appendStr): New procedure.
(EnumerateErrors): New procedure.
(MissingCaseBounds): Re-implement.
(InRangeList): Remove.
(MissingCaseStatementBounds): New procedure function.
(checkTypes): Re-format.
(inRange): Re-format.
(TypeCaseBounds): Re-format.
* gm2-compiler/M2Error.mod (GetAnnounceScope): Add noscope to
case label list.
* gm2-compiler/M2GCCDeclare.mod: Replace ForeachFieldEnumerationDo
with ForeachLocalSymDo.
* gm2-compiler/M2Options.def (SetCaseEnumChecking): New procedure.
(CaseEnumChecking): New variable.
* gm2-compiler/M2Options.mod (SetCaseEnumChecking): New procedure.
(Module initialization): set CaseEnumChecking to FALSE.
* gm2-compiler/M2Quads.def (QuadOperator): Alphabetically ordered.
* gm2-compiler/M2Quads.mod (IsBackReferenceConditional): Add else
clause.
(BuildCaseStart): Pass selector expression to InitCaseBounds.
(CheckUninitializedVariablesAreUsed): Remove.
(IsInlineWithinBlock): Remove.
(AsmStatementsInBlock): Remove.
(CheckVariablesInBlock): Remove commented code.
(BeginVarient): Pass NulSym to InitCaseBounds.
* gm2-compiler/M2Range.mod (FoldCaseBounds): New local variable
errorGenerated. Add call to MissingCaseStatementBounds.
* gm2-compiler/P3Build.bnf (CaseEndStatement): Call ElseCase.
* gm2-compiler/PCSymBuild.mod (InitDesExpr): Add else clause.
(InitFunction): Add else clause.
(InitConvert): Add else clause.
(InitLeaf): Add else clause.
(InitBinary): Add else clause.
(InitUnary): Add else clause.
* gm2-compiler/SymbolTable.def (GetNth): Re-write comment.
(ForeachFieldEnumerationDo): Re-write comment stating alphabetical
traversal.
* gm2-compiler/SymbolTable.mod (GetNth): Re-write comment.
Add case label for EnumerationSym and call GetItemFromList.
(ForeachFieldEnumerationDo): Re-write comment stating alphabetical
traversal.
(SymEnumeration): Add ListOfFields used for declaration order.
(MakeEnumeration): Initialize ListOfFields.
(PutFieldEnumeration): Include Field in ListOfFields.
* gm2-gcc/m2options.h (M2Options_SetCaseEnumChecking): New
function.
* gm2-lang.cc (gm2_langhook_handle_option): Add
OPT_Wcase_enum case and call M2Options_SetCaseEnumChecking.
* lang.opt (Wcase-enum): Add.
gcc/testsuite/ChangeLog:
* gm2/switches/case/fail/missingclause.mod: New test.
* gm2/switches/case/fail/switches-case-fail.exp: New test.
* gm2/switches/case/pass/enumcase.mod: New test.
* gm2/switches/case/pass/enumcase2.mod: New test.
* gm2/switches/case/pass/switches-case-pass.exp: New test.
(cherry picked from commit 89b5866742a17c38cc98edd9e434cff8e3a3c7ea)
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/doc/gm2.texi | 7 +
gcc/m2/gm2-compiler/M2CaseList.def | 15 +-
gcc/m2/gm2-compiler/M2CaseList.mod | 446 ++++++++++++++-------
gcc/m2/gm2-compiler/M2Error.mod | 3 +-
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 13 +-
gcc/m2/gm2-compiler/M2Options.def | 13 +-
gcc/m2/gm2-compiler/M2Options.mod | 14 +-
gcc/m2/gm2-compiler/M2Quads.def | 115 ++++--
gcc/m2/gm2-compiler/M2Quads.mod | 144 +------
gcc/m2/gm2-compiler/M2Range.mod | 37 +-
gcc/m2/gm2-compiler/P3Build.bnf | 2 +
gcc/m2/gm2-compiler/PCSymBuild.mod | 34 +-
gcc/m2/gm2-compiler/SymbolTable.def | 9 +-
gcc/m2/gm2-compiler/SymbolTable.mod | 39 +-
gcc/m2/gm2-gcc/m2options.h | 2 +-
gcc/m2/gm2-lang.cc | 3 +
gcc/m2/lang.opt | 4 +
.../gm2/switches/case/fail/missingclause.mod | 23 ++
.../gm2/switches/case/fail/switches-case-fail.exp | 37 ++
gcc/testsuite/gm2/switches/case/pass/enumcase.mod | 24 ++
gcc/testsuite/gm2/switches/case/pass/enumcase2.mod | 22 +
.../gm2/switches/case/pass/switches-case-pass.exp | 37 ++
22 files changed, 692 insertions(+), 351 deletions(-)
diff --git a/gcc/doc/gm2.texi b/gcc/doc/gm2.texi
index 9f7f8ce6e995..bae822f2690a 100644
--- a/gcc/doc/gm2.texi
+++ b/gcc/doc/gm2.texi
@@ -659,6 +659,13 @@ zero.
@item -fwholevalue
generate code to detect whole number overflow and underflow.
+@item -Wcase-enum
+generate a warning if a @code{CASE} statement selects on an enumerated
+type expression and the statement is missing one or more @code{CASE}
+labels. No warning is issued if the @code{CASE} statement has a default
+@code{ELSE} clause.
+The option @samp{-Wall} will turn on this flag.
+
@item -Wuninit-variable-checking
issue a warning if a variable is used before it is initialized.
The checking only occurs in the first basic block in each procedure.
diff --git a/gcc/m2/gm2-compiler/M2CaseList.def b/gcc/m2/gm2-compiler/M2CaseList.def
index 224ad57a82c6..e135f14bde9e 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.def
+++ b/gcc/m2/gm2-compiler/M2CaseList.def
@@ -36,10 +36,15 @@ FROM Lists IMPORT List ;
(*
PushCase - create a case entity and push it to an internal stack.
+ rec is NulSym if this is a CASE statement.
+ If rec is a record then it indicates a possible
+ varients reside in the record to check.
+ Both rec and va might be NulSym and then the expr
+ will contain the selector expression to a case statement.
Return the case id.
*)
-PROCEDURE PushCase (r: CARDINAL; v: CARDINAL) : CARDINAL ;
+PROCEDURE PushCase (rec, va, expr: CARDINAL) : CARDINAL ;
(*
@@ -113,6 +118,14 @@ PROCEDURE OverlappingCaseBounds (c: CARDINAL) : BOOLEAN ;
PROCEDURE MissingCaseBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
+(*
+ MissingCaseStatementBounds - returns TRUE if the case statement has a missing
+ clause. It will also generate error messages.
+*)
+
+PROCEDURE MissingCaseStatementBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
+
+
(*
WriteCase - displays the case list.
*)
diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod
index a478c88f9cfb..c7596356ddf5 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -24,12 +24,12 @@ IMPLEMENTATION MODULE M2CaseList ;
FROM M2Debug IMPORT Assert ;
FROM M2GCCDeclare IMPORT TryDeclareConstant, GetTypeMin, GetTypeMax ;
-FROM M2MetaError IMPORT MetaError1, MetaError2, MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3, MetaErrorT4, MetaErrorString1 ;
+FROM M2MetaError IMPORT MetaError1, MetaError2, MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3, MetaErrorT4, MetaErrorStringT0, MetaErrorString1 ;
FROM M2Error IMPORT InternalError ;
FROM M2Range IMPORT OverlapsRange, IsEqual, IsGreater ;
FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, ForeachIndiceInIndexDo, HighIndice ;
-FROM Lists IMPORT InitList, IncludeItemIntoList ;
+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 ;
@@ -41,7 +41,7 @@ FROM M2Base IMPORT IsExpressionCompatible ;
FROM M2Printf IMPORT printf1 ;
FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType,
- ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType ;
+ ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth ;
TYPE
RangePair = POINTER TO RECORD
@@ -65,6 +65,7 @@ TYPE
elseField : CARDINAL ;
record : CARDINAL ;
varient : CARDINAL ;
+ expression : CARDINAL ;
maxCaseId : CARDINAL ;
caseListArray: Index ;
currentCase : CaseList ;
@@ -87,37 +88,39 @@ VAR
(*
PushCase - create a case entity and push it to an internal stack.
- r, is NulSym if this is a CASE statement.
- If, r, is a record then it indicates it includes one
- or more varients reside in the record. The particular
- varient is, v.
+ rec is NulSym if this is a CASE statement.
+ If rec is a record then it indicates a possible
+ varients reside in the record to check.
+ Both rec and va might be NulSym and then the expr
+ will contain the selector expression to a case statement.
Return the case id.
*)
-PROCEDURE PushCase (r: CARDINAL; v: CARDINAL) : CARDINAL ;
+PROCEDURE PushCase (rec, va, expr: CARDINAL) : CARDINAL ;
VAR
c: CaseDescriptor ;
BEGIN
- INC(caseId) ;
- NEW(c) ;
- IF c=NIL
+ INC (caseId) ;
+ NEW (c) ;
+ IF c = NIL
THEN
InternalError ('out of memory error')
ELSE
WITH c^ DO
elseClause := FALSE ;
elseField := NulSym ;
- record := r ;
- varient := v ;
+ record := rec ;
+ varient := va ;
+ expression := expr ;
maxCaseId := 0 ;
- caseListArray := InitIndex(1) ;
+ caseListArray := InitIndex (1) ;
next := caseStack ;
currentCase := NIL
END ;
caseStack := c ;
- PutIndice(caseArray, caseId, c)
+ PutIndice (caseArray, caseId, c)
END ;
- RETURN( caseId )
+ RETURN caseId
END PushCase ;
@@ -568,41 +571,62 @@ BEGIN
END DisposeRanges ;
+(*
+ RemoveRange - removes the range descriptor h from set and return the
+ possibly new head of set.
+*)
+
+PROCEDURE RemoveRange (set: SetRange; h: SetRange) : SetRange ;
+VAR
+ i: SetRange ;
+BEGIN
+ IF h=set
+ THEN
+ set := set^.next ;
+ h^.next := NIL ;
+ h := DisposeRanges(h) ;
+ ELSE
+ i := set ;
+ WHILE i^.next#h DO
+ i := i^.next
+ END ;
+ i^.next := h^.next ;
+ i := h ;
+ h := h^.next ;
+ i^.next := NIL ;
+ i := DisposeRanges(i)
+ END ;
+ RETURN set
+END RemoveRange ;
+
+
(*
SubBitRange - subtracts bits, lo..hi, from, set.
*)
PROCEDURE SubBitRange (set: SetRange; lo, hi: Tree; tokenno: CARDINAL) : SetRange ;
VAR
- h, i : SetRange ;
+ h, i: SetRange ;
BEGIN
h := set ;
WHILE h#NIL DO
+ (* Check to see if a single set element h is obliterated by lo..hi. *)
IF (h^.high=NIL) OR IsEqual(h^.high, h^.low)
THEN
IF IsEqual(h^.low, lo) OR OverlapsRange(lo, hi, h^.low, h^.low)
THEN
- IF h=set
- THEN
- set := set^.next ;
- h^.next := NIL ;
- h := DisposeRanges(h) ;
- h := set
- ELSE
- i := set ;
- WHILE i^.next#h DO
- i := i^.next
- END ;
- i^.next := h^.next ;
- i := h ;
- h := h^.next ;
- i^.next := NIL ;
- i := DisposeRanges(i)
- END
+ set := RemoveRange (set, h) ;
+ h := set
ELSE
h := h^.next
END
+ (* Now check to see if the lo..hi match exactly with the set range. *)
+ ELSIF (h^.high#NIL) AND IsEqual (lo, h^.low) AND IsEqual (hi, h^.high)
+ THEN
+ (* Remove h and return as lo..hi have been removed. *)
+ RETURN RemoveRange (set, h)
ELSE
+ (* All other cases require modifying the existing set range. *)
IF OverlapsRange(lo, hi, h^.low, h^.high)
THEN
IF IsGreater(h^.low, lo) OR IsGreater(hi, h^.high)
@@ -646,105 +670,209 @@ BEGIN
END SubBitRange ;
+(*
+ CheckLowHigh - checks to see the low value <= high value and issues an error
+ if this is not true.
+*)
+
+PROCEDURE CheckLowHigh (rp: RangePair) ;
+VAR
+ lo, hi: Tree ;
+ temp : CARDINAL ;
+BEGIN
+ lo := Mod2Gcc (rp^.low) ;
+ hi := Mod2Gcc (rp^.high) ;
+ IF IsGreater (lo, hi)
+ THEN
+ MetaErrorT2 (rp^.tokenno, 'case range should be low..high rather than high..low, range specified as {%1Euad}..{%2Euad}', rp^.low, rp^.high) ;
+ temp := rp^.high ;
+ rp^.high := rp^.low ;
+ rp^.low := temp
+ END
+END CheckLowHigh ;
+
+
(*
ExcludeCaseRanges - excludes all case ranges found in, p, from, set
*)
-PROCEDURE ExcludeCaseRanges (set: SetRange; p: CaseDescriptor) : SetRange ;
+PROCEDURE ExcludeCaseRanges (set: SetRange; cd: CaseDescriptor) : SetRange ;
VAR
i, j: CARDINAL ;
- q : CaseList ;
- r : RangePair ;
+ cl : CaseList ;
+ rp : RangePair ;
BEGIN
- WITH p^ DO
+ WITH cd^ DO
i := 1 ;
- WHILE i<=maxCaseId DO
- q := GetIndice(caseListArray, i) ;
+ WHILE i <= maxCaseId DO
+ cl := GetIndice (caseListArray, i) ;
j := 1 ;
- WHILE j<=q^.maxRangeId DO
- r := GetIndice(q^.rangeArray, j) ;
- IF r^.high=NulSym
+ WHILE j <= cl^.maxRangeId DO
+ rp := GetIndice (cl^.rangeArray, j) ;
+ IF rp^.high = NulSym
THEN
- set := SubBitRange(set, Mod2Gcc(r^.low), Mod2Gcc(r^.low), r^.tokenno)
+ set := SubBitRange (set,
+ Mod2Gcc (rp^.low),
+ Mod2Gcc (rp^.low), rp^.tokenno)
ELSE
- set := SubBitRange(set, Mod2Gcc(r^.low), Mod2Gcc(r^.high), r^.tokenno)
+ CheckLowHigh (rp) ;
+ set := SubBitRange (set,
+ Mod2Gcc (rp^.low),
+ Mod2Gcc (rp^.high), rp^.tokenno)
END ;
- INC(j)
+ INC (j)
END ;
- INC(i)
+ INC (i)
END
END ;
- RETURN( set )
+ RETURN set
END ExcludeCaseRanges ;
VAR
- High, Low : Tree ;
errorString: String ;
(*
- DoEnumValues -
+ IncludeElement -
*)
-PROCEDURE DoEnumValues (sym: CARDINAL) ;
+PROCEDURE IncludeElement (enumList: List; field: CARDINAL; low, high: Tree) ;
+VAR
+ fieldTree: Tree ;
BEGIN
- IF (Low#NIL) AND IsEqual(Mod2Gcc(sym), Low)
+ IF field # NulSym
THEN
- errorString := ConCat(errorString, InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ;
- Low := NIL
+ fieldTree := Mod2Gcc (field) ;
+ IF OverlapsRange (fieldTree, fieldTree, low, high)
+ THEN
+ IncludeItemIntoList (enumList, field)
+ END
+ END
+END IncludeElement ;
+
+
+(*
+ IncludeElements -
+*)
+
+PROCEDURE IncludeElements (type: CARDINAL; enumList: List; low, high: Tree) ;
+VAR
+ field : CARDINAL ;
+ i,
+ NoElements: CARDINAL ;
+BEGIN
+ NoElements := NoOfElements (type) ;
+ i := 1 ;
+ WHILE i <= NoElements DO
+ field := GetNth (type, i) ;
+ IncludeElement (enumList, field, low, high) ;
+ INC (i)
+ END
+END IncludeElements ;
+
+
+(*
+ ErrorRangeEnum
+*)
+
+PROCEDURE ErrorRangeEnum (type: CARDINAL; set: SetRange; enumList: List) ;
+VAR
+ Low, High: Tree ;
+BEGIN
+ Low := set^.low ;
+ High := set^.high ;
+ IF Low = NIL
+ THEN
+ Low := High
+ END ;
+ IF High = NIL
+ THEN
+ High := Low
END ;
- IF (High#NIL) AND IsEqual(Mod2Gcc(sym), High)
+ IF (Low # NIL) AND (High # NIL)
THEN
- errorString := ConCat(errorString, Mark(InitString('..'))) ;
- errorString := ConCat(errorString, Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym))))) ;
- High := NIL
+ IncludeElements (type, enumList, Low, High)
END
-END DoEnumValues ;
+END ErrorRangeEnum ;
(*
- ErrorRange -
+ ErrorRanges - return a list of all enumeration fields not present in the case statement.
+ The return value will be nil if type is not an enumeration type.
*)
-PROCEDURE ErrorRange (p: CaseDescriptor; type: CARDINAL; set: SetRange) ;
+PROCEDURE ErrorRanges (type: CARDINAL; set: SetRange) : List ;
+VAR
+ enumSet: List ;
BEGIN
- type := SkipType(type) ;
- IF IsEnumeration(type)
+ type := SkipType (type) ;
+ IF IsEnumeration (type)
THEN
- Low := set^.low ;
- High := set^.high ;
- IF IsEqual(Low, High)
- THEN
- High := NIL ;
- errorString := InitString('enumeration value ') ;
- ForeachLocalSymDo(type, DoEnumValues) ;
- errorString := ConCat(errorString, InitString(' is ignored by the CASE variant record {%1D}'))
- ELSE
- errorString := InitString('enumeration values ') ;
- ForeachLocalSymDo(type, DoEnumValues) ;
- errorString := ConCat(errorString, InitString(' are ignored by the CASE variant record {%1D}'))
+ InitList (enumSet) ;
+ WHILE set#NIL DO
+ ErrorRangeEnum (type, set, enumSet) ;
+ set := set^.next
END ;
- MetaErrorString1(errorString, p^.varient)
- END
-END ErrorRange ;
+ RETURN enumSet
+ END ;
+ RETURN NIL
+END ErrorRanges ;
+
+
+(*
+ appendEnum -
+*)
+
+PROCEDURE appendEnum (enum: CARDINAL) ;
+BEGIN
+ errorString := ConCat (errorString,
+ Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum)))))
+END appendEnum ;
(*
- ErrorRanges -
+ appendStr -
*)
-PROCEDURE ErrorRanges (p: CaseDescriptor; type: CARDINAL; set: SetRange) ;
+PROCEDURE appendStr (str: ARRAY OF CHAR) ;
BEGIN
- WHILE set#NIL DO
- ErrorRange(p, type, set) ;
- set := set^.next
+ errorString := ConCat (errorString, Mark (InitString (str)))
+END appendStr ;
+
+
+(*
+ EnumerateErrors -
+*)
+
+PROCEDURE EnumerateErrors (tokenno: CARDINAL; enumList: List) ;
+VAR
+ i, n: CARDINAL ;
+BEGIN
+ n := NoOfItemsInList (enumList) ;
+ IF (enumList # NIL) AND (n > 0)
+ THEN
+ appendEnum (GetItemFromList (enumList, 1)) ;
+ IF n > 1
+ THEN
+ IF n > 2
+ THEN
+ i := 2 ;
+ WHILE i <= n-1 DO
+ appendStr (', ') ;
+ appendEnum (GetItemFromList (enumList, i)) ;
+ INC (i)
+ END
+ END ;
+ appendStr (' and ') ;
+ appendEnum (GetItemFromList (enumList, n))
+ END
END
-END ErrorRanges ;
+END EnumerateErrors ;
(*
- MissingCaseBounds - returns TRUE if there were any missing bounds
+ MissingCaseBounds - returns true if there were any missing bounds
in the varient record case list, c. It will
generate an error message for each missing
bounds found.
@@ -757,61 +885,109 @@ VAR
missing: BOOLEAN ;
set : SetRange ;
BEGIN
- p := GetIndice(caseArray, c) ;
+ p := GetIndice (caseArray, c) ;
missing := FALSE ;
WITH p^ DO
- IF (record#NulSym) AND (varient#NulSym) AND (NOT elseClause)
+ IF NOT elseClause
THEN
- (* not a CASE statement, but a varient record containing without an ELSE clause *)
- type := GetVariantTagType(varient) ;
- set := NewSet(type) ;
- set := ExcludeCaseRanges(set, p) ;
- IF set#NIL
+ IF (record # NulSym) AND (varient # NulSym)
THEN
- missing := TRUE ;
- MetaErrorT2 (tokenno,
- 'not all variant record alternatives in the {%kCASE} clause are specified, hint you either need to specify each value of {%2ad} or use an {%kELSE} clause',
- varient, type) ;
- ErrorRanges(p, type, set)
- END ;
- set := DisposeRanges(set)
+ (* Not a case statement, but a varient record without an else clause. *)
+ type := GetVariantTagType (varient) ;
+ set := NewSet (type) ;
+ set := ExcludeCaseRanges (set, p) ;
+ IF set # NIL
+ THEN
+ missing := TRUE ;
+ MetaErrorT2 (tokenno,
+ 'not all variant record alternatives in the {%kCASE} clause are specified, hint you either need to specify each value of {%2ad} or use an {%kELSE} clause',
+ varient, type) ;
+ EnumerateErrors (tokenno, ErrorRanges (type, set))
+ END ;
+ set := DisposeRanges (set)
+ END
END
END ;
- RETURN( missing )
+ RETURN missing
END MissingCaseBounds ;
(*
- InRangeList - returns TRUE if the value, tag, is defined in the case list.
+ MissingCaseStatementBounds - returns true if the case statement has a missing
+ clause. It will also generate error messages.
+*)
-PROCEDURE InRangeList (cl: CaseList; tag: CARDINAL) : BOOLEAN ;
+PROCEDURE MissingCaseStatementBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
VAR
- i, h: CARDINAL ;
+ p : CaseDescriptor ;
+ type : CARDINAL ;
+ missing: BOOLEAN ;
+ set : SetRange ;
+BEGIN
+ p := GetIndice (caseArray, c) ;
+ missing := FALSE ;
+ WITH p^ DO
+ IF NOT elseClause
+ THEN
+ IF expression # NulSym
+ THEN
+ type := SkipType (GetType (expression)) ;
+ IF (type # NulSym) AND IsEnumeration (type)
+ 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
+ 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) ;
+ errorString := InitString ('{%W}the missing enumeration fields are: ') ;
+ EnumerateErrors (tokenno, ErrorRanges (type, set)) ;
+ MetaErrorStringT0 (tokenno, errorString)
+ END ;
+ set := DisposeRanges (set)
+ END
+ END
+ END
+ END ;
+ RETURN missing
+END MissingCaseStatementBounds ;
+
+
+(*
+ InRangeList - returns true if the value, tag, is defined in the case list.
+
+procedure InRangeList (cl: CaseList; tag: cardinal) : boolean ;
+var
+ i, h: cardinal ;
r : RangePair ;
a : Tree ;
-BEGIN
- WITH cl^ DO
+begin
+ with cl^ do
i := 1 ;
h := HighIndice(rangeArray) ;
- WHILE i<=h DO
+ while i<=h do
r := GetIndice(rangeArray, i) ;
- WITH r^ DO
- IF high=NulSym
- THEN
+ with r^ do
+ if high=NulSym
+ then
a := Mod2Gcc(low)
- ELSE
+ else
a := Mod2Gcc(high)
- END ;
- IF OverlapsRange(Mod2Gcc(low), a, Mod2Gcc(tag), Mod2Gcc(tag))
- THEN
- RETURN( TRUE )
- END
- END ;
- INC(i)
- END
- END ;
- RETURN( FALSE )
-END InRangeList ;
+ end ;
+ if OverlapsRange(Mod2Gcc(low), a, Mod2Gcc(tag), Mod2Gcc(tag))
+ then
+ return( true )
+ end
+ end ;
+ inc(i)
+ end
+ end ;
+ return( false )
+end InRangeList ;
*)
@@ -821,7 +997,7 @@ END InRangeList ;
PROCEDURE WriteCase (c: CARDINAL) ;
BEGIN
- (* this debugging procedure should be finished. *)
+ (* this debugging PROCEDURE should be finished. *)
printf1 ("%d", c)
END WriteCase ;
@@ -834,32 +1010,32 @@ PROCEDURE checkTypes (constant, type: CARDINAL) : BOOLEAN ;
VAR
consttype: CARDINAL ;
BEGIN
- IF (constant#NulSym) AND IsConst(constant)
+ IF (constant # NulSym) AND IsConst (constant)
THEN
- consttype := GetType(constant) ;
- IF NOT IsExpressionCompatible(consttype, type)
+ consttype := GetType (constant) ;
+ IF NOT IsExpressionCompatible (consttype, type)
THEN
- MetaError2('the CASE statement variant tag {%1ad} must be type compatible with the constant {%2Da:is a {%2d}}',
- type, constant) ;
- RETURN( FALSE )
+ MetaError2 ('the case statement variant tag {%1ad} must be type compatible with the constant {%2Da:is a {%2d}}',
+ type, constant) ;
+ RETURN FALSE
END
END ;
- RETURN( TRUE )
+ RETURN TRUE
END checkTypes ;
(*
- inRange - returns TRUE if, min <= i <= max.
+ inRange - returns true if, min <= i <= max.
*)
PROCEDURE inRange (i, min, max: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( OverlapsRange(Mod2Gcc(i), Mod2Gcc(i), Mod2Gcc(min), Mod2Gcc(max)) )
+ RETURN OverlapsRange (Mod2Gcc (i), Mod2Gcc (i), Mod2Gcc (min), Mod2Gcc (max))
END inRange ;
(*
- TypeCaseBounds - returns TRUE if all bounds in case list, c, are
+ TypeCaseBounds - returns true if all bounds in case list, c, are
compatible with the tagged type.
*)
@@ -915,11 +1091,11 @@ BEGIN
THEN
compatible := FALSE
END ;
- INC(j)
+ INC (j)
END ;
- INC(i)
+ INC (i)
END ;
- RETURN( compatible )
+ RETURN compatible
END
END TypeCaseBounds ;
diff --git a/gcc/m2/gm2-compiler/M2Error.mod b/gcc/m2/gm2-compiler/M2Error.mod
index 47c4c39f81be..8f42d5f7ee1e 100644
--- a/gcc/m2/gm2-compiler/M2Error.mod
+++ b/gcc/m2/gm2-compiler/M2Error.mod
@@ -868,7 +868,8 @@ BEGIN
implementation: desc := InitString ("In implementation module") |
program : desc := InitString ("In program module") |
module : desc := InitString ("In inner module") |
- procedure : desc := InitString ("In procedure")
+ procedure : desc := InitString ("In procedure") |
+ noscope : desc := InitString ("Unknown scope")
END
END ;
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 37235f08e979..3ce9cb22653d 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -117,7 +117,7 @@ FROM SymbolTable IMPORT NulSym,
ForeachOAFamily, GetOAFamily,
IsModuleWithinProcedure, IsVariableSSA,
IsVariableAtAddress, IsConstructorConstant,
- ForeachLocalSymDo, ForeachFieldEnumerationDo,
+ ForeachLocalSymDo,
ForeachProcedureDo, ForeachModuleDo,
ForeachInnerModuleDo, ForeachImportedDo,
ForeachExportedDo, PrintInitialized ;
@@ -4935,7 +4935,7 @@ BEGIN
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
- ForeachFieldEnumerationDo(type, FindMinMaxEnum) ;
+ ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MinEnumerationField )
ELSIF IsBaseType(type)
THEN
@@ -4974,7 +4974,7 @@ BEGIN
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
- ForeachFieldEnumerationDo(type, FindMinMaxEnum) ;
+ ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MaxEnumerationField )
ELSIF IsBaseType(type)
THEN
@@ -5186,7 +5186,6 @@ END CheckResolveSubrange ;
PROCEDURE TypeConstFullyDeclared (sym: CARDINAL) : Tree ;
VAR
t: Tree ;
- n: Name ;
BEGIN
IF IsEnumeration(sym)
THEN
@@ -5294,7 +5293,7 @@ PROCEDURE IsEnumerationDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
BEGIN
action := q ;
enumDeps := TRUE ;
- ForeachFieldEnumerationDo(sym, IsFieldEnumerationDependants) ;
+ ForeachLocalSymDo (sym, IsFieldEnumerationDependants) ;
RETURN( enumDeps )
END IsEnumerationDependants ;
@@ -5305,7 +5304,7 @@ END IsEnumerationDependants ;
PROCEDURE WalkEnumerationDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
- ForeachFieldEnumerationDo(sym, p)
+ ForeachLocalSymDo (sym, p)
END WalkEnumerationDependants ;
@@ -5319,7 +5318,7 @@ VAR
high, low: CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
- CheckResolveSubrange(sym) ;
+ CheckResolveSubrange (sym) ;
type := GetSType(sym) ;
IF type#NulSym
THEN
diff --git a/gcc/m2/gm2-compiler/M2Options.def b/gcc/m2/gm2-compiler/M2Options.def
index d8d3845a7394..6eefe7c771a2 100644
--- a/gcc/m2/gm2-compiler/M2Options.def
+++ b/gcc/m2/gm2-compiler/M2Options.def
@@ -70,7 +70,7 @@ EXPORT QUALIFIED SetReturnCheck, SetNilCheck, SetCaseCheck,
IndexChecking, RangeChecking,
ReturnChecking, CaseElseChecking,
AutoInit,
- VariantValueChecking,
+ VariantValueChecking, CaseEnumChecking,
UnusedVariableChecking, UnusedParameterChecking,
UninitVariableChecking, SetUninitVariableChecking,
UninitVariableConditionalChecking,
@@ -97,7 +97,7 @@ EXPORT QUALIFIED SetReturnCheck, SetNilCheck, SetCaseCheck,
SetGenModuleList, GetGenModuleFilename, SharedFlag,
SetB, GetB, SetMD, GetMD, SetMMD, GetMMD, SetObj, GetObj,
GetMQ, SetMQ, SetM2Prefix, GetM2Prefix,
- SetM2PathName, GetM2PathName ;
+ SetM2PathName, GetM2PathName, SetCaseEnumChecking ;
VAR
@@ -149,6 +149,8 @@ VAR
VariantValueChecking, (* Should we check all values are present *)
(* in a variant record? True for ISO and *)
(* false for PIM. *)
+ CaseEnumChecking, (* Should the compiler check for missing *)
+ (* enumeration labels in a case statement? *)
Quiet, (* -fquiet option specified. *)
LineDirectives, (* Should compiler understand preprocessor *)
(* # linenumber "filename" markers? *)
@@ -936,6 +938,13 @@ PROCEDURE SetShared (value: BOOLEAN) ;
PROCEDURE SetUninitVariableChecking (value: BOOLEAN; arg: ADDRESS) : INTEGER ;
+(*
+ SetCaseEnumChecking - sets the CaseEnumChecking to value.
+*)
+
+PROCEDURE SetCaseEnumChecking (value: BOOLEAN) ;
+
+
(*
FinaliseOptions - once all options have been parsed we set any inferred
values.
diff --git a/gcc/m2/gm2-compiler/M2Options.mod b/gcc/m2/gm2-compiler/M2Options.mod
index 1174a0d54222..f265aa5da2b5 100644
--- a/gcc/m2/gm2-compiler/M2Options.mod
+++ b/gcc/m2/gm2-compiler/M2Options.mod
@@ -1193,7 +1193,8 @@ BEGIN
UninitVariableChecking := value ;
PedanticCast := value ;
PedanticParamNames := value ;
- StyleChecking := value
+ StyleChecking := value ;
+ CaseEnumChecking := value
END SetWall ;
@@ -1405,6 +1406,16 @@ BEGIN
END SetUninitVariableChecking ;
+(*
+ SetCaseEnumChecking - sets the CaseEnumChecking to value.
+*)
+
+PROCEDURE SetCaseEnumChecking (value: BOOLEAN) ;
+BEGIN
+ CaseEnumChecking := value
+END SetCaseEnumChecking ;
+
+
BEGIN
cflag := FALSE ; (* -c. *)
RuntimeModuleOverride := InitString (DefaultRuntimeModuleOverride) ;
@@ -1477,6 +1488,7 @@ BEGIN
DumpDir := NIL ;
UninitVariableChecking := FALSE ;
UninitVariableConditionalChecking := FALSE ;
+ CaseEnumChecking := FALSE ;
M2Prefix := InitString ('') ;
M2PathName := InitString ('')
END M2Options.
diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def
index 3fc9dfbdb34b..743589f2a409 100644
--- a/gcc/m2/gm2-compiler/M2Quads.def
+++ b/gcc/m2/gm2-compiler/M2Quads.def
@@ -150,38 +150,93 @@ EXPORT QUALIFIED StartBuildDefFile, StartBuildModFile, EndBuildFile,
TYPE
- QuadOperator = (BecomesOp, IndrXOp, XIndrOp, ArrayOp, ElementSizeOp,
- RecordFieldOp,
- AddrOp, SizeOp,
- IfEquOp, IfLessEquOp, IfGreEquOp, IfGreOp, IfLessOp,
- IfNotEquOp, IfInOp, IfNotInOp,
- CallOp, ParamOp, OptParamOp, ReturnOp, ReturnValueOp, FunctValueOp,
- NewLocalVarOp, KillLocalVarOp,
- ProcedureScopeOp, ModuleScopeOp,
- DummyOp,
- GotoOp, InitEndOp, InitStartOp,
- FinallyStartOp, FinallyEndOp,
- RetryOp, TryOp, CatchBeginOp, CatchEndOp, ThrowOp,
- NegateOp, AddOp, SubOp, MultOp,
- DivM2Op, ModM2Op,
- DivCeilOp, ModCeilOp,
- DivFloorOp, ModFloorOp, DivTruncOp, ModTruncOp,
- LogicalOrOp, LogicalAndOp, LogicalXorOp, LogicalDiffOp,
+ QuadOperator = (AddOp,
+ AddrOp,
ArithAddOp,
- InclOp, ExclOp, LogicalShiftOp, LogicalRotateOp,
- UnboundedOp, HighOp,
- CoerceOp, ConvertOp, CastOp,
+ ArrayOp,
+ BecomesOp,
+ BuiltinConstOp,
+ BuiltinTypeInfoOp,
+ CallOp,
+ CastOp,
+ CatchBeginOp,
+ CatchEndOp,
+ CodeOffOp,
+ CodeOnOp,
+ CoerceOp,
+ ConvertOp,
+ DivCeilOp,
+ DivFloorOp,
+ DivM2Op,
+ DivTruncOp,
+ DummyOp,
+ ElementSizeOp,
+ EndFileOp,
+ ErrorOp,
+ ExclOp,
+ FinallyEndOp,
+ FinallyStartOp,
+ FunctValueOp,
+ GotoOp,
+ HighOp,
+ IfEquOp,
+ IfGreEquOp,
+ IfGreOp,
+ IfInOp,
+ IfLessEquOp,
+ IfLessOp,
+ IfNotEquOp,
+ IfNotInOp,
+ InclOp,
+ IndrXOp,
InitAddressOp,
- StartDefFileOp, StartModFileOp, EndFileOp,
- CodeOnOp, CodeOffOp,
- ProfileOnOp, ProfileOffOp,
- OptimizeOnOp, OptimizeOffOp,
- InlineOp, LineNumberOp, StatementNoteOp,
- SubrangeLowOp, SubrangeHighOp,
- BuiltinConstOp, BuiltinTypeInfoOp, StandardFunctionOp,
- SavePriorityOp, RestorePriorityOp,
- SaveExceptionOp, RestoreExceptionOp,
- RangeCheckOp, ErrorOp) ;
+ InitEndOp,
+ InitStartOp,
+ InlineOp,
+ KillLocalVarOp,
+ LineNumberOp,
+ LogicalAndOp,
+ LogicalDiffOp,
+ LogicalOrOp,
+ LogicalRotateOp,
+ LogicalShiftOp,
+ LogicalXorOp,
+ ModCeilOp,
+ ModFloorOp,
+ ModM2Op,
+ ModTruncOp,
+ ModuleScopeOp,
+ MultOp,
+ NegateOp,
+ NewLocalVarOp,
+ OptimizeOffOp,
+ OptimizeOnOp,
+ OptParamOp,
+ ParamOp,
+ ProcedureScopeOp,
+ ProfileOffOp,
+ ProfileOnOp,
+ RangeCheckOp,
+ RecordFieldOp,
+ RestoreExceptionOp,
+ RestorePriorityOp,
+ RetryOp,
+ ReturnOp,
+ ReturnValueOp,
+ SaveExceptionOp,
+ SavePriorityOp,
+ SizeOp,
+ StandardFunctionOp,
+ StartDefFileOp,
+ StartModFileOp,
+ StatementNoteOp,
+ SubOp,
+ SubrangeHighOp,
+ SubrangeLowOp,
+ ThrowOp,
+ TryOp,
+ UnboundedOp,
+ XIndrOp) ;
(*
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index c11e61fbb0c3..be837b328e5d 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -693,6 +693,8 @@ BEGIN
RETURN( TRUE )
END
+ ELSE
+ RETURN FALSE
END ;
i := GetNextQuad (i)
END ;
@@ -4660,15 +4662,17 @@ END BuildEndFor ;
<- Ptr
+------------+
- Empty | 0 | 0 |
- |------------|
| 0 | 0 |
|------------|
+ | 0 | 0 |
+ +-------------+ |------------|
+ | Expr | | | Expr | |
+ |-------------| |------------|
*)
PROCEDURE BuildCaseStart ;
BEGIN
- BuildRange (InitCaseBounds (PushCase (NulSym, NulSym))) ;
+ BuildRange (InitCaseBounds (PushCase (NulSym, NulSym, OperandT (1)))) ;
PushBool (0, 0) ; (* BackPatch list initialized *)
PushBool (0, 0) (* Room for a boolean expression *)
END BuildCaseStart ;
@@ -10759,143 +10763,13 @@ BEGIN
END LoopAnalysis ;
-(*
- CheckUninitializedVariablesAreUsed - checks to see whether uninitialized variables are used.
-*)
-
-PROCEDURE CheckUninitializedVariablesAreUsed (BlockSym: CARDINAL) ;
-VAR
- i, n,
- ParamNo : CARDINAL ;
- ReadStart,
- ReadEnd,
- WriteStart,
- WriteEnd : CARDINAL ;
-BEGIN
- IF IsProcedure(BlockSym)
- THEN
- ParamNo := NoOfParam(BlockSym)
- ELSE
- ParamNo := 0
- END ;
- i := 1 ;
- REPEAT
- n := GetNth(BlockSym, i) ;
- IF (n#NulSym) AND (NOT IsTemporary(n)) AND
- (IsProcedure(BlockSym) OR (((IsDefImp(BlockSym) AND (GetMainModule()=BlockSym)) OR IsModule(BlockSym)) AND
- (NOT IsExported(BlockSym, n))))
- THEN
- GetReadQuads(n, RightValue, ReadStart, ReadEnd) ;
- GetWriteQuads(n, RightValue, WriteStart, WriteEnd) ;
- IF i<=ParamNo
- THEN
- (* n is a parameter *)
- IF UnusedParameterChecking
- THEN
- IF ReadStart = 0
- THEN
- IF WriteStart = 0
- THEN
- MetaError2 ('unused parameter {%1WMad} in procedure {%2ad}', n, BlockSym)
- ELSE
- IF NOT IsVarParam (BlockSym, i)
- THEN
- (* --fixme-- reconsider this. *)
- (* MetaError2 ('writing to a non var parameter {%1WMad} and never reading from it in procedure {%2ad}',
- n, BlockSym) *)
- END
- END
- END
- END
- ELSE
- (* n is a local variable *)
- IF UnusedVariableChecking
- THEN
- IF ReadStart=0
- THEN
- IF WriteStart=0
- THEN
- MetaError2 ('unused variable {%1WMad} in {%2d} {%2ad}', n, BlockSym)
- ELSE
- (* --fixme-- reconsider this. *)
- (* MetaError2 ('writing to a variable {%1WMad} and never reading from it in {%2d} {%2ad}', n, BlockSym) *)
- END
- ELSE
- IF WriteStart=0
- THEN
- MetaError2 ('variable {%1WMad} is being used but it is never initialized in {%2d} {%2ad}', n, BlockSym)
- END
- END
- END
- END
- END ;
- INC(i)
- UNTIL n=NulSym
-END CheckUninitializedVariablesAreUsed ;
-
-
-(*
- IsInlineWithinBlock - returns TRUE if an InlineOp is found
- within start..end.
-*)
-
-PROCEDURE IsInlineWithinBlock (start, end: CARDINAL) : BOOLEAN ;
-VAR
- op : QuadOperator ;
- op1, op2, op3: CARDINAL ;
-BEGIN
- WHILE (start#end) AND (start#0) DO
- GetQuad(start, op, op1, op2, op3) ;
- IF op=InlineOp
- THEN
- RETURN( TRUE )
- END ;
- start := GetNextQuad(start)
- END ;
- RETURN( FALSE )
-END IsInlineWithinBlock ;
-
-
-(*
- AsmStatementsInBlock - returns TRUE if an ASM statement is found within a block, BlockSym.
-*)
-
-PROCEDURE AsmStatementsInBlock (BlockSym: CARDINAL) : BOOLEAN ;
-VAR
- Scope,
- StartInit,
- EndInit,
- StartFinish,
- EndFinish : CARDINAL ;
-BEGIN
- IF IsProcedure(BlockSym)
- THEN
- GetProcedureQuads(BlockSym, Scope, StartInit, EndInit) ;
- RETURN( IsInlineWithinBlock(StartInit, EndInit) )
- ELSE
- GetModuleQuads(BlockSym, StartInit, EndInit, StartFinish, EndFinish) ;
- RETURN( IsInlineWithinBlock(StartInit, EndInit) OR
- IsInlineWithinBlock(StartFinish, EndFinish) )
- END
-END AsmStatementsInBlock ;
-
-
(*
CheckVariablesInBlock - given a block, BlockSym, check whether all variables are used.
*)
PROCEDURE CheckVariablesInBlock (BlockSym: CARDINAL) ;
BEGIN
- CheckVariablesAndParameterTypesInBlock (BlockSym) ;
- (*
- IF UnusedVariableChecking OR UnusedParameterChecking
- THEN
- IF (NOT AsmStatementsInBlock (BlockSym))
- THEN
- CheckUninitializedVariablesAreUsed (BlockSym)
- END
- END
- *)
+ CheckVariablesAndParameterTypesInBlock (BlockSym)
END CheckVariablesInBlock ;
@@ -14434,7 +14308,7 @@ BEGIN
Assert(IsRecord(r) OR IsFieldVarient(r)) ;
v := GetRecordOrField() ;
Assert(IsVarient(v)) ;
- BuildRange(InitCaseBounds(PushCase(r, v)))
+ BuildRange(InitCaseBounds(PushCase(r, v, NulSym)))
END BeginVarient ;
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index 0f8678eea9f0..0f7c740a1ea1 100644
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -56,7 +56,7 @@ FROM M2Debug IMPORT Assert ;
FROM Indexing IMPORT Index, InitIndex, InBounds, PutIndice, GetIndice ;
FROM Storage IMPORT ALLOCATE ;
FROM M2ALU IMPORT PushIntegerTree, PushInt, ConvertToInt, Equ, Gre, Less, GreEqu ;
-FROM M2Options IMPORT VariantValueChecking ;
+FROM M2Options IMPORT VariantValueChecking, CaseEnumChecking ;
FROM M2Error IMPORT Error, InternalError, ErrorFormat0, ErrorFormat1, ErrorFormat2, FlushErrors,
GetAnnounceScope ;
@@ -103,8 +103,9 @@ FROM M2Base IMPORT Nil, IsRealType, GetBaseTypeMinMax,
ExceptionParameterBounds,
ExceptionNo ;
-FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds, WriteCase, MissingCaseBounds, TypeCaseBounds ;
-
+FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds,
+ WriteCase, MissingCaseBounds, TypeCaseBounds,
+ MissingCaseStatementBounds ;
TYPE
TypeOfRange = (assignment, returnassignment, subrangeassignment,
@@ -1915,12 +1916,14 @@ END FoldDynamicArraySubscript ;
PROCEDURE FoldCaseBounds (tokenno: CARDINAL; q: CARDINAL; r: CARDINAL) ;
VAR
- p: Range ;
+ p : Range ;
+ errorGenerated: BOOLEAN ;
BEGIN
p := GetIndice(RangeIndex, r) ;
WITH p^ DO
IF CaseBoundsResolved(tokenno, caseList)
THEN
+ errorGenerated := FALSE ;
IF TypeCaseBounds (caseList)
THEN
(* nothing to do *)
@@ -1928,14 +1931,26 @@ BEGIN
IF OverlappingCaseBounds(caseList)
THEN
PutQuad(q, ErrorOp, NulSym, NulSym, r) ;
- IF VariantValueChecking AND MissingCaseBounds(tokenno, caseList)
+ errorGenerated := TRUE
+ END ;
+ IF VariantValueChecking AND MissingCaseBounds(tokenno, caseList)
+ THEN
+ IF NOT errorGenerated
THEN
- (* nothing to do *)
+ PutQuad(q, ErrorOp, NulSym, NulSym, r) ;
+ errorGenerated := TRUE
END
- ELSIF VariantValueChecking AND MissingCaseBounds(tokenno, caseList)
+ END ;
+ IF CaseEnumChecking AND MissingCaseStatementBounds (tokenno, caseList)
+ THEN
+ IF NOT errorGenerated
+ THEN
+ PutQuad(q, ErrorOp, NulSym, NulSym, r) ;
+ errorGenerated := TRUE
+ END
+ END ;
+ IF NOT errorGenerated
THEN
- PutQuad(q, ErrorOp, NulSym, NulSym, r)
- ELSE
SubQuad(q)
END
END
@@ -1964,6 +1979,10 @@ BEGIN
(* nothing to do *)
END ;
IF MissingCaseBounds (tokenno, caseList)
+ THEN
+ (* nothing to do *)
+ END ;
+ IF CaseEnumChecking AND MissingCaseStatementBounds (tokenno, caseList)
THEN
(* nothing to do *)
END
diff --git a/gcc/m2/gm2-compiler/P3Build.bnf b/gcc/m2/gm2-compiler/P3Build.bnf
index bcff7579164d..15c31fb854af 100644
--- a/gcc/m2/gm2-compiler/P3Build.bnf
+++ b/gcc/m2/gm2-compiler/P3Build.bnf
@@ -55,6 +55,7 @@ FROM M2Printf IMPORT printf0, printf1 ;
FROM M2Debug IMPORT Assert ;
FROM P2SymBuild IMPORT BuildString, BuildNumber ;
FROM M2MetaError IMPORT MetaErrorT0 ;
+FROM M2CaseList IMPORT ElseCase ;
FROM M2Reserved IMPORT tokToTok, toktype,
NulTok, ImportTok, ExportTok, QualifiedTok, UnQualifiedTok,
@@ -1207,6 +1208,7 @@ CaseEndStatement := "END" % Bui
% BuildCaseEnd %
| "ELSE" % BuildStmtNote (-1) %
% BuildCaseElse %
+ % ElseCase (NulSym) %
StatementSequence % BuildStmtNote (0) %
"END"
% BuildCaseEnd %
diff --git a/gcc/m2/gm2-compiler/PCSymBuild.mod b/gcc/m2/gm2-compiler/PCSymBuild.mod
index c6708d522316..2b9e913757bb 100644
--- a/gcc/m2/gm2-compiler/PCSymBuild.mod
+++ b/gcc/m2/gm2-compiler/PCSymBuild.mod
@@ -806,7 +806,7 @@ PROCEDURE InitDesExpr (des: CARDINAL) ;
VAR
e: exprNode ;
BEGIN
- NEW(e) ;
+ NEW (e) ;
WITH e^ DO
tag := designator ;
CASE tag OF
@@ -819,6 +819,8 @@ BEGIN
left := NIL
END
+ ELSE
+ InternalError ('expecting designator')
END
END ;
PushAddress (exprStack, e)
@@ -1168,6 +1170,8 @@ BEGIN
third := more
END
+ ELSE
+ InternalError ('expecting function')
END
END ;
PushAddress (exprStack, n)
@@ -1194,6 +1198,8 @@ BEGIN
expr := e
END
+ ELSE
+ InternalError ('expecting convert')
END
END ;
PushAddress(exprStack, n)
@@ -1208,7 +1214,7 @@ PROCEDURE InitLeaf (m: constType; s, t: CARDINAL) ;
VAR
l: exprNode ;
BEGIN
- NEW(l) ;
+ NEW (l) ;
WITH l^ DO
tag := leaf ;
CASE tag OF
@@ -1219,9 +1225,11 @@ BEGIN
sym := s
END
+ ELSE
+ InternalError ('expecting leaf')
END
END ;
- PushAddress(exprStack, l)
+ PushAddress (exprStack, l)
END InitLeaf ;
@@ -1513,9 +1521,9 @@ PROCEDURE InitBinary (m: constType; t: CARDINAL; o: Name) ;
VAR
l, r, b: exprNode ;
BEGIN
- r := PopAddress(exprStack) ;
- l := PopAddress(exprStack) ;
- NEW(b) ;
+ r := PopAddress (exprStack) ;
+ l := PopAddress (exprStack) ;
+ NEW (b) ;
WITH b^ DO
tag := binary ;
CASE tag OF
@@ -1527,9 +1535,11 @@ BEGIN
right := r ;
op := o
END
+ ELSE
+ InternalError ('expecting binary')
END
END ;
- PushAddress(exprStack, b)
+ PushAddress (exprStack, b)
END InitBinary ;
@@ -1541,10 +1551,10 @@ PROCEDURE BuildRelationConst ;
VAR
op: Name ;
BEGIN
- PopT(op) ;
+ PopT (op) ;
IF inDesignator
THEN
- InitBinary(boolean, Boolean, op)
+ InitBinary (boolean, Boolean, op)
END
END BuildRelationConst ;
@@ -1557,10 +1567,10 @@ PROCEDURE BuildBinaryConst ;
VAR
op: Name ;
BEGIN
- PopT(op) ;
+ PopT (op) ;
IF inDesignator
THEN
- InitBinary(unknown, NulSym, op)
+ InitBinary (unknown, NulSym, op)
END
END BuildBinaryConst ;
@@ -1586,6 +1596,8 @@ BEGIN
op := o
END
+ ELSE
+ InternalError ('expecting unary')
END
END ;
PushAddress(exprStack, b)
diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def
index 9579a42ca0a3..e7356da42a78 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.def
+++ b/gcc/m2/gm2-compiler/SymbolTable.def
@@ -1223,8 +1223,9 @@ PROCEDURE FromModuleGetSym (tok: CARDINAL;
(*
- GetNth - returns the n th symbol in the list of father Sym.
- Sym may be a Module, DefImp, Procedure or Record symbol.
+ GetNth - returns the n th symbol in the list associated with the scope
+ of Sym. Sym may be a Module, DefImp, Procedure, Record or
+ Enumeration symbol.
*)
PROCEDURE GetNth (Sym: CARDINAL; n: CARDINAL) : CARDINAL ;
@@ -2426,7 +2427,9 @@ PROCEDURE ForeachParamSymDo (Sym: CARDINAL; P: PerformOperation) ;
(*
ForeachFieldEnumerationDo - for each field in enumeration, Sym,
- do procedure, P.
+ do procedure, P. Each call to P contains
+ an enumeration field, the order is alphabetical.
+ Use ForeachLocalSymDo for declaration order.
*)
PROCEDURE ForeachFieldEnumerationDo (Sym: CARDINAL; P: PerformOperation) ;
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index 64dfddecd8ce..891b29985b8b 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -284,7 +284,8 @@ TYPE
(* of enumeration. *)
NoOfElements: CARDINAL ; (* No elements in enumeration *)
LocalSymbols: SymbolTree ; (* Contains all enumeration *)
- (* fields. *)
+ (* fields (alphabetical). *)
+ ListOfFields: List ; (* Ordered as declared. *)
Size : PtrToValue ; (* Size at runtime of symbol. *)
packedInfo : PackedInfo ; (* the equivalent packed type *)
oafamily : CARDINAL ; (* The oafamily for this sym *)
@@ -4635,6 +4636,7 @@ BEGIN
(* enumeration type. *)
Size := InitValue () ; (* Size at runtime of sym *)
InitTree (LocalSymbols) ; (* Enumeration fields. *)
+ InitList (ListOfFields) ; (* Ordered as declared. *)
InitPacked (packedInfo) ; (* not packed and no *)
(* equivalent (yet). *)
oafamily := oaf ; (* The open array family *)
@@ -6537,8 +6539,9 @@ END GetNthFromComponent ;
(*
- GetNth - returns the n th symbol in the list of father Sym.
- Sym may be a Module, DefImp, Procedure or Record symbol.
+ GetNth - returns the n th symbol in the list associated with the scope
+ of Sym. Sym may be a Module, DefImp, Procedure, Record or
+ Enumeration symbol.
*)
PROCEDURE GetNth (Sym: CARDINAL; n: CARDINAL) : CARDINAL ;
@@ -6550,14 +6553,15 @@ BEGIN
WITH pSym^ DO
CASE SymbolType OF
- RecordSym : i := GetItemFromList(Record.ListOfSons, n) |
- VarientSym : i := GetItemFromList(Varient.ListOfSons, n) |
- VarientFieldSym : i := GetItemFromList(VarientField.ListOfSons, n) |
- ProcedureSym : i := GetItemFromList(Procedure.ListOfVars, n) |
- DefImpSym : i := GetItemFromList(DefImp.ListOfVars, n) |
- ModuleSym : i := GetItemFromList(Module.ListOfVars, n) |
- TupleSym : i := GetFromIndex(Tuple.list, n) |
- VarSym : i := GetNthFromComponent(Sym, n)
+ RecordSym : i := GetItemFromList (Record.ListOfSons, n) |
+ VarientSym : i := GetItemFromList (Varient.ListOfSons, n) |
+ VarientFieldSym : i := GetItemFromList (VarientField.ListOfSons, n) |
+ ProcedureSym : i := GetItemFromList (Procedure.ListOfVars, n) |
+ DefImpSym : i := GetItemFromList (DefImp.ListOfVars, n) |
+ ModuleSym : i := GetItemFromList (Module.ListOfVars, n) |
+ TupleSym : i := GetFromIndex (Tuple.list, n) |
+ VarSym : i := GetNthFromComponent (Sym, n) |
+ EnumerationSym : i := GetItemFromList (Enumeration.ListOfFields, n)
ELSE
InternalError ('cannot GetNth from this symbol')
@@ -7428,7 +7432,8 @@ BEGIN
FieldName,
GetDeclaredMod(GetSymKey(LocalSymbols, FieldName)))
ELSE
- PutSymKey(LocalSymbols, FieldName, Field)
+ PutSymKey(LocalSymbols, FieldName, Field) ;
+ IncludeItemIntoList (ListOfFields, Field)
END
END
@@ -12233,6 +12238,7 @@ VAR
pSym: PtrToSymbol ;
s : CARDINAL ;
BEGIN
+ s := NulSym ;
IF IsModule (sym) OR IsDefImp (sym)
THEN
RETURN( CollectSymbolFrom (tok, sym, n) )
@@ -12257,7 +12263,8 @@ BEGIN
s := CollectUnknown (tok, GetScope (sym), n)
END ;
RETURN( s )
- END
+ END ;
+ RETURN( s )
END CollectUnknown ;
@@ -13561,7 +13568,9 @@ END ForeachModuleDo ;
(*
ForeachFieldEnumerationDo - for each field in enumeration, Sym,
- do procedure, P.
+ do procedure, P. Each call to P contains
+ an enumeration field, the order is alphabetical.
+ Use ForeachLocalSymDo for declaration order.
*)
PROCEDURE ForeachFieldEnumerationDo (Sym: CARDINAL; P: PerformOperation) ;
@@ -13572,7 +13581,7 @@ BEGIN
WITH pSym^ DO
CASE SymbolType OF
- EnumerationSym: ForeachNodeDo( Enumeration.LocalSymbols, P)
+ EnumerationSym: ForeachNodeDo (Enumeration.LocalSymbols, P)
ELSE
InternalError ('expecting Enumeration symbol')
diff --git a/gcc/m2/gm2-gcc/m2options.h b/gcc/m2/gm2-gcc/m2options.h
index dd79509737e2..8bd820fcc782 100644
--- a/gcc/m2/gm2-gcc/m2options.h
+++ b/gcc/m2/gm2-gcc/m2options.h
@@ -137,7 +137,7 @@ EXTERN char *M2Options_GetM2Prefix (void);
EXTERN void M2Options_SetM2PathName (const char *arg);
EXTERN char *M2Options_GetM2PathName (void);
EXTERN int M2Options_SetUninitVariableChecking (bool value, const char *arg);
-
+EXTERN void M2Options_SetCaseEnumChecking (bool value);
#undef EXTERN
#endif /* m2options_h. */
diff --git a/gcc/m2/gm2-lang.cc b/gcc/m2/gm2-lang.cc
index c21d29b37e62..2b702cd6daa8 100644
--- a/gcc/m2/gm2-lang.cc
+++ b/gcc/m2/gm2-lang.cc
@@ -479,6 +479,9 @@ gm2_langhook_handle_option (
case OPT_Wall:
M2Options_SetWall (value);
return 1;
+ case OPT_Wcase_enum:
+ M2Options_SetCaseEnumChecking (value);
+ return 1;
#if 0
/* Not yet implemented. */
case OPT_fxcode:
diff --git a/gcc/m2/lang.opt b/gcc/m2/lang.opt
index 730a1a28683e..f906d4e8b809 100644
--- a/gcc/m2/lang.opt
+++ b/gcc/m2/lang.opt
@@ -277,6 +277,10 @@ Wall
Modula-2
; Documented in c.opt
+Wcase-enum
+Modula-2
+turns on case statement label compile time checking when using an expression of an enum type.
+
Wpedantic
Modula-2
; Documented in common.opt
diff --git a/gcc/testsuite/gm2/switches/case/fail/missingclause.mod b/gcc/testsuite/gm2/switches/case/fail/missingclause.mod
new file mode 100644
index 000000000000..153ed9b3b0bd
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/missingclause.mod
@@ -0,0 +1,23 @@
+MODULE missingclause ; (*!m2iso+gm2*)
+
+
+TYPE
+ colour = (red, green, blue) ;
+
+
+PROCEDURE init (c: colour) ;
+BEGIN
+ CASE c OF
+
+ red,
+ blue: (* User forgets green. *)
+
+ END
+END init ;
+
+
+VAR
+ rgb: colour ;
+BEGIN
+ init (rgb)
+END missingclause.
diff --git a/gcc/testsuite/gm2/switches/case/fail/switches-case-fail.exp b/gcc/testsuite/gm2/switches/case/fail/switches-case-fail.exp
new file mode 100644
index 000000000000..2a3d48ce0d69
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/fail/switches-case-fail.exp
@@ -0,0 +1,37 @@
+# Expect driver script for GCC Regression Tests
+# Copyright (C) 2023 Free Software Foundation, Inc.
+
+# This program 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 3 of the License, or
+# (at your option) any later version.
+#
+# This program 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+# load support procs
+load_lib gm2-torture.exp
+
+gm2_init_iso "${srcdir}/gm2/switches/case/fail/" -Wcase-enum -Werror
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $testcase] then {
+ continue
+ }
+
+ gm2-torture-fail $testcase
+}
diff --git a/gcc/testsuite/gm2/switches/case/pass/enumcase.mod b/gcc/testsuite/gm2/switches/case/pass/enumcase.mod
new file mode 100644
index 000000000000..7876598f4171
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/enumcase.mod
@@ -0,0 +1,24 @@
+MODULE enumcase ; (*!m2iso+gm2*)
+
+
+TYPE
+ colour = (red, blue, green) ;
+
+PROCEDURE init (c: colour) ;
+BEGIN
+ CASE c OF
+
+ red: |
+ (* blue..green: *)
+ blue,
+ green:
+
+ END
+END init ;
+
+
+VAR
+ rgb: colour ;
+BEGIN
+ init (rgb)
+END enumcase.
diff --git a/gcc/testsuite/gm2/switches/case/pass/enumcase2.mod b/gcc/testsuite/gm2/switches/case/pass/enumcase2.mod
new file mode 100644
index 000000000000..796bc80aeeb6
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/enumcase2.mod
@@ -0,0 +1,22 @@
+MODULE enumcase2 ; (*!m2iso+gm2*)
+
+
+TYPE
+ colour = (red, blue, green) ;
+
+PROCEDURE init (c: colour) ;
+BEGIN
+ CASE c OF
+
+ red: |
+ blue..green:
+
+ END
+END init ;
+
+
+VAR
+ rgb: colour ;
+BEGIN
+ init (rgb)
+END enumcase2.
diff --git a/gcc/testsuite/gm2/switches/case/pass/switches-case-pass.exp b/gcc/testsuite/gm2/switches/case/pass/switches-case-pass.exp
new file mode 100644
index 000000000000..92124aefa4a6
--- /dev/null
+++ b/gcc/testsuite/gm2/switches/case/pass/switches-case-pass.exp
@@ -0,0 +1,37 @@
+# Expect driver script for GCC Regression Tests
+# Copyright (C) 2003-2023 Free Software Foundation, Inc.
+
+# This program 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 3 of the License, or
+# (at your option) any later version.
+#
+# This program 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+# load support procs
+load_lib gm2-torture.exp
+
+gm2_init_iso "${srcdir}/gm2/switches/case/pass" -Wcase-enum -Werror
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $testcase] then {
+ continue
+ }
+
+ gm2-torture $testcase
+}
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-09-12 12:38 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-09-12 12:38 [gcc r13-7794] [PATCH] modula2: new option -Wcase-enum and associated fixes 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).