@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.
(*
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 ;
(*
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.
*)
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 ;
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
elseField : CARDINAL ;
record : CARDINAL ;
varient : CARDINAL ;
+ expression : CARDINAL ;
maxCaseId : CARDINAL ;
caseListArray: Index ;
currentCase : CaseList ;
(*
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 ;
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)
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.
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 ;
*)
PROCEDURE WriteCase (c: CARDINAL) ;
BEGIN
- (* this debugging procedure should be finished. *)
+ (* this debugging PROCEDURE should be finished. *)
printf1 ("%d", c)
END WriteCase ;
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.
*)
THEN
compatible := FALSE
END ;
- INC(j)
+ INC (j)
END ;
- INC(i)
+ INC (i)
END ;
- RETURN( compatible )
+ RETURN compatible
END
END TypeCaseBounds ;
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 ;
ForeachOAFamily, GetOAFamily,
IsModuleWithinProcedure, IsVariableSSA,
IsVariableAtAddress, IsConstructorConstant,
- ForeachLocalSymDo, ForeachFieldEnumerationDo,
+ ForeachLocalSymDo,
ForeachProcedureDo, ForeachModuleDo,
ForeachInnerModuleDo, ForeachImportedDo,
ForeachExportedDo, PrintInitialized ;
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
- ForeachFieldEnumerationDo(type, FindMinMaxEnum) ;
+ ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MinEnumerationField )
ELSIF IsBaseType(type)
THEN
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
- ForeachFieldEnumerationDo(type, FindMinMaxEnum) ;
+ ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MaxEnumerationField )
ELSIF IsBaseType(type)
THEN
PROCEDURE TypeConstFullyDeclared (sym: CARDINAL) : Tree ;
VAR
t: Tree ;
- n: Name ;
BEGIN
IF IsEnumeration(sym)
THEN
BEGIN
action := q ;
enumDeps := TRUE ;
- ForeachFieldEnumerationDo(sym, IsFieldEnumerationDependants) ;
+ ForeachLocalSymDo (sym, IsFieldEnumerationDependants) ;
RETURN( enumDeps )
END IsEnumerationDependants ;
PROCEDURE WalkEnumerationDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
- ForeachFieldEnumerationDo(sym, p)
+ ForeachLocalSymDo (sym, p)
END WalkEnumerationDependants ;
high, low: CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
- CheckResolveSubrange(sym) ;
+ CheckResolveSubrange (sym) ;
type := GetSType(sym) ;
IF type#NulSym
THEN
IndexChecking, RangeChecking,
ReturnChecking, CaseElseChecking,
AutoInit,
- VariantValueChecking,
+ VariantValueChecking, CaseEnumChecking,
UnusedVariableChecking, UnusedParameterChecking,
UninitVariableChecking, SetUninitVariableChecking,
UninitVariableConditionalChecking,
SetGenModuleList, GetGenModuleFilename, SharedFlag,
SetB, GetB, SetMD, GetMD, SetMMD, GetMMD, SetObj, GetObj,
GetMQ, SetMQ, SetM2Prefix, GetM2Prefix,
- SetM2PathName, GetM2PathName ;
+ SetM2PathName, GetM2PathName, SetCaseEnumChecking ;
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? *)
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.
UninitVariableChecking := value ;
PedanticCast := value ;
PedanticParamNames := value ;
- StyleChecking := value
+ StyleChecking := value ;
+ CaseEnumChecking := value
END SetWall ;
END SetUninitVariableChecking ;
+(*
+ SetCaseEnumChecking - sets the CaseEnumChecking to value.
+*)
+
+PROCEDURE SetCaseEnumChecking (value: BOOLEAN) ;
+BEGIN
+ CaseEnumChecking := value
+END SetCaseEnumChecking ;
+
+
BEGIN
cflag := FALSE ; (* -c. *)
RuntimeModuleOverride := InitString (DefaultRuntimeModuleOverride) ;
DumpDir := NIL ;
UninitVariableChecking := FALSE ;
UninitVariableConditionalChecking := FALSE ;
+ CaseEnumChecking := FALSE ;
M2Prefix := InitString ('') ;
M2PathName := InitString ('')
END M2Options.
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) ;
(*
RETURN( TRUE )
END
+ ELSE
+ RETURN FALSE
END ;
i := GetNextQuad (i)
END ;
<- 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 ;
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 ;
Assert(IsRecord(r) OR IsFieldVarient(r)) ;
v := GetRecordOrField() ;
Assert(IsVarient(v)) ;
- BuildRange(InitCaseBounds(PushCase(r, v)))
+ BuildRange(InitCaseBounds(PushCase(r, v, NulSym)))
END BeginVarient ;
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 ;
ExceptionParameterBounds,
ExceptionNo ;
-FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds, WriteCase, MissingCaseBounds, TypeCaseBounds ;
-
+FROM M2CaseList IMPORT CaseBoundsResolved, OverlappingCaseBounds,
+ WriteCase, MissingCaseBounds, TypeCaseBounds,
+ MissingCaseStatementBounds ;
TYPE
TypeOfRange = (assignment, returnassignment, subrangeassignment,
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 *)
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
(* nothing to do *)
END ;
IF MissingCaseBounds (tokenno, caseList)
+ THEN
+ (* nothing to do *)
+ END ;
+ IF CaseEnumChecking AND MissingCaseStatementBounds (tokenno, caseList)
THEN
(* nothing to do *)
END
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,
% BuildCaseEnd %
| "ELSE" % BuildStmtNote (-1) %
% BuildCaseElse %
+ % ElseCase (NulSym) %
StatementSequence % BuildStmtNote (0) %
"END"
% BuildCaseEnd %
VAR
e: exprNode ;
BEGIN
- NEW(e) ;
+ NEW (e) ;
WITH e^ DO
tag := designator ;
CASE tag OF
left := NIL
END
+ ELSE
+ InternalError ('expecting designator')
END
END ;
PushAddress (exprStack, e)
third := more
END
+ ELSE
+ InternalError ('expecting function')
END
END ;
PushAddress (exprStack, n)
expr := e
END
+ ELSE
+ InternalError ('expecting convert')
END
END ;
PushAddress(exprStack, n)
VAR
l: exprNode ;
BEGIN
- NEW(l) ;
+ NEW (l) ;
WITH l^ DO
tag := leaf ;
CASE tag OF
sym := s
END
+ ELSE
+ InternalError ('expecting leaf')
END
END ;
- PushAddress(exprStack, l)
+ PushAddress (exprStack, l)
END InitLeaf ;
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
right := r ;
op := o
END
+ ELSE
+ InternalError ('expecting binary')
END
END ;
- PushAddress(exprStack, b)
+ PushAddress (exprStack, b)
END InitBinary ;
VAR
op: Name ;
BEGIN
- PopT(op) ;
+ PopT (op) ;
IF inDesignator
THEN
- InitBinary(boolean, Boolean, op)
+ InitBinary (boolean, Boolean, op)
END
END BuildRelationConst ;
VAR
op: Name ;
BEGIN
- PopT(op) ;
+ PopT (op) ;
IF inDesignator
THEN
- InitBinary(unknown, NulSym, op)
+ InitBinary (unknown, NulSym, op)
END
END BuildBinaryConst ;
op := o
END
+ ELSE
+ InternalError ('expecting unary')
END
END ;
PushAddress(exprStack, b)
(*
- 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 ;
(*
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) ;
(* 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 *)
(* 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 *)
(*
- 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 ;
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')
FieldName,
GetDeclaredMod(GetSymKey(LocalSymbols, FieldName)))
ELSE
- PutSymKey(LocalSymbols, FieldName, Field)
+ PutSymKey(LocalSymbols, FieldName, Field) ;
+ IncludeItemIntoList (ListOfFields, Field)
END
END
pSym: PtrToSymbol ;
s : CARDINAL ;
BEGIN
+ s := NulSym ;
IF IsModule (sym) OR IsDefImp (sym)
THEN
RETURN( CollectSymbolFrom (tok, sym, n) )
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 ;
(*
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) ;
WITH pSym^ DO
CASE SymbolType OF
- EnumerationSym: ForeachNodeDo( Enumeration.LocalSymbols, P)
+ EnumerationSym: ForeachNodeDo (Enumeration.LocalSymbols, P)
ELSE
InternalError ('expecting Enumeration symbol')
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. */
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:
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
--- /dev/null
+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.
--- /dev/null
+# 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
+}
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+# 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
+}
projects / thirdparty / gcc.git / commitdiff
