From: Gaius Mulley Date: Tue, 12 Sep 2023 09:50:44 +0000 (+0100) Subject: modula2: new option -Wcase-enum and associated fixes X-Git-Tag: basepoints/gcc-15~6265 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=89b5866742a17c38cc98edd9e434cff8e3a3c7ea;p=thirdparty%2Fgcc.git 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. Signed-off-by: Gaius Mulley --- 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 aabaef4c5adb..86f896e4d8c4 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -292,7 +292,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 *) @@ -4644,6 +4645,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 *) @@ -6636,8 +6638,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 ; @@ -6649,14 +6652,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') @@ -7528,7 +7532,8 @@ BEGIN FieldName, GetDeclaredMod(GetSymKey(LocalSymbols, FieldName))) ELSE - PutSymKey(LocalSymbols, FieldName, Field) + PutSymKey(LocalSymbols, FieldName, Field) ; + IncludeItemIntoList (ListOfFields, Field) END END @@ -12333,6 +12338,7 @@ VAR pSym: PtrToSymbol ; s : CARDINAL ; BEGIN + s := NulSym ; IF IsModule (sym) OR IsDefImp (sym) THEN RETURN( CollectSymbolFrom (tok, sym, n) ) @@ -12355,10 +12361,9 @@ BEGIN END END ; s := CollectUnknown (tok, GetScope (sym), n) - END ; - RETURN( s ) + END END ; - InternalError ('expecting sym should be a module, defimp or procedure symbol') + RETURN( s ) END CollectUnknown ; @@ -13662,7 +13667,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) ; @@ -13673,7 +13680,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 +# . + +# 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 +# . + +# 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 +}