| (* M2CaseList.mod implement ISO case label lists. |
| |
| Copyright (C) 2009-2026 Free Software Foundation, Inc. |
| Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>. |
| |
| This file is part of GNU Modula-2. |
| |
| GNU Modula-2 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, or (at your option) |
| any later version. |
| |
| GNU Modula-2 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 GNU Modula-2; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. *) |
| |
| IMPLEMENTATION MODULE M2CaseList ; |
| |
| |
| FROM M2Debug IMPORT Assert ; |
| FROM M2GCCDeclare IMPORT TryDeclareConstant, GetTypeMin, GetTypeMax ; |
| 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, PushCard ; |
| FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, ForeachIndiceInIndexDo, HighIndice ; |
| FROM Lists IMPORT InitList, IncludeItemIntoList, RemoveItemFromList, NoOfItemsInList, GetItemFromList ; |
| FROM NameKey IMPORT NulName, KeyToCharStar ; |
| FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ; |
| FROM DynamicStrings IMPORT InitString, InitStringCharStar, InitStringChar, ConCat, Mark, KillString ; |
| FROM gcctypes IMPORT tree ; |
| FROM m2block IMPORT RememberType ; |
| FROM m2type IMPORT GetMinFrom ; |
| FROM m2expr IMPORT GetIntegerOne, CSTIntToString, CSTIntToChar ; |
| FROM Storage IMPORT ALLOCATE ; |
| FROM M2Base IMPORT IsExpressionCompatible, Char ; |
| FROM M2LexBuf IMPORT TokenToLocation ; |
| FROM NumberIO IMPORT WriteCard ; |
| |
| FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType, |
| ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth, |
| IsSubrange, MakeConstLit, IsConstString, GetStringLength, MakeConstVar, PutConst, |
| PopValue ; |
| |
| TYPE |
| RangePair = POINTER TO RECORD |
| low, high: CARDINAL ; |
| tokenno : CARDINAL ; |
| END ; |
| |
| ConflictingPair = POINTER TO RECORD |
| a, b: RangePair ; |
| END ; |
| |
| CaseList = POINTER TO RECORD |
| maxRangeId : CARDINAL ; |
| rangeArray : Index ; |
| currentRange: RangePair ; |
| varientField: CARDINAL ; |
| END ; |
| |
| CaseDescriptor = POINTER TO RECORD |
| resolved : BOOLEAN ; |
| elseClause : BOOLEAN ; |
| elseField : CARDINAL ; |
| record : CARDINAL ; |
| varient : CARDINAL ; |
| expression : CARDINAL ; |
| maxCaseId : CARDINAL ; |
| caseListArray: Index ; |
| currentCase : CaseList ; |
| next : CaseDescriptor ; |
| END ; |
| |
| SetRange = POINTER TO RECORD |
| low, high: tree ; |
| next : SetRange ; |
| END ; |
| |
| VAR |
| caseStack : CaseDescriptor ; |
| caseId : CARDINAL ; |
| caseArray : Index ; |
| conflictArray: Index ; |
| FreeRangeList: SetRange ; |
| |
| |
| |
| (* |
| 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 (rec, va, expr: CARDINAL) : CARDINAL ; |
| VAR |
| c: CaseDescriptor ; |
| BEGIN |
| INC (caseId) ; |
| NEW (c) ; |
| IF c = NIL |
| THEN |
| InternalError ('out of memory error') |
| ELSE |
| WITH c^ DO |
| resolved := FALSE ; |
| elseClause := FALSE ; |
| elseField := NulSym ; |
| record := rec ; |
| varient := va ; |
| expression := expr ; |
| maxCaseId := 0 ; |
| caseListArray := InitIndex (1) ; |
| next := caseStack ; |
| currentCase := NIL |
| END ; |
| caseStack := c ; |
| PutIndice (caseArray, caseId, c) |
| END ; |
| RETURN caseId |
| END PushCase ; |
| |
| |
| (* |
| PopCase - pop the top element of the case entity from the internal |
| stack. |
| *) |
| |
| PROCEDURE PopCase ; |
| BEGIN |
| IF caseStack=NIL |
| THEN |
| InternalError ('case stack is empty') |
| END ; |
| caseStack := caseStack^.next |
| END PopCase ; |
| |
| |
| (* |
| ElseCase - indicates that this case varient does have an else clause. |
| *) |
| |
| PROCEDURE ElseCase (f: CARDINAL) ; |
| BEGIN |
| WITH caseStack^ DO |
| elseClause := TRUE ; |
| elseField := f |
| END |
| END ElseCase ; |
| |
| |
| (* |
| BeginCaseList - create a new label list. |
| *) |
| |
| PROCEDURE BeginCaseList (v: CARDINAL) ; |
| VAR |
| l: CaseList ; |
| BEGIN |
| NEW(l) ; |
| IF l=NIL |
| THEN |
| InternalError ('out of memory error') |
| END ; |
| WITH l^ DO |
| maxRangeId := 0 ; |
| rangeArray := InitIndex(1) ; |
| currentRange := NIL ; |
| varientField := v |
| END ; |
| WITH caseStack^ DO |
| INC(maxCaseId) ; |
| PutIndice(caseListArray, maxCaseId, l) ; |
| currentCase := l |
| END |
| END BeginCaseList ; |
| |
| |
| (* |
| EndCaseList - terminate the current label list. |
| *) |
| |
| PROCEDURE EndCaseList ; |
| BEGIN |
| caseStack^.currentCase := NIL |
| END EndCaseList ; |
| |
| |
| (* |
| AddRange - add a range to the current label list. |
| *) |
| |
| PROCEDURE AddRange (r1, r2: CARDINAL; tok: CARDINAL) ; |
| VAR |
| r: RangePair ; |
| BEGIN |
| NEW(r) ; |
| IF r=NIL |
| THEN |
| InternalError ('out of memory error') |
| ELSE |
| WITH r^ DO |
| low := r1 ; |
| high := r2 ; |
| tokenno := tok |
| END ; |
| WITH caseStack^.currentCase^ DO |
| INC(maxRangeId) ; |
| PutIndice(rangeArray, maxRangeId, r) ; |
| currentRange := r |
| END |
| END |
| END AddRange ; |
| |
| |
| (* |
| GetVariantTagType - returns the type associated with, variant. |
| *) |
| |
| PROCEDURE GetVariantTagType (variant: CARDINAL) : CARDINAL ; |
| VAR |
| tag: CARDINAL ; |
| BEGIN |
| tag := GetVarientTag(variant) ; |
| IF IsFieldVarient(tag) OR IsRecordField(tag) |
| THEN |
| RETURN( GetType(tag) ) |
| ELSE |
| RETURN( tag ) |
| END |
| END GetVariantTagType ; |
| |
| |
| (* |
| CaseBoundsResolved - returns TRUE if all constants in the case list, c, |
| are known to GCC. |
| *) |
| |
| PROCEDURE CaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ; |
| VAR |
| p: CaseDescriptor ; |
| BEGIN |
| p := GetIndice (caseArray, c) ; |
| IF p^.resolved |
| THEN |
| RETURN TRUE |
| ELSE |
| IF CheckCaseBoundsResolved (tokenno, c) |
| THEN |
| ConvertNulStr2NulChar (tokenno, c) ; |
| RETURN TRUE |
| ELSE |
| RETURN FALSE |
| END |
| END |
| END CaseBoundsResolved ; |
| |
| |
| (* |
| CheckCaseBoundsResolved - return TRUE if all constants in the case list c are known to GCC. |
| *) |
| |
| PROCEDURE CheckCaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ; |
| VAR |
| p : CaseDescriptor ; |
| q : CaseList ; |
| r : RangePair ; |
| min, |
| max, |
| type, |
| i, j : CARDINAL ; |
| BEGIN |
| p := GetIndice(caseArray, c) ; |
| WITH p^ DO |
| IF varient#NulSym |
| THEN |
| (* not a CASE statement, but a varient record containing without an ELSE clause *) |
| type := GetVariantTagType(varient) ; |
| resolved := TRUE ; |
| IF NOT GccKnowsAbout(type) |
| THEN |
| (* do we need to add, type, to the list of types required to be resolved? *) |
| resolved := FALSE |
| END ; |
| min := GetTypeMin(type) ; |
| IF NOT GccKnowsAbout(min) |
| THEN |
| TryDeclareConstant(tokenno, min) ; |
| resolved := FALSE |
| END ; |
| max := GetTypeMax(type) ; |
| IF NOT GccKnowsAbout(max) |
| THEN |
| TryDeclareConstant(tokenno, max) ; |
| resolved := FALSE |
| END ; |
| IF NOT resolved |
| THEN |
| RETURN( FALSE ) |
| END |
| END ; |
| i := 1 ; |
| WHILE i<=maxCaseId DO |
| q := GetIndice(caseListArray, i) ; |
| j := 1 ; |
| WHILE j<=q^.maxRangeId DO |
| r := GetIndice(q^.rangeArray, j) ; |
| IF r^.low#NulSym |
| THEN |
| IF IsConst(r^.low) |
| THEN |
| TryDeclareConstant(tokenno, r^.low) ; |
| IF NOT GccKnowsAbout(r^.low) |
| THEN |
| RETURN( FALSE ) |
| END |
| ELSE |
| IF r^.high=NulSym |
| THEN |
| MetaError1('the CASE statement variant must be defined by a constant {%1Da:is a {%1dv}}', r^.low) |
| ELSE |
| MetaError1('the CASE statement variant low value in a range must be defined by a constant {%1Da:is a {%1dv}}', |
| r^.low) |
| END |
| END |
| END ; |
| IF r^.high#NulSym |
| THEN |
| IF IsConst(r^.high) |
| THEN |
| TryDeclareConstant(tokenno, r^.high) ; |
| IF NOT GccKnowsAbout(r^.high) |
| THEN |
| RETURN( FALSE ) |
| END |
| ELSE |
| MetaError1('the CASE statement variant high value in a range must be defined by a constant {%1Da:is a {%1dv}}', |
| r^.high) |
| END |
| END ; |
| INC(j) |
| END ; |
| INC(i) |
| END |
| END ; |
| RETURN( TRUE ) |
| END CheckCaseBoundsResolved ; |
| |
| |
| (* |
| ConvertNulStr2NulChar - |
| *) |
| |
| PROCEDURE ConvertNulStr2NulChar (tokenno: CARDINAL; c: CARDINAL) ; |
| VAR |
| p : CaseDescriptor ; |
| q : CaseList ; |
| r : RangePair ; |
| i, j: CARDINAL ; |
| BEGIN |
| p := GetIndice (caseArray, c) ; |
| WITH p^ DO |
| i := 1 ; |
| WHILE i <= maxCaseId DO |
| q := GetIndice (caseListArray, i) ; |
| j := 1 ; |
| WHILE j<=q^.maxRangeId DO |
| r := GetIndice (q^.rangeArray, j) ; |
| r^.low := NulStr2NulChar (tokenno, r^.low) ; |
| r^.high := NulStr2NulChar (tokenno, r^.high) ; |
| INC (j) |
| END ; |
| INC (i) |
| END |
| END |
| END ConvertNulStr2NulChar ; |
| |
| |
| (* |
| NulStr2NulChar - if sym is a const string of length 0 then return |
| a nul char instead otherwise return sym. |
| *) |
| |
| PROCEDURE NulStr2NulChar (tok: CARDINAL; sym: CARDINAL) : CARDINAL ; |
| BEGIN |
| IF sym # NulSym |
| THEN |
| IF IsConst (sym) AND IsConstString (sym) AND GccKnowsAbout (sym) |
| THEN |
| IF GetStringLength (tok, sym) = 0 |
| THEN |
| sym := MakeConstVar (tok, NulName) ; |
| PutConst (sym, Char) ; |
| PushCard (0) ; |
| PopValue (sym) ; |
| TryDeclareConstant (tok, sym) ; |
| Assert (GccKnowsAbout (sym)) |
| END |
| END |
| END ; |
| RETURN sym |
| END NulStr2NulChar ; |
| |
| |
| (* |
| IsSame - return TRUE if r, s, are in, e. |
| *) |
| |
| PROCEDURE IsSame (e: ConflictingPair; r, s: RangePair) : BOOLEAN ; |
| BEGIN |
| WITH e^ DO |
| RETURN( ((a=r) AND (b=s)) OR ((a=s) AND (b=r)) ) |
| END |
| END IsSame ; |
| |
| |
| (* |
| SeenBefore - |
| *) |
| |
| PROCEDURE SeenBefore (r, s: RangePair) : BOOLEAN ; |
| VAR |
| i, h: CARDINAL ; |
| e : ConflictingPair ; |
| BEGIN |
| h := HighIndice(conflictArray) ; |
| i := 1 ; |
| WHILE i<=h DO |
| e := GetIndice(conflictArray, i) ; |
| IF IsSame(e, r, s) |
| THEN |
| RETURN( TRUE ) |
| END ; |
| INC(i) |
| END ; |
| NEW(e) ; |
| WITH e^ DO |
| a := r ; |
| b := s |
| END ; |
| PutIndice(conflictArray, h+1, e) ; |
| RETURN( FALSE ) |
| END SeenBefore ; |
| |
| |
| (* |
| Overlaps - |
| *) |
| |
| PROCEDURE Overlaps (r, s: RangePair) : BOOLEAN ; |
| VAR |
| a, b, c, d: CARDINAL ; |
| BEGIN |
| a := r^.low ; |
| c := s^.low ; |
| IF r^.high=NulSym |
| THEN |
| b := a ; |
| IF s^.high=NulSym |
| THEN |
| d := c ; |
| IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d)) |
| THEN |
| IF NOT SeenBefore(r, s) |
| THEN |
| MetaErrorT2 (r^.tokenno, 'case label {%1ad} is a duplicate with {%2ad}', a, c) ; |
| MetaErrorT2 (s^.tokenno, 'case label {%1ad} is a duplicate with {%2ad}', c, a) |
| END ; |
| RETURN( TRUE ) |
| END |
| ELSE |
| d := s^.high ; |
| IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d)) |
| THEN |
| IF NOT SeenBefore (r, s) |
| THEN |
| MetaErrorT3 (r^.tokenno, 'case label {%1ad} is a duplicate in the range {%2ad}..{%3ad}', a, c, d) ; |
| MetaErrorT3 (s^.tokenno, 'case range {%2ad}..{%3ad} is a duplicate of case label {%1ad}', c, d, a) |
| END ; |
| RETURN( TRUE ) |
| END |
| END |
| ELSE |
| b := r^.high ; |
| IF s^.high=NulSym |
| THEN |
| d := c ; |
| IF OverlapsRange (Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d)) |
| THEN |
| IF NOT SeenBefore(r, s) |
| THEN |
| MetaErrorT3 (r^.tokenno, 'case range {%1ad}..{%2ad} is a duplicate with case label {%3ad}', a, b, c) ; |
| MetaErrorT3 (s^.tokenno, 'case label {%1ad} is a duplicate with case range %{2ad}..{%3ad}', c, a, b) |
| END ; |
| RETURN( TRUE ) |
| END |
| ELSE |
| d := s^.high ; |
| IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d)) |
| THEN |
| IF NOT SeenBefore(r, s) |
| THEN |
| MetaErrorT4 (r^.tokenno, 'case range {%1ad}..{%2ad} overlaps case range {%3ad}..{%4ad}', a, b, c, d) ; |
| MetaErrorT4 (s^.tokenno, 'case range {%1ad}..{%2ad} overlaps case range {%3ad}..{%4ad}', c, d, a, b) |
| END ; |
| RETURN( TRUE ) |
| END |
| END |
| END ; |
| RETURN( FALSE ) |
| END Overlaps ; |
| |
| |
| (* |
| GetCaseExpression - return the type from the expression. |
| *) |
| |
| PROCEDURE GetCaseExpression (p: CaseDescriptor) : CARDINAL ; |
| VAR |
| type: CARDINAL ; |
| BEGIN |
| WITH p^ DO |
| IF expression = NulSym |
| THEN |
| type := NulSym |
| ELSE |
| type := SkipType (GetType (expression)) |
| END |
| END ; |
| RETURN type |
| END GetCaseExpression ; |
| |
| |
| (* |
| OverlappingCaseBound - returns TRUE if, r, overlaps any case bound in the |
| case statement, c. |
| *) |
| |
| PROCEDURE OverlappingCaseBound (r: RangePair; c: CARDINAL) : BOOLEAN ; |
| VAR |
| p : CaseDescriptor ; |
| q : CaseList ; |
| s : RangePair ; |
| i, j : CARDINAL ; |
| overlap: BOOLEAN ; |
| BEGIN |
| p := GetIndice (caseArray, c) ; |
| overlap := FALSE ; |
| WITH p^ DO |
| i := 1 ; |
| WHILE i<=maxCaseId DO |
| q := GetIndice (caseListArray, i) ; |
| j := 1 ; |
| WHILE j<=q^.maxRangeId DO |
| s := GetIndice (q^.rangeArray, j) ; |
| IF (s#r) AND Overlaps (r, s) |
| THEN |
| overlap := TRUE |
| END ; |
| INC (j) |
| END ; |
| INC (i) |
| END |
| END ; |
| RETURN( overlap ) |
| END OverlappingCaseBound ; |
| |
| |
| (* |
| OverlappingCaseBounds - returns TRUE if there were any overlapping bounds |
| in the case list, c. It will generate an error |
| messages for each overlapping bound found. |
| *) |
| |
| PROCEDURE OverlappingCaseBounds (c: CARDINAL) : BOOLEAN ; |
| VAR |
| p : CaseDescriptor ; |
| q : CaseList ; |
| r : RangePair ; |
| i, j : CARDINAL ; |
| overlap: BOOLEAN ; |
| BEGIN |
| p := GetIndice (caseArray, c) ; |
| overlap := FALSE ; |
| WITH p^ DO |
| i := 1 ; |
| WHILE i<=maxCaseId DO |
| q := GetIndice (caseListArray, i) ; |
| j := 1 ; |
| WHILE j<=q^.maxRangeId DO |
| r := GetIndice (q^.rangeArray, j) ; |
| IF OverlappingCaseBound (r, c) |
| THEN |
| overlap := TRUE |
| END ; |
| INC(j) |
| END ; |
| INC(i) |
| END |
| END ; |
| RETURN( overlap ) |
| END OverlappingCaseBounds ; |
| |
| |
| (* |
| NewRanges - return a new range from the freelist or heap. |
| *) |
| |
| PROCEDURE NewRanges () : SetRange ; |
| VAR |
| s: SetRange ; |
| BEGIN |
| IF FreeRangeList=NIL |
| THEN |
| NEW(s) |
| ELSE |
| s := FreeRangeList ; |
| FreeRangeList := FreeRangeList^.next |
| END ; |
| s^.next := NIL ; |
| RETURN( s ) |
| END NewRanges ; |
| |
| |
| (* |
| NewSet - returns a new set based on type with the low and high fields assigned |
| to the min and max values for the type. |
| *) |
| |
| PROCEDURE NewSet (type: CARDINAL) : SetRange ; |
| VAR |
| s: SetRange ; |
| BEGIN |
| s := NewRanges() ; |
| WITH s^ DO |
| low := Mod2Gcc(GetTypeMin(type)) ; |
| high := Mod2Gcc(GetTypeMax(type)) ; |
| next := NIL |
| END ; |
| RETURN( s ) |
| END NewSet ; |
| |
| |
| (* |
| DisposeRanges - place set and its list onto the free list. |
| *) |
| |
| PROCEDURE DisposeRanges (set: SetRange) : SetRange ; |
| VAR |
| t: SetRange ; |
| BEGIN |
| IF set#NIL |
| THEN |
| IF FreeRangeList=NIL |
| THEN |
| FreeRangeList := set |
| ELSE |
| t := set ; |
| WHILE t^.next#NIL DO |
| t := t^.next |
| END ; |
| t^.next := FreeRangeList ; |
| FreeRangeList := set |
| END |
| END ; |
| RETURN( NIL ) |
| 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 ; |
| 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 |
| 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) |
| THEN |
| MetaErrorT0 (tokenno, 'variant case range lies outside tag value') |
| ELSE |
| IF IsEqual(h^.low, lo) |
| THEN |
| PushIntegerTree(hi) ; |
| PushInt(1) ; |
| Addn ; |
| h^.low := PopIntegerTree() |
| ELSIF IsEqual(h^.high, hi) |
| THEN |
| PushIntegerTree(lo) ; |
| PushInt(1) ; |
| Sub ; |
| h^.high := PopIntegerTree() |
| ELSE |
| (* lo..hi exist inside range h^.low..h^.high *) |
| i := NewRanges() ; |
| i^.next := h^.next ; |
| h^.next := i ; |
| i^.high := h^.high ; |
| PushIntegerTree(lo) ; |
| PushInt(1) ; |
| Sub ; |
| h^.high := PopIntegerTree() ; |
| PushIntegerTree(hi) ; |
| PushInt(1) ; |
| Addn ; |
| i^.low := PopIntegerTree() |
| END |
| END |
| ELSE |
| h := h^.next |
| END |
| END |
| END ; |
| RETURN( set ) |
| 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; cd: CaseDescriptor) : SetRange ; |
| VAR |
| i, j: CARDINAL ; |
| cl : CaseList ; |
| rp : RangePair ; |
| BEGIN |
| WITH cd^ DO |
| i := 1 ; |
| WHILE i <= maxCaseId DO |
| cl := GetIndice (caseListArray, i) ; |
| j := 1 ; |
| WHILE j <= cl^.maxRangeId DO |
| rp := GetIndice (cl^.rangeArray, j) ; |
| IF rp^.high = NulSym |
| THEN |
| set := SubBitRange (set, |
| Mod2Gcc (rp^.low), |
| Mod2Gcc (rp^.low), rp^.tokenno) |
| ELSE |
| CheckLowHigh (rp) ; |
| set := SubBitRange (set, |
| Mod2Gcc (rp^.low), |
| Mod2Gcc (rp^.high), rp^.tokenno) |
| END ; |
| INC (j) |
| END ; |
| INC (i) |
| END |
| END ; |
| RETURN set |
| END ExcludeCaseRanges ; |
| |
| |
| VAR |
| errorString: String ; |
| |
| |
| (* |
| IncludeElement - only include enumeration field into errorString if it lies between low..high. |
| *) |
| |
| PROCEDURE IncludeElement (enumList: List; field: CARDINAL; low, high: tree) ; |
| VAR |
| fieldTree: tree ; |
| BEGIN |
| IF field # NulSym |
| THEN |
| fieldTree := Mod2Gcc (field) ; |
| IF OverlapsRange (fieldTree, fieldTree, low, high) |
| THEN |
| IncludeItemIntoList (enumList, field) |
| END |
| END |
| END IncludeElement ; |
| |
| |
| (* |
| IncludeElements - only include enumeration field values low..high in errorString. |
| *) |
| |
| 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 - include enumeration fields Low to High in errorString. |
| *) |
| |
| 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 (Low # NIL) AND (High # NIL) |
| THEN |
| IncludeElements (type, enumList, Low, High) |
| END |
| END ErrorRangeEnum ; |
| |
| |
| (* |
| 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 ErrorRanges (type: CARDINAL; set: SetRange) : List ; |
| VAR |
| enumSet: List ; |
| BEGIN |
| type := SkipType (type) ; |
| IF IsEnumeration (type) |
| THEN |
| InitList (enumSet) ; |
| WHILE set#NIL DO |
| ErrorRangeEnum (type, set, enumSet) ; |
| set := set^.next |
| END ; |
| RETURN enumSet |
| END ; |
| RETURN NIL |
| END ErrorRanges ; |
| |
| |
| (* |
| appendString - appends str to errorString. |
| *) |
| |
| PROCEDURE appendString (str: String) ; |
| BEGIN |
| errorString := ConCat (errorString, str) |
| END appendString ; |
| |
| |
| (* |
| appendEnum - appends enum to errorString. |
| *) |
| |
| PROCEDURE appendEnum (enum: CARDINAL) ; |
| BEGIN |
| appendString (Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum))))) |
| END appendEnum ; |
| |
| |
| (* |
| appendStr - appends str to errorString. |
| *) |
| |
| PROCEDURE appendStr (str: ARRAY OF CHAR) ; |
| BEGIN |
| appendString (Mark (InitString (str))) |
| END appendStr ; |
| |
| |
| (* |
| EnumerateErrors - populate errorString with the contents of enumList. |
| *) |
| |
| PROCEDURE EnumerateErrors (enumList: List) ; |
| VAR |
| i, n: CARDINAL ; |
| BEGIN |
| n := NoOfItemsInList (enumList) ; |
| IF (enumList # NIL) AND (n > 0) |
| THEN |
| IF n = 1 |
| THEN |
| errorString := InitString ('{%W}the missing enumeration field is: ') ; |
| ELSE |
| errorString := InitString ('{%W}the missing enumeration fields are: ') ; |
| END ; |
| 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 EnumerateErrors ; |
| |
| |
| (* |
| NoOfSetElements - return the number of set elements. |
| *) |
| |
| PROCEDURE NoOfSetElements (set: SetRange) : tree ; |
| BEGIN |
| PushInt (0) ; |
| WHILE set # NIL DO |
| IF ((set^.low # NIL) AND (set^.high = NIL)) OR |
| ((set^.low = NIL) AND (set^.high # NIL)) |
| THEN |
| PushInt (1) ; |
| Addn |
| ELSIF (set^.low # NIL) AND (set^.high # NIL) |
| THEN |
| PushIntegerTree (set^.high) ; |
| PushIntegerTree (set^.low) ; |
| Sub ; |
| PushInt (1) ; |
| Addn ; |
| Addn |
| END ; |
| set := set^.next |
| END ; |
| RETURN PopIntegerTree () |
| END NoOfSetElements ; |
| |
| |
| (* |
| isPrintableChar - a cautious isprint. |
| *) |
| |
| PROCEDURE isPrintableChar (value: tree) : BOOLEAN ; |
| BEGIN |
| CASE CSTIntToChar (value) OF |
| |
| 'a'..'z': RETURN TRUE | |
| 'A'..'Z': RETURN TRUE | |
| '0'..'9': RETURN TRUE | |
| '!', '@': RETURN TRUE | |
| '#', '$': RETURN TRUE | |
| '%', '^': RETURN TRUE | |
| '&', '*': RETURN TRUE | |
| '(', ')': RETURN TRUE | |
| '[', ']': RETURN TRUE | |
| '{', '}': RETURN TRUE | |
| '-', '+': RETURN TRUE | |
| '_', '=': RETURN TRUE | |
| ':', ';': RETURN TRUE | |
| "'", '"': RETURN TRUE | |
| ',', '.': RETURN TRUE | |
| '<', '>': RETURN TRUE | |
| '/', '?': RETURN TRUE | |
| '\', '|': RETURN TRUE | |
| '~', '`': RETURN TRUE | |
| ' ' : RETURN TRUE |
| |
| ELSE |
| RETURN FALSE |
| END |
| END isPrintableChar ; |
| |
| |
| (* |
| appendTree - append tree value to the errorString. It attempts to pretty print |
| CHAR constants and will fall back to CHR (x) if necessary. |
| *) |
| |
| PROCEDURE appendTree (value: tree; type: CARDINAL) ; |
| BEGIN |
| IF SkipType (GetType (type)) = Char |
| THEN |
| IF isPrintableChar (value) |
| THEN |
| IF CSTIntToChar (value) = "'" |
| THEN |
| appendString (InitStringChar ('"')) ; |
| appendString (InitStringChar (CSTIntToChar (value))) ; |
| appendString (InitStringChar ('"')) |
| ELSE |
| appendString (InitStringChar ("'")) ; |
| appendString (InitStringChar (CSTIntToChar (value))) ; |
| appendString (InitStringChar ("'")) |
| END |
| ELSE |
| appendString (InitString ('CHR (')) ; |
| appendString (InitStringCharStar (CSTIntToString (value))) ; |
| appendString (InitStringChar (')')) |
| END |
| ELSE |
| appendString (InitStringCharStar (CSTIntToString (value))) |
| END |
| END appendTree ; |
| |
| |
| (* |
| SubrangeErrors - create an errorString containing all set ranges. |
| *) |
| |
| PROCEDURE SubrangeErrors (subrangetype: CARDINAL; set: SetRange) ; |
| VAR |
| sr : SetRange ; |
| rangeNo : CARDINAL ; |
| nMissing, |
| zero, one: tree ; |
| BEGIN |
| nMissing := NoOfSetElements (set) ; |
| PushInt (0) ; |
| zero := PopIntegerTree () ; |
| IF IsGreater (nMissing, zero) |
| THEN |
| PushInt (1) ; |
| one := PopIntegerTree () ; |
| IF IsGreater (nMissing, one) |
| THEN |
| errorString := InitString ('{%W}there are a total of ') |
| ELSE |
| errorString := InitString ('{%W}there is a total of ') |
| END ; |
| appendString (InitStringCharStar (CSTIntToString (nMissing))) ; |
| appendStr (' missing values in the subrange, the {%kCASE} statement needs labels (or an {%kELSE} statement)') ; |
| appendStr (' for the following values: ') ; |
| sr := set ; |
| rangeNo := 0 ; |
| WHILE sr # NIL DO |
| INC (rangeNo) ; |
| IF rangeNo > 1 |
| THEN |
| IF sr^.next = NIL |
| THEN |
| appendStr (' and ') |
| ELSE |
| appendStr (', ') |
| END |
| END ; |
| IF sr^.low = NIL |
| THEN |
| appendTree (sr^.high, subrangetype) |
| ELSIF (sr^.high = NIL) OR IsEqual (sr^.low, sr^.high) |
| THEN |
| appendTree (sr^.low, subrangetype) |
| ELSE |
| appendTree (sr^.low, subrangetype) ; |
| appendStr ('..') ; |
| appendTree (sr^.high, subrangetype) |
| END ; |
| sr := sr^.next |
| END |
| END |
| END SubrangeErrors ; |
| |
| |
| (* |
| EmitMissingRangeErrors - emits a singular/plural error message for an enumeration type. |
| *) |
| |
| PROCEDURE EmitMissingRangeErrors (tokenno: CARDINAL; type: CARDINAL; set: SetRange) ; |
| BEGIN |
| errorString := NIL ; |
| IF IsEnumeration (type) |
| THEN |
| EnumerateErrors (ErrorRanges (type, set)) |
| ELSIF IsSubrange (type) |
| THEN |
| SubrangeErrors (type, set) |
| END ; |
| IF errorString # NIL |
| THEN |
| MetaErrorStringT0 (tokenno, errorString) |
| END |
| END EmitMissingRangeErrors ; |
| |
| |
| (* |
| 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. |
| *) |
| |
| PROCEDURE MissingCaseBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ; |
| VAR |
| p : CaseDescriptor ; |
| type : CARDINAL ; |
| missing: BOOLEAN ; |
| set : SetRange ; |
| BEGIN |
| p := GetIndice (caseArray, c) ; |
| missing := FALSE ; |
| WITH p^ DO |
| IF NOT elseClause |
| THEN |
| IF (record # NulSym) AND (varient # NulSym) |
| THEN |
| (* 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) ; |
| EmitMissingRangeErrors (tokenno, type, set) |
| END ; |
| set := DisposeRanges (set) |
| END |
| END |
| END ; |
| RETURN missing |
| END MissingCaseBounds ; |
| |
| |
| (* |
| MissingCaseStatementBounds - returns true if the case statement has a missing |
| clause. It will also generate error messages. |
| *) |
| |
| PROCEDURE MissingCaseStatementBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ; |
| VAR |
| p : CaseDescriptor ; |
| type : CARDINAL ; |
| missing: BOOLEAN ; |
| set : SetRange ; |
| BEGIN |
| p := GetIndice (caseArray, c) ; |
| missing := FALSE ; |
| WITH p^ DO |
| IF NOT elseClause |
| THEN |
| type := GetCaseExpression (p) ; |
| IF type # NulSym |
| THEN |
| IF IsEnumeration (type) OR IsSubrange (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 {%1Wd} values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1ad} or use an {%kELSE} clause', |
| type) ; |
| EmitMissingRangeErrors (tokenno, type, set) |
| END ; |
| set := DisposeRanges (set) |
| END |
| END |
| END |
| END ; |
| 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 |
| i := 1 ; |
| h := HighIndice(rangeArray) ; |
| while i<=h do |
| r := GetIndice(rangeArray, i) ; |
| with r^ do |
| if high=NulSym |
| then |
| a := Mod2Gcc(low) |
| 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 ; |
| *) |
| |
| |
| (* |
| WriteCase - dump out the case list (internal debugging). |
| *) |
| |
| PROCEDURE WriteCase (c: CARDINAL) ; |
| BEGIN |
| (* this debugging PROCEDURE should be finished. *) |
| WriteCard (c, 0) |
| END WriteCase ; |
| |
| |
| (* |
| checkTypes - checks to see that, constant, and, type, are compatible. |
| *) |
| |
| PROCEDURE checkTypes (constant, type: CARDINAL) : BOOLEAN ; |
| VAR |
| consttype: CARDINAL ; |
| BEGIN |
| IF (constant # NulSym) AND IsConst (constant) |
| THEN |
| 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 {%2dv}}', |
| type, constant) ; |
| RETURN FALSE |
| END |
| END ; |
| RETURN TRUE |
| END checkTypes ; |
| |
| |
| (* |
| 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)) |
| END inRange ; |
| |
| |
| (* |
| TypeCaseBounds - returns true if all bounds in case list, c, are |
| compatible with the tagged type. |
| *) |
| |
| PROCEDURE TypeCaseBounds (c: CARDINAL) : BOOLEAN ; |
| VAR |
| p : CaseDescriptor ; |
| q : CaseList ; |
| r : RangePair ; |
| min, max, |
| type, |
| i, j : CARDINAL ; |
| compatible: BOOLEAN ; |
| BEGIN |
| p := GetIndice(caseArray, c) ; |
| type := NulSym ; |
| WITH p^ DO |
| type := NulSym ; |
| IF varient#NulSym |
| THEN |
| (* not a CASE statement, but a varient record containing without an ELSE clause *) |
| type := GetVariantTagType(varient) ; |
| min := GetTypeMin(type) ; |
| max := GetTypeMax(type) |
| END ; |
| IF type=NulSym |
| THEN |
| RETURN( TRUE ) |
| END ; |
| compatible := TRUE ; |
| i := 1 ; |
| WHILE i<=maxCaseId DO |
| q := GetIndice(caseListArray, i) ; |
| j := 1 ; |
| WHILE j<=q^.maxRangeId DO |
| r := GetIndice(q^.rangeArray, j) ; |
| IF (r^.low#NulSym) AND (NOT inRange(r^.low, min, max)) |
| THEN |
| MetaError2('the CASE statement variant range {%1ad} exceeds that of the tag type {%2ad}', |
| r^.low, type) ; |
| compatible := FALSE |
| END ; |
| IF NOT checkTypes(r^.low, type) |
| THEN |
| compatible := FALSE |
| END ; |
| IF (r^.high#NulSym) AND (NOT inRange(r^.high, min, max)) |
| THEN |
| MetaError2('the CASE statement variant range {%1ad} exceeds that of the tag type {%2ad}', |
| r^.high, type) ; |
| compatible := FALSE |
| END ; |
| IF NOT checkTypes(r^.high, type) |
| THEN |
| compatible := FALSE |
| END ; |
| INC (j) |
| END ; |
| INC (i) |
| END ; |
| RETURN compatible |
| END |
| END TypeCaseBounds ; |
| |
| |
| BEGIN |
| caseStack := NIL ; |
| caseId := 0 ; |
| caseArray := InitIndex(1) ; |
| conflictArray := InitIndex(1) ; |
| FreeRangeList := NIL |
| END M2CaseList. |
