1 (* M2CaseList.mod implement ISO case label lists.
3 Copyright (C) 2009-2023 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
6 This file is part of GNU Modula-2.
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Modula-2; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. *)
22 IMPLEMENTATION MODULE M2CaseList ;
25 FROM M2Debug IMPORT Assert ;
26 FROM M2GCCDeclare IMPORT TryDeclareConstant, GetTypeMin, GetTypeMax ;
27 FROM M2MetaError IMPORT MetaError1, MetaError2, MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3, MetaErrorT4, MetaErrorString1 ;
28 FROM M2Error IMPORT InternalError ;
29 FROM M2Range IMPORT OverlapsRange, IsEqual, IsGreater ;
30 FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt ;
31 FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, ForeachIndiceInIndexDo, HighIndice ;
32 FROM Lists IMPORT InitList, IncludeItemIntoList ;
33 FROM NameKey IMPORT KeyToCharStar ;
34 FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ;
35 FROM DynamicStrings IMPORT InitString, InitStringCharStar, ConCat, Mark, KillString ;
36 FROM m2tree IMPORT Tree ;
37 FROM m2block IMPORT RememberType ;
38 FROM m2type IMPORT GetMinFrom ;
39 FROM Storage IMPORT ALLOCATE ;
40 FROM M2Base IMPORT IsExpressionCompatible ;
41 FROM M2Printf IMPORT printf1 ;
43 FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType,
44 ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType ;
47 RangePair = POINTER TO RECORD
52 ConflictingPair = POINTER TO RECORD
56 CaseList = POINTER TO RECORD
57 maxRangeId : CARDINAL ;
59 currentRange: RangePair ;
60 varientField: CARDINAL ;
63 CaseDescriptor = POINTER TO RECORD
64 elseClause : BOOLEAN ;
65 elseField : CARDINAL ;
68 maxCaseId : CARDINAL ;
69 caseListArray: Index ;
70 currentCase : CaseList ;
71 next : CaseDescriptor ;
74 SetRange = POINTER TO RECORD
80 caseStack : CaseDescriptor ;
83 conflictArray: Index ;
84 FreeRangeList: SetRange ;
89 PushCase - create a case entity and push it to an internal stack.
90 r, is NulSym if this is a CASE statement.
91 If, r, is a record then it indicates it includes one
92 or more varients reside in the record. The particular
97 PROCEDURE PushCase (r: CARDINAL; v: CARDINAL) : CARDINAL ;
105 InternalError ('out of memory error')
108 elseClause := FALSE ;
109 elseField := NulSym ;
113 caseListArray := InitIndex(1) ;
118 PutIndice(caseArray, caseId, c)
125 PopCase - pop the top element of the case entity from the internal
133 InternalError ('case stack is empty')
135 caseStack := caseStack^.next
140 ElseCase - indicates that this case varient does have an else clause.
143 PROCEDURE ElseCase (f: CARDINAL) ;
153 BeginCaseList - create a new label list.
156 PROCEDURE BeginCaseList (v: CARDINAL) ;
163 InternalError ('out of memory error')
167 rangeArray := InitIndex(1) ;
168 currentRange := NIL ;
173 PutIndice(caseListArray, maxCaseId, l) ;
180 EndCaseList - terminate the current label list.
183 PROCEDURE EndCaseList ;
185 caseStack^.currentCase := NIL
190 AddRange - add a range to the current label list.
193 PROCEDURE AddRange (r1, r2: CARDINAL; tok: CARDINAL) ;
200 InternalError ('out of memory error')
207 WITH caseStack^.currentCase^ DO
209 PutIndice(rangeArray, maxRangeId, r) ;
217 GetVariantTagType - returns the type associated with, variant.
220 PROCEDURE GetVariantTagType (variant: CARDINAL) : CARDINAL ;
224 tag := GetVarientTag(variant) ;
225 IF IsFieldVarient(tag) OR IsRecordField(tag)
227 RETURN( GetType(tag) )
231 END GetVariantTagType ;
235 CaseBoundsResolved - returns TRUE if all constants in the case list, c,
239 PROCEDURE CaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
250 p := GetIndice(caseArray, c) ;
254 (* not a CASE statement, but a varient record containing without an ELSE clause *)
255 type := GetVariantTagType(varient) ;
257 IF NOT GccKnowsAbout(type)
259 (* do we need to add, type, to the list of types required to be resolved? *)
262 min := GetTypeMin(type) ;
263 IF NOT GccKnowsAbout(min)
265 TryDeclareConstant(tokenno, min) ;
268 max := GetTypeMax(type) ;
269 IF NOT GccKnowsAbout(max)
271 TryDeclareConstant(tokenno, max) ;
280 WHILE i<=maxCaseId DO
281 q := GetIndice(caseListArray, i) ;
283 WHILE j<=q^.maxRangeId DO
284 r := GetIndice(q^.rangeArray, j) ;
289 TryDeclareConstant(tokenno, r^.low) ;
290 IF NOT GccKnowsAbout(r^.low)
297 MetaError1('the CASE statement variant must be defined by a constant {%1Da:is a {%1d}}', r^.low)
299 MetaError1('the CASE statement variant low value in a range must be defined by a constant {%1Da:is a {%1d}}',
308 TryDeclareConstant(tokenno, r^.high) ;
309 IF NOT GccKnowsAbout(r^.high)
314 MetaError1('the CASE statement variant high value in a range must be defined by a constant {%1Da:is a {%1d}}',
324 END CaseBoundsResolved ;
328 IsSame - return TRUE if r, s, are in, e.
331 PROCEDURE IsSame (e: ConflictingPair; r, s: RangePair) : BOOLEAN ;
334 RETURN( ((a=r) AND (b=s)) OR ((a=s) AND (b=r)) )
343 PROCEDURE SeenBefore (r, s: RangePair) : BOOLEAN ;
346 e : ConflictingPair ;
348 h := HighIndice(conflictArray) ;
351 e := GetIndice(conflictArray, i) ;
363 PutIndice(conflictArray, h+1, e) ;
372 PROCEDURE Overlaps (r, s: RangePair) : BOOLEAN ;
374 a, b, c, d: CARDINAL ;
384 IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
386 IF NOT SeenBefore(r, s)
388 MetaErrorT2 (r^.tokenno, 'case label {%1ad} is a duplicate with {%2ad}', a, c) ;
389 MetaErrorT2 (s^.tokenno, 'case label {%1ad} is a duplicate with {%2ad}', c, a)
395 IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
397 IF NOT SeenBefore (r, s)
399 MetaErrorT3 (r^.tokenno, 'case label {%1ad} is a duplicate in the range {%2ad}..{%3ad}', a, c, d) ;
400 MetaErrorT3 (s^.tokenno, 'case range {%2ad}..{%3ad} is a duplicate of case label {%1ad}', c, d, a)
410 IF OverlapsRange (Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
412 IF NOT SeenBefore(r, s)
414 MetaErrorT3 (r^.tokenno, 'case range {%1ad}..{%2ad} is a duplicate with case label {%3ad}', a, b, c) ;
415 MetaErrorT3 (s^.tokenno, 'case label {%1ad} is a duplicate with case range %{2ad}..{%3ad}', c, a, b)
421 IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
423 IF NOT SeenBefore(r, s)
425 MetaErrorT4 (r^.tokenno, 'case range {%1ad}..{%2ad} overlaps case range {%3ad}..{%4ad}', a, b, c, d) ;
426 MetaErrorT4 (s^.tokenno, 'case range {%1ad}..{%2ad} overlaps case range {%3ad}..{%4ad}', c, d, a, b)
437 OverlappingCaseBound - returns TRUE if, r, overlaps any case bound in the
441 PROCEDURE OverlappingCaseBound (r: RangePair; c: CARDINAL) : BOOLEAN ;
449 p := GetIndice (caseArray, c) ;
453 WHILE i<=maxCaseId DO
454 q := GetIndice (caseListArray, i) ;
456 WHILE j<=q^.maxRangeId DO
457 s := GetIndice (q^.rangeArray, j) ;
458 IF (s#r) AND Overlaps (r, s)
468 END OverlappingCaseBound ;
472 OverlappingCaseBounds - returns TRUE if there were any overlapping bounds
473 in the case list, c. It will generate an error
474 messages for each overlapping bound found.
477 PROCEDURE OverlappingCaseBounds (c: CARDINAL) : BOOLEAN ;
485 p := GetIndice(caseArray, c) ;
489 WHILE i<=maxCaseId DO
490 q := GetIndice(caseListArray, i) ;
492 WHILE j<=q^.maxRangeId DO
493 r := GetIndice(q^.rangeArray, j) ;
494 IF OverlappingCaseBound (r, c)
504 END OverlappingCaseBounds ;
511 PROCEDURE NewRanges () : SetRange ;
520 FreeRangeList := FreeRangeList^.next
531 PROCEDURE NewSet (type: CARDINAL) : SetRange ;
537 low := Mod2Gcc(GetTypeMin(type)) ;
538 high := Mod2Gcc(GetTypeMax(type)) ;
549 PROCEDURE DisposeRanges (set: SetRange) : SetRange ;
563 t^.next := FreeRangeList ;
572 SubBitRange - subtracts bits, lo..hi, from, set.
575 PROCEDURE SubBitRange (set: SetRange; lo, hi: Tree; tokenno: CARDINAL) : SetRange ;
581 IF (h^.high=NIL) OR IsEqual(h^.high, h^.low)
583 IF IsEqual(h^.low, lo) OR OverlapsRange(lo, hi, h^.low, h^.low)
589 h := DisposeRanges(h) ;
600 i := DisposeRanges(i)
606 IF OverlapsRange(lo, hi, h^.low, h^.high)
608 IF IsGreater(h^.low, lo) OR IsGreater(hi, h^.high)
610 MetaErrorT0 (tokenno, 'variant case range lies outside tag value')
612 IF IsEqual(h^.low, lo)
614 PushIntegerTree(hi) ;
617 h^.low := PopIntegerTree()
618 ELSIF IsEqual(h^.high, hi)
620 PushIntegerTree(lo) ;
623 h^.high := PopIntegerTree()
625 (* lo..hi exist inside range h^.low..h^.high *)
630 PushIntegerTree(lo) ;
633 h^.high := PopIntegerTree() ;
634 PushIntegerTree(hi) ;
637 i^.low := PopIntegerTree()
650 ExcludeCaseRanges - excludes all case ranges found in, p, from, set
653 PROCEDURE ExcludeCaseRanges (set: SetRange; p: CaseDescriptor) : SetRange ;
661 WHILE i<=maxCaseId DO
662 q := GetIndice(caseListArray, i) ;
664 WHILE j<=q^.maxRangeId DO
665 r := GetIndice(q^.rangeArray, j) ;
668 set := SubBitRange(set, Mod2Gcc(r^.low), Mod2Gcc(r^.low), r^.tokenno)
670 set := SubBitRange(set, Mod2Gcc(r^.low), Mod2Gcc(r^.high), r^.tokenno)
678 END ExcludeCaseRanges ;
683 errorString: String ;
690 PROCEDURE DoEnumValues (sym: CARDINAL) ;
692 IF (Low#NIL) AND IsEqual(Mod2Gcc(sym), Low)
694 errorString := ConCat(errorString, InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ;
697 IF (High#NIL) AND IsEqual(Mod2Gcc(sym), High)
699 errorString := ConCat(errorString, Mark(InitString('..'))) ;
700 errorString := ConCat(errorString, Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym))))) ;
710 PROCEDURE ErrorRange (p: CaseDescriptor; type: CARDINAL; set: SetRange) ;
712 type := SkipType(type) ;
713 IF IsEnumeration(type)
717 IF IsEqual(Low, High)
720 errorString := InitString('enumeration value ') ;
721 ForeachLocalSymDo(type, DoEnumValues) ;
722 errorString := ConCat(errorString, InitString(' is ignored by the CASE variant record {%1D}'))
724 errorString := InitString('enumeration values ') ;
725 ForeachLocalSymDo(type, DoEnumValues) ;
726 errorString := ConCat(errorString, InitString(' are ignored by the CASE variant record {%1D}'))
728 MetaErrorString1(errorString, p^.varient)
737 PROCEDURE ErrorRanges (p: CaseDescriptor; type: CARDINAL; set: SetRange) ;
740 ErrorRange(p, type, set) ;
747 MissingCaseBounds - returns TRUE if there were any missing bounds
748 in the varient record case list, c. It will
749 generate an error message for each missing
753 PROCEDURE MissingCaseBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
760 p := GetIndice(caseArray, c) ;
763 IF (record#NulSym) AND (varient#NulSym) AND (NOT elseClause)
765 (* not a CASE statement, but a varient record containing without an ELSE clause *)
766 type := GetVariantTagType(varient) ;
767 set := NewSet(type) ;
768 set := ExcludeCaseRanges(set, p) ;
772 MetaErrorT2 (tokenno,
773 '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',
775 ErrorRanges(p, type, set)
777 set := DisposeRanges(set)
781 END MissingCaseBounds ;
785 InRangeList - returns TRUE if the value, tag, is defined in the case list.
787 PROCEDURE InRangeList (cl: CaseList; tag: CARDINAL) : BOOLEAN ;
795 h := HighIndice(rangeArray) ;
797 r := GetIndice(rangeArray, i) ;
805 IF OverlapsRange(Mod2Gcc(low), a, Mod2Gcc(tag), Mod2Gcc(tag))
819 WriteCase - dump out the case list (internal debugging).
822 PROCEDURE WriteCase (c: CARDINAL) ;
824 (* this debugging procedure should be finished. *)
830 checkTypes - checks to see that, constant, and, type, are compatible.
833 PROCEDURE checkTypes (constant, type: CARDINAL) : BOOLEAN ;
835 consttype: CARDINAL ;
837 IF (constant#NulSym) AND IsConst(constant)
839 consttype := GetType(constant) ;
840 IF NOT IsExpressionCompatible(consttype, type)
842 MetaError2('the CASE statement variant tag {%1ad} must be type compatible with the constant {%2Da:is a {%2d}}',
852 inRange - returns TRUE if, min <= i <= max.
855 PROCEDURE inRange (i, min, max: CARDINAL) : BOOLEAN ;
857 RETURN( OverlapsRange(Mod2Gcc(i), Mod2Gcc(i), Mod2Gcc(min), Mod2Gcc(max)) )
862 TypeCaseBounds - returns TRUE if all bounds in case list, c, are
863 compatible with the tagged type.
866 PROCEDURE TypeCaseBounds (c: CARDINAL) : BOOLEAN ;
874 compatible: BOOLEAN ;
876 p := GetIndice(caseArray, c) ;
882 (* not a CASE statement, but a varient record containing without an ELSE clause *)
883 type := GetVariantTagType(varient) ;
884 min := GetTypeMin(type) ;
885 max := GetTypeMax(type)
893 WHILE i<=maxCaseId DO
894 q := GetIndice(caseListArray, i) ;
896 WHILE j<=q^.maxRangeId DO
897 r := GetIndice(q^.rangeArray, j) ;
898 IF (r^.low#NulSym) AND (NOT inRange(r^.low, min, max))
900 MetaError2('the CASE statement variant range {%1ad} exceeds that of the tag type {%2ad}',
904 IF NOT checkTypes(r^.low, type)
908 IF (r^.high#NulSym) AND (NOT inRange(r^.high, min, max))
910 MetaError2('the CASE statement variant range {%1ad} exceeds that of the tag type {%2ad}',
914 IF NOT checkTypes(r^.high, type)
930 caseArray := InitIndex(1) ;
931 conflictArray := InitIndex(1) ;