From e3632a18d1e0b94b4c7b99a512b19c830ed3b228 Mon Sep 17 00:00:00 2001 From: Gaius Mulley Date: Tue, 9 Jan 2024 13:36:44 +0000 Subject: [PATCH] PR modula2/112920 cc1gm2 hangs in the type resolver This patch contains a fix to gcc/m2/gm2-compiler/M2GCCDeclare.mod. The fix introduces a group of sets which can be compared. The resolver will loop until there is no change in all sets within the group. Since symbols migrate from set to set without ever looping this will never hang. Previously only the number of elements in a set were compared which resulted in a infinite spin. gcc/m2/ChangeLog: PR modula2/112920 * gm2-compiler/M2GCCDeclare.mod (Group): New declaration. Import MakeSubrange, MakeConstVar, MakeConstLit and DivTrunc. (FreeGroup): New declaration. (GlobalGroup): New declaration. (ToBeSolvedByQuads): Remove. (NilTypedArrays): Remove. (PartiallyDeclared): Remove. (HeldByAlignment): Remove. (FinishedAlignment): Remove. (ToDoList): Remove. (DebugSet): Re-format. (DebugNumber): Re-format. (DebugSetNumbers): Reference sets using GlobalGroup. (AddSymToWatch): Re-format. (WatchIncludeList): Reference sets using GlobalGroup. (WatchRemoveList): Reference sets using GlobalGroup. (NewGroup): New procedure. (DisposeGroup): New procedure. (InitGroup): New procedure. (KillGroup): New procedure. (DupGroup): New procedure. (EqualGroup): New procedure. (LookupSet): New procedure. (CanDeclareTypePartially): Reference sets using GlobalGroup. (CompletelyResolved): Reference sets using GlobalGroup. (IsNilTypedArrays): Reference sets using GlobalGroup. (IsFullyDeclared): Reference sets using GlobalGroup. (IsPartiallyDeclared): Reference sets using GlobalGroup. (IsPartiallyOrFullyDeclared): Reference sets using GlobalGroup. (DeclareTypeConstFully): Reference sets using GlobalGroup. (bodyl): Remove. (Body): Use bodyt and to lookup the required set. (ForeachTryDeclare): Remove parameter l. Lookup set instead. (DeclareOutstandingTypes): Add new rules setarraynul and setfully. Reference sets using GlobalGroup. (ActivateWatch): New procedure. (DeclareTypesConstantsProceduresInRange): Re-written to check group change. (DeclareTypesConstantsProcedures): Re-written to check group change. (DeclareBoolean): Reference sets using GlobalGroup. (DeclarePackedBoolean): Ditto. (DeclareDefaultConstants): Ditto. (FreeGroup): Initialized. (GlobalGroup): Ditto. * gm2-compiler/Sets.def (EqualSet): New procedure function. Remove export qualified list of identifiers. * gm2-compiler/Sets.mod (EqualSet): New procedure function. Signed-off-by: Gaius Mulley --- gcc/m2/gm2-compiler/M2GCCDeclare.mod | 639 ++++++++++++++++++--------- gcc/m2/gm2-compiler/Sets.def | 12 +- gcc/m2/gm2-compiler/Sets.mod | 61 ++- 3 files changed, 491 insertions(+), 221 deletions(-) diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod index 5c8e3f08774f..594178f826d1 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod @@ -50,7 +50,7 @@ FROM M2FileName IMPORT CalculateFileName ; FROM DynamicStrings IMPORT String, string, InitString, KillString, InitStringCharStar, InitStringChar, Mark ; FROM FormatStrings IMPORT Sprintf1 ; FROM M2LexBuf IMPORT TokenToLineNo, FindFileNameFromToken, TokenToLocation, UnknownTokenNo, BuiltinTokenNo ; -FROM M2MetaError IMPORT MetaError1, MetaError3 ; +FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3 ; FROM M2Error IMPORT FlushErrors, InternalError ; FROM M2Printf IMPORT printf0, printf1, printf2, printf3 ; @@ -65,7 +65,8 @@ FROM Lists IMPORT List, InitList, IncludeItemIntoList, FROM Sets IMPORT Set, InitSet, KillSet, IncludeElementIntoSet, ExcludeElementFromSet, - NoOfElementsInSet, IsElementInSet, ForeachElementInSetDo ; + NoOfElementsInSet, IsElementInSet, ForeachElementInSetDo, + DuplicateSet, EqualSet ; FROM SymbolTable IMPORT NulSym, ModeOfAddr, @@ -115,13 +116,16 @@ FROM SymbolTable IMPORT NulSym, GetParameterShadowVar, GetUnboundedRecordType, GetModuleCtors, + MakeSubrange, MakeConstVar, MakeConstLit, + PutConst, ForeachOAFamily, GetOAFamily, IsModuleWithinProcedure, IsVariableSSA, IsVariableAtAddress, IsConstructorConstant, ForeachLocalSymDo, ForeachProcedureDo, ForeachModuleDo, ForeachInnerModuleDo, ForeachImportedDo, - ForeachExportedDo, PrintInitialized ; + ForeachExportedDo, PrintInitialized, + FinalSymbol ; FROM M2Base IMPORT IsPseudoBaseProcedure, IsPseudoBaseFunction, GetBaseTypeMinMax, MixTypes, @@ -145,6 +149,7 @@ FROM M2Scope IMPORT ScopeBlock, InitScopeBlock, KillScopeBlock, ForeachScopeBloc FROM M2ALU IMPORT Addn, Sub, Equ, GreEqu, Gre, Less, PushInt, PushCard, ConvertToType, PushIntegerTree, PopIntegerTree, PopRealTree, ConvertToInt, PopSetTree, PopChar, + DivTrunc, IsConstructorDependants, WalkConstructorDependants, PopConstructorTree, PopComplexTree, PutConstructorSolved, ChangeToConstructor, EvaluateValue, TryEvaluateValue ; @@ -189,47 +194,61 @@ FROM m2expr IMPORT BuildSub, BuildLSL, BuildTBitSize, BuildAdd, BuildDivTrunc, B BuildSize, TreeOverflow, AreConstantsEqual, CompareTrees, GetPointerZero, GetIntegerZero, GetIntegerOne ; -FROM m2block IMPORT RememberType, pushGlobalScope, popGlobalScope, pushFunctionScope, popFunctionScope, +FROM m2block IMPORT RememberType, pushGlobalScope, popGlobalScope, + pushFunctionScope, popFunctionScope, finishFunctionDecl, RememberConstant, GetGlobalContext ; TYPE StartProcedure = PROCEDURE (location_t, ADDRESS) : Tree ; ListType = (fullydeclared, partiallydeclared, niltypedarrays, - heldbyalignment, finishedalignment, todolist, tobesolvedbyquads) ; + heldbyalignment, finishedalignment, todolist, + tobesolvedbyquads, finishedsetarray) ; doDeclareProcedure = PROCEDURE (CARDINAL, CARDINAL) ; CONST - Debugging = FALSE ; - Progress = FALSE ; - EnableSSA = FALSE ; + Debugging = FALSE ; + Progress = FALSE ; + EnableSSA = FALSE ; + EnableWatch = FALSE ; + + +TYPE + Group = POINTER TO RECORD + ToBeSolvedByQuads, (* Constants which must be solved *) + (* by processing the quadruples. *) + FinishedSetArray, (* Sets which have had their set *) + (* array created. *) + NilTypedArrays, (* Arrays which have NIL as their *) + (* type. *) + FullyDeclared, (* Those symbols which have been *) + (* fully declared. *) + PartiallyDeclared, (* Those types which have need to *) + (* be finished (but already *) + (* started: records, function *) + (* and array type). *) + HeldByAlignment, (* Types which have a user *) + (* specified alignment constant. *) + FinishedAlignment, (* Records for which we know *) + (* their alignment value. *) + ToDoList : Set ; (* Contains a set of all *) + (* outstanding types that need to *) + (* be declared to GCC once *) + (* its dependants have *) + (* been written. *) + Next : Group ; + END ; + VAR - ToBeSolvedByQuads, (* constants which must be solved *) - (* by processing the quadruples. *) - NilTypedArrays, (* arrays which have NIL as their *) - (* type. *) - FullyDeclared, (* those symbols which have been *) - (* fully declared. *) - PartiallyDeclared, (* those types which have need to *) - (* be finished (but already *) - (* started: records, function, *) - (* and array type). *) - HeldByAlignment, (* types which have a user *) - (* specified alignment constant. *) - FinishedAlignment, (* records for which we know *) - (* their alignment value. *) + FreeGroup, + GlobalGroup : Group ; (* The global group of all sets. *) VisitedList, - ChainedList, - ToDoList : Set ; (* Contains a set of all *) - (* outstanding types that need to *) - (* be declared to GCC once *) - (* its dependants have *) - (* been written. *) - HaveInitDefaultTypes: BOOLEAN ; (* have we initialized them yet? *) - WatchList : Set ; (* Set of symbols being watched *) + ChainedList : Set ; + HaveInitDefaultTypes: BOOLEAN ; (* Have we initialized them yet? *) + WatchList : Set ; (* Set of symbols being watched. *) EnumerationIndex : Index ; action : IsAction ; enumDeps : BOOLEAN ; @@ -237,7 +256,7 @@ VAR PROCEDURE mystop ; BEGIN END mystop ; -(* *************************************************** +(* *************************************************** *) (* PrintNum - *) @@ -254,10 +273,10 @@ END PrintNum ; PROCEDURE DebugSet (a: ARRAY OF CHAR; l: Set) ; BEGIN - printf0(a) ; - printf0(' {') ; + printf0 (a) ; + printf0 (' {') ; ForeachElementInSetDo (l, PrintNum) ; - printf0('}\n') + printf0 ('}\n') END DebugSet ; @@ -267,15 +286,16 @@ END DebugSet ; PROCEDURE DebugSets ; BEGIN - DebugSet('ToDoList', ToDoList) ; - DebugSet('HeldByAlignment', HeldByAlignment) ; - DebugSet('FinishedAlignment', FinishedAlignment) ; - DebugSet('PartiallyDeclared', PartiallyDeclared) ; - DebugSet('FullyDeclared', FullyDeclared) ; - DebugSet('NilTypedArrays', NilTypedArrays) ; - DebugSet('ToBeSolvedByQuads', ToBeSolvedByQuads) + DebugSet ('ToDoList', GlobalGroup^.ToDoList) ; + DebugSet ('HeldByAlignment', GlobalGroup^.HeldByAlignment) ; + DebugSet ('FinishedAlignment', GlobalGroup^.FinishedAlignment) ; + DebugSet ('PartiallyDeclared', GlobalGroup^.PartiallyDeclared) ; + DebugSet ('FullyDeclared', GlobalGroup^.FullyDeclared) ; + DebugSet ('NilTypedArrays', GlobalGroup^.NilTypedArrays) ; + DebugSet ('ToBeSolvedByQuads', GlobalGroup^.ToBeSolvedByQuads) ; + DebugSet ('FinishedSetArray', GlobalGroup^.FinishedSetArray) END DebugSets ; - ************************************************ *) +(* ************************************************ *) (* @@ -286,50 +306,25 @@ PROCEDURE DebugNumber (a: ARRAY OF CHAR; s: Set) ; VAR n: CARDINAL ; BEGIN - n := NoOfElementsInSet(s) ; - printf1(a, n) ; - FIO.FlushBuffer(FIO.StdOut) + n := NoOfElementsInSet (s) ; + printf1 (a, n) ; + FIO.FlushBuffer (FIO.StdOut) END DebugNumber ; -(* - FindSetNumbers - -*) - -PROCEDURE FindSetNumbers (VAR t, a, p, f, n, b: CARDINAL) : BOOLEAN ; -VAR - t1, p1, f1, n1, b1, a1: CARDINAL ; - same : BOOLEAN ; -BEGIN - t1 := NoOfElementsInSet(ToDoList) ; - a1 := NoOfElementsInSet(HeldByAlignment) ; - p1 := NoOfElementsInSet(PartiallyDeclared) ; - f1 := NoOfElementsInSet(FullyDeclared) ; - n1 := NoOfElementsInSet(NilTypedArrays) ; - b1 := NoOfElementsInSet(ToBeSolvedByQuads) ; - same := ((t=t1) AND (a=a1) AND (p=p1) AND (f=f1) AND (n=n1) AND (b=b1)) ; - t := t1 ; - a := a1 ; - p := p1 ; - f := f1 ; - n := n1 ; - b := b1 ; - RETURN( same ) -END FindSetNumbers ; - - (* DebugSets - *) PROCEDURE DebugSetNumbers ; BEGIN - DebugNumber('ToDoList : %d\n', ToDoList) ; - DebugNumber('HeldByAlignment : %d\n', HeldByAlignment) ; - DebugNumber('PartiallyDeclared : %d\n', PartiallyDeclared) ; - DebugNumber('FullyDeclared : %d\n', FullyDeclared) ; - DebugNumber('NilTypedArrays : %d\n', NilTypedArrays) ; - DebugNumber('ToBeSolvedByQuads : %d\n', ToBeSolvedByQuads) + DebugNumber ('ToDoList : %d\n', GlobalGroup^.ToDoList) ; + DebugNumber ('HeldByAlignment : %d\n', GlobalGroup^.HeldByAlignment) ; + DebugNumber ('PartiallyDeclared : %d\n', GlobalGroup^.PartiallyDeclared) ; + DebugNumber ('FullyDeclared : %d\n', GlobalGroup^.FullyDeclared) ; + DebugNumber ('NilTypedArrays : %d\n', GlobalGroup^.NilTypedArrays) ; + DebugNumber ('ToBeSolvedByQuads : %d\n', GlobalGroup^.ToBeSolvedByQuads) ; + DebugNumber ('FinishedSetArray : %d\n', GlobalGroup^.FinishedSetArray) END DebugSetNumbers ; @@ -341,12 +336,12 @@ END DebugSetNumbers ; PROCEDURE AddSymToWatch (sym: WORD) ; BEGIN - IF (sym#NulSym) AND (NOT IsElementInSet(WatchList, sym)) + IF (sym # NulSym) AND (NOT IsElementInSet (WatchList, sym)) THEN - IncludeElementIntoSet(WatchList, sym) ; - WalkDependants(sym, AddSymToWatch) ; - printf1("watching symbol %d\n", sym) ; - FIO.FlushBuffer(FIO.StdOut) + IncludeElementIntoSet (WatchList, sym) ; + WalkDependants (sym, AddSymToWatch) ; + printf1 ("watching symbol %d\n", sym) ; + FIO.FlushBuffer (FIO.StdOut) END END AddSymToWatch ; @@ -401,21 +396,18 @@ END doInclude ; PROCEDURE WatchIncludeList (sym: CARDINAL; lt: ListType) ; BEGIN - IF IsElementInSet(WatchList, sym) + IF IsElementInSet (WatchList, sym) THEN CASE lt OF - tobesolvedbyquads : doInclude(ToBeSolvedByQuads, "symbol %d -> ToBeSolvedByQuads\n", sym) | - fullydeclared : doInclude(FullyDeclared, "symbol %d -> FullyDeclared\n", sym) ; - IF sym=8821 - THEN - mystop - END | - partiallydeclared : doInclude(PartiallyDeclared, "symbol %d -> PartiallyDeclared\n", sym) | - heldbyalignment : doInclude(HeldByAlignment, "symbol %d -> HeldByAlignment\n", sym) | - finishedalignment : doInclude(FinishedAlignment, "symbol %d -> FinishedAlignment\n", sym) | - todolist : doInclude(ToDoList, "symbol %d -> ToDoList\n", sym) | - niltypedarrays : doInclude(NilTypedArrays, "symbol %d -> NilTypedArrays\n", sym) + tobesolvedbyquads : doInclude (GlobalGroup^.ToBeSolvedByQuads, "symbol %d -> ToBeSolvedByQuads\n", sym) | + fullydeclared : doInclude (GlobalGroup^.FullyDeclared, "symbol %d -> FullyDeclared\n", sym) | + partiallydeclared : doInclude (GlobalGroup^.PartiallyDeclared, "symbol %d -> PartiallyDeclared\n", sym) | + heldbyalignment : doInclude (GlobalGroup^.HeldByAlignment, "symbol %d -> HeldByAlignment\n", sym) | + finishedalignment : doInclude (GlobalGroup^.FinishedAlignment, "symbol %d -> FinishedAlignment\n", sym) | + todolist : doInclude (GlobalGroup^.ToDoList, "symbol %d -> ToDoList\n", sym) | + niltypedarrays : doInclude (GlobalGroup^.NilTypedArrays, "symbol %d -> NilTypedArrays\n", sym) | + finishedsetarray : doInclude (GlobalGroup^.FinishedSetArray, "symbol %d -> FinishedSetArray\n", sym) ELSE InternalError ('unknown list') @@ -423,13 +415,18 @@ BEGIN ELSE CASE lt OF - tobesolvedbyquads : IncludeElementIntoSet(ToBeSolvedByQuads, sym) | - fullydeclared : IncludeElementIntoSet(FullyDeclared, sym) | - partiallydeclared : IncludeElementIntoSet(PartiallyDeclared, sym) | - heldbyalignment : IncludeElementIntoSet(HeldByAlignment, sym) | - finishedalignment : IncludeElementIntoSet(FinishedAlignment, sym) | - todolist : IncludeElementIntoSet(ToDoList, sym) | - niltypedarrays : IncludeElementIntoSet(NilTypedArrays, sym) + tobesolvedbyquads : IncludeElementIntoSet (GlobalGroup^.ToBeSolvedByQuads, sym) | + fullydeclared : IncludeElementIntoSet (GlobalGroup^.FullyDeclared, sym) | + partiallydeclared : IncludeElementIntoSet (GlobalGroup^.PartiallyDeclared, sym) | + heldbyalignment : IncludeElementIntoSet (GlobalGroup^.HeldByAlignment, sym) | + finishedalignment : IncludeElementIntoSet (GlobalGroup^.FinishedAlignment, sym) | + todolist : IncludeElementIntoSet (GlobalGroup^.ToDoList, sym) ; + IF EnableWatch AND (sym = 919) + THEN + IncludeElementIntoSet (WatchList, 919) + END | + niltypedarrays : IncludeElementIntoSet (GlobalGroup^.NilTypedArrays, sym) | + finishedsetarray : IncludeElementIntoSet (GlobalGroup^.FinishedSetArray, sym) ELSE InternalError ('unknown list') @@ -444,14 +441,14 @@ END WatchIncludeList ; PROCEDURE doExclude (l: Set; a: ARRAY OF CHAR; sym: CARDINAL) ; BEGIN - IF IsElementInSet(l, sym) + IF IsElementInSet (l, sym) THEN - printf0('rule: ') ; + printf0 ('rule: ') ; WriteRule ; - printf0(' ') ; - printf1(a, sym) ; - FIO.FlushBuffer(FIO.StdOut) ; - ExcludeElementFromSet(l, sym) + printf0 (' ') ; + printf1 (a, sym) ; + FIO.FlushBuffer (FIO.StdOut) ; + ExcludeElementFromSet (l, sym) END END doExclude ; @@ -465,17 +462,18 @@ END doExclude ; PROCEDURE WatchRemoveList (sym: CARDINAL; lt: ListType) ; BEGIN - IF IsElementInSet(WatchList, sym) + IF IsElementInSet (WatchList, sym) THEN CASE lt OF - tobesolvedbyquads : doExclude(ToBeSolvedByQuads, "symbol %d off ToBeSolvedByQuads\n", sym) | - fullydeclared : doExclude(FullyDeclared, "symbol %d off FullyDeclared\n", sym) | - partiallydeclared : doExclude(PartiallyDeclared, "symbol %d off PartiallyDeclared\n", sym) | - heldbyalignment : doExclude(HeldByAlignment, "symbol %d -> HeldByAlignment\n", sym) | - finishedalignment : doExclude(FinishedAlignment, "symbol %d -> FinishedAlignment\n", sym) | - todolist : doExclude(ToDoList, "symbol %d off ToDoList\n", sym) | - niltypedarrays : doExclude(NilTypedArrays, "symbol %d off NilTypedArrays\n", sym) + tobesolvedbyquads : doExclude (GlobalGroup^.ToBeSolvedByQuads, "symbol %d off ToBeSolvedByQuads\n", sym) | + fullydeclared : doExclude (GlobalGroup^.FullyDeclared, "symbol %d off FullyDeclared\n", sym) | + partiallydeclared : doExclude (GlobalGroup^.PartiallyDeclared, "symbol %d off PartiallyDeclared\n", sym) | + heldbyalignment : doExclude (GlobalGroup^.HeldByAlignment, "symbol %d -> HeldByAlignment\n", sym) | + finishedalignment : doExclude (GlobalGroup^.FinishedAlignment, "symbol %d -> FinishedAlignment\n", sym) | + todolist : doExclude (GlobalGroup^.ToDoList, "symbol %d off ToDoList\n", sym) | + niltypedarrays : doExclude (GlobalGroup^.NilTypedArrays, "symbol %d off NilTypedArrays\n", sym) | + finishedsetarray : doExclude (GlobalGroup^.FinishedSetArray, "symbol %d off FinishedSetArray\n", sym) | ELSE InternalError ('unknown list') @@ -483,13 +481,14 @@ BEGIN ELSE CASE lt OF - tobesolvedbyquads : ExcludeElementFromSet(ToBeSolvedByQuads, sym) | - fullydeclared : ExcludeElementFromSet(FullyDeclared, sym) | - partiallydeclared : ExcludeElementFromSet(PartiallyDeclared, sym) | - heldbyalignment : ExcludeElementFromSet(HeldByAlignment, sym) | - finishedalignment : ExcludeElementFromSet(FinishedAlignment, sym) | - todolist : ExcludeElementFromSet(ToDoList, sym) | - niltypedarrays : ExcludeElementFromSet(NilTypedArrays, sym) + tobesolvedbyquads : ExcludeElementFromSet (GlobalGroup^.ToBeSolvedByQuads, sym) | + fullydeclared : ExcludeElementFromSet (GlobalGroup^.FullyDeclared, sym) | + partiallydeclared : ExcludeElementFromSet (GlobalGroup^.PartiallyDeclared, sym) | + heldbyalignment : ExcludeElementFromSet (GlobalGroup^.HeldByAlignment, sym) | + finishedalignment : ExcludeElementFromSet (GlobalGroup^.FinishedAlignment, sym) | + todolist : ExcludeElementFromSet (GlobalGroup^.ToDoList, sym) | + niltypedarrays : ExcludeElementFromSet (GlobalGroup^.NilTypedArrays, sym) | + finishedsetarray : ExcludeElementFromSet (GlobalGroup^.FinishedSetArray, sym) | ELSE InternalError ('unknown list') @@ -498,6 +497,155 @@ BEGIN END WatchRemoveList ; +(* + NewGroup - +*) + +PROCEDURE NewGroup (VAR g: Group) ; +BEGIN + IF FreeGroup = NIL + THEN + NEW (g) + ELSE + g := FreeGroup ; + FreeGroup := FreeGroup^.Next + END +END NewGroup ; + + +(* + DisposeGroup - +*) + +PROCEDURE DisposeGroup (VAR g: Group) ; +BEGIN + g^.Next := FreeGroup ; + FreeGroup := g ; + g := NIL +END DisposeGroup ; + + +(* + InitGroup - initialize all sets in group and return the group. +*) + +PROCEDURE InitGroup () : Group ; +VAR + g: Group ; +BEGIN + NewGroup (g) ; + (* Initialize all sets in group. *) + WITH g^ DO + FinishedSetArray := InitSet (1) ; + ToDoList := InitSet (1) ; + FullyDeclared := InitSet (1) ; + PartiallyDeclared := InitSet (1) ; + NilTypedArrays := InitSet (1) ; + HeldByAlignment := InitSet (1) ; + FinishedAlignment := InitSet (1) ; + ToBeSolvedByQuads := InitSet (1) ; + Next := NIL + END ; + RETURN g +END InitGroup ; + + +(* + KillGroup - delete all sets in group and deallocate g. +*) + +PROCEDURE KillGroup (VAR g: Group) ; +BEGIN + (* Delete all sets in group. *) + IF g # NIL + THEN + WITH g^ DO + FinishedSetArray := KillSet (FinishedSetArray) ; + ToDoList := KillSet (ToDoList) ; + FullyDeclared := KillSet (FullyDeclared) ; + PartiallyDeclared := KillSet (PartiallyDeclared) ; + NilTypedArrays := KillSet (NilTypedArrays) ; + HeldByAlignment := KillSet (HeldByAlignment) ; + FinishedAlignment := KillSet (FinishedAlignment) ; + ToBeSolvedByQuads := KillSet (ToBeSolvedByQuads) ; + Next := NIL + END ; + DisposeGroup (g) + END +END KillGroup ; + + +(* + DupGroup - If g is not NIL then destroy g. + Return a duplicate of GlobalGroup. +*) + +PROCEDURE DupGroup (g: Group) : Group ; +BEGIN + IF g # NIL + THEN + (* Kill old group. *) + KillGroup (g) + END ; + NewGroup (g) ; + WITH g^ DO + (* Copy all sets. *) + FinishedSetArray := DuplicateSet (GlobalGroup^.FinishedSetArray) ; + ToDoList := DuplicateSet (GlobalGroup^.ToDoList) ; + FullyDeclared := DuplicateSet (GlobalGroup^.FullyDeclared) ; + PartiallyDeclared := DuplicateSet (GlobalGroup^.PartiallyDeclared) ; + NilTypedArrays := DuplicateSet (GlobalGroup^.NilTypedArrays) ; + HeldByAlignment := DuplicateSet (GlobalGroup^.HeldByAlignment) ; + FinishedAlignment := DuplicateSet (GlobalGroup^.FinishedAlignment) ; + ToBeSolvedByQuads := DuplicateSet (GlobalGroup^.ToBeSolvedByQuads) ; + Next := NIL + END ; + RETURN g +END DupGroup ; + + +(* + EqualGroup - return TRUE if group left = right. +*) + +PROCEDURE EqualGroup (left, right: Group) : BOOLEAN ; +BEGIN + RETURN ((left = right) OR + (EqualSet (left^.FullyDeclared, right^.FullyDeclared) AND + EqualSet (left^.PartiallyDeclared, right^.PartiallyDeclared) AND + EqualSet (left^.NilTypedArrays, right^.NilTypedArrays) AND + EqualSet (left^.HeldByAlignment, right^.HeldByAlignment) AND + EqualSet (left^.FinishedAlignment, right^.FinishedAlignment) AND + EqualSet (left^.ToDoList, right^.ToDoList) AND + EqualSet (left^.ToBeSolvedByQuads, right^.ToBeSolvedByQuads) AND + EqualSet (left^.FinishedSetArray, right^.FinishedSetArray))) +END EqualGroup ; + + +(* + LookupSet - +*) + +PROCEDURE LookupSet (listtype: ListType) : Set ; +BEGIN + CASE listtype OF + + fullydeclared : RETURN GlobalGroup^.FullyDeclared | + partiallydeclared : RETURN GlobalGroup^.PartiallyDeclared | + niltypedarrays : RETURN GlobalGroup^.NilTypedArrays | + heldbyalignment : RETURN GlobalGroup^.HeldByAlignment | + finishedalignment : RETURN GlobalGroup^.FinishedAlignment | + todolist : RETURN GlobalGroup^.ToDoList | + tobesolvedbyquads : RETURN GlobalGroup^.ToBeSolvedByQuads | + finishedsetarray : RETURN GlobalGroup^.FinishedSetArray + + ELSE + InternalError ('unknown ListType') + END ; + RETURN NIL +END LookupSet ; + + (* GetEnumList - *) @@ -685,7 +833,7 @@ PROCEDURE CanDeclareTypePartially (sym: CARDINAL) : BOOLEAN ; VAR type: CARDINAL ; BEGIN - IF IsElementInSet(PartiallyDeclared, sym) + IF IsElementInSet(GlobalGroup^.PartiallyDeclared, sym) THEN RETURN( FALSE ) ELSIF IsProcType(sym) OR IsRecord(sym) OR IsVarient(sym) OR IsFieldVarient(sym) @@ -712,21 +860,21 @@ VAR location: location_t ; BEGIN (* check to see if we have already partially declared the symbol *) - IF NOT IsElementInSet(PartiallyDeclared, sym) + IF NOT IsElementInSet(GlobalGroup^.PartiallyDeclared, sym) THEN IF IsRecord(sym) THEN - Assert (NOT IsElementInSet (HeldByAlignment, sym)) ; + Assert (NOT IsElementInSet (GlobalGroup^.HeldByAlignment, sym)) ; Assert (DoStartDeclaration (sym, BuildStartRecord) # NIL) ; WatchIncludeList (sym, heldbyalignment) ELSIF IsVarient (sym) THEN - Assert(NOT IsElementInSet(HeldByAlignment, sym)) ; + Assert(NOT IsElementInSet(GlobalGroup^.HeldByAlignment, sym)) ; Assert (DoStartDeclaration(sym, BuildStartVarient) # NIL) ; WatchIncludeList(sym, heldbyalignment) ELSIF IsFieldVarient(sym) THEN - Assert(NOT IsElementInSet(HeldByAlignment, sym)) ; + Assert(NOT IsElementInSet(GlobalGroup^.HeldByAlignment, sym)) ; Assert (DoStartDeclaration(sym, BuildStartFieldVarient) # NIL) ; WatchIncludeList(sym, heldbyalignment) ELSIF IsProcType(sym) @@ -852,7 +1000,7 @@ END PromotePointerFully ; PROCEDURE CompletelyResolved (sym: CARDINAL) : BOOLEAN ; BEGIN - RETURN( IsElementInSet(FullyDeclared, sym) ) + RETURN( IsElementInSet(GlobalGroup^.FullyDeclared, sym) ) END CompletelyResolved ; @@ -932,7 +1080,7 @@ END IsTypeQ ; PROCEDURE IsNilTypedArrays (sym: CARDINAL) : BOOLEAN ; BEGIN - RETURN( IsElementInSet(NilTypedArrays, sym) ) + RETURN( IsElementInSet(GlobalGroup^.NilTypedArrays, sym) ) END IsNilTypedArrays ; @@ -942,7 +1090,7 @@ END IsNilTypedArrays ; PROCEDURE IsFullyDeclared (sym: CARDINAL) : BOOLEAN ; BEGIN - RETURN( IsElementInSet(FullyDeclared, sym) ) + RETURN( IsElementInSet(GlobalGroup^.FullyDeclared, sym) ) END IsFullyDeclared ; @@ -974,7 +1122,7 @@ END NotAllDependantsFullyDeclared ; PROCEDURE IsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ; BEGIN - RETURN( IsElementInSet(PartiallyDeclared, sym) ) + RETURN( IsElementInSet(GlobalGroup^.PartiallyDeclared, sym) ) END IsPartiallyDeclared ; @@ -1006,8 +1154,8 @@ END NotAllDependantsPartiallyDeclared ; PROCEDURE IsPartiallyOrFullyDeclared (sym: CARDINAL) : BOOLEAN ; BEGIN - RETURN( IsElementInSet(PartiallyDeclared, sym) OR - IsElementInSet(FullyDeclared, sym) ) + RETURN( IsElementInSet(GlobalGroup^.PartiallyDeclared, sym) OR + IsElementInSet(GlobalGroup^.FullyDeclared, sym) ) END IsPartiallyOrFullyDeclared ; @@ -1102,7 +1250,7 @@ PROCEDURE DeclareTypeConstFully (sym: CARDINAL) ; VAR t: Tree ; BEGIN - IF NOT IsElementInSet(ToBeSolvedByQuads, sym) + IF NOT IsElementInSet(GlobalGroup^.ToBeSolvedByQuads, sym) THEN IF IsModule(sym) OR IsDefImp(sym) THEN @@ -1210,7 +1358,6 @@ VAR bodyp : WalkAction ; bodyq : IsAction ; bodyt : ListType ; - bodyl : Set ; bodyr : Rule ; recursionCaught, oneResolved, @@ -1257,12 +1404,12 @@ END WriteRule ; PROCEDURE Body (sym: CARDINAL) ; BEGIN - IF bodyq(sym) + IF bodyq (sym) THEN - WatchRemoveList(sym, bodyt) ; - bodyp(sym) ; - (* bodyp(sym) might have replaced sym into the set *) - IF NOT IsElementInSet(bodyl, sym) + WatchRemoveList (sym, bodyt) ; + bodyp (sym) ; + (* The bodyp (sym) procedure function might have replaced sym into the set. *) + IF NOT IsElementInSet (LookupSet (bodyt), sym) THEN noMoreWritten := FALSE ; oneResolved := TRUE @@ -1272,16 +1419,17 @@ END Body ; (* - ForeachTryDeclare - while q(of one sym in l) is true - for each symbol in, l, - if q(sym) - then - p(sym) + ForeachTryDeclare - while q (of one sym in set t) is true + for each symbol in set t, + if q (sym) + then + p (sym) + end end end *) -PROCEDURE ForeachTryDeclare (t: ListType; l: Set; r: Rule; +PROCEDURE ForeachTryDeclare (t: ListType; r: Rule; q: IsAction; p: WalkAction) : BOOLEAN ; BEGIN IF recursionCaught @@ -1291,13 +1439,12 @@ BEGIN bodyt := t ; bodyq := q ; bodyp := p ; - bodyl := l ; bodyr := r ; recursionCaught := TRUE ; oneResolved := FALSE ; REPEAT noMoreWritten := TRUE ; - ForeachElementInSetDo(l, Body) + ForeachElementInSetDo (LookupSet (t), Body) UNTIL noMoreWritten ; bodyr := norule ; recursionCaught := FALSE ; @@ -1313,113 +1460,129 @@ END ForeachTryDeclare ; PROCEDURE DeclaredOutstandingTypes (ForceComplete: BOOLEAN) : BOOLEAN ; VAR - finished : BOOLEAN ; - d, a, p, f, n, b: CARDINAL ; -BEGIN - d := 0 ; - a := 0 ; - p := 0 ; - f := 0 ; - n := 0 ; - b := 0 ; + finished: BOOLEAN ; + copy : Group ; +BEGIN + copy := NIL ; finished := FALSE ; REPEAT - IF FindSetNumbers (d, a, p, f, n, b) OR Progress + IF Progress AND (copy # NIL) THEN - DebugSetNumbers + IF NOT EqualGroup (copy, GlobalGroup) + THEN + DebugSetNumbers ; + DebugSets + END END ; - IF ForeachTryDeclare (todolist, ToDoList, + copy := DupGroup (copy) ; + IF ForeachTryDeclare (todolist, partialtype, CanDeclareTypePartially, DeclareTypePartially) THEN (* continue looping *) - ELSIF ForeachTryDeclare (todolist, ToDoList, +(* + ELSIF ForeachTryDeclare (todolist, + setarraynul, + CanCreateSetArray, + CreateSetArray) + THEN + (* Populates the finishedsetarray list with each set seen. *) + (* Continue looping. *) + ELSIF ForeachTryDeclare (finishedsetarray, + setfully, + CanCreateSet, + CreateSet) + THEN + (* Populates the fullydeclared list with each set. *) + (* Continue looping. *) +*) + ELSIF ForeachTryDeclare (todolist, arraynil, CanDeclareArrayAsNil, DeclareArrayAsNil) THEN (* continue looping *) - ELSIF ForeachTryDeclare (todolist, ToDoList, + ELSIF ForeachTryDeclare (todolist, pointernilarray, CanDeclarePointerToNilArray, DeclarePointerToNilArray) THEN (* continue looping *) - ELSIF ForeachTryDeclare (niltypedarrays, NilTypedArrays, + ELSIF ForeachTryDeclare (niltypedarrays, arraypartial, CanDeclareArrayPartially, DeclareArrayPartially) THEN (* continue looping *) - ELSIF ForeachTryDeclare (niltypedarrays, NilTypedArrays, + ELSIF ForeachTryDeclare (niltypedarrays, pointerfully, CanPromotePointerFully, PromotePointerFully) THEN (* continue looping *) - ELSIF ForeachTryDeclare (heldbyalignment, HeldByAlignment, + ELSIF ForeachTryDeclare (heldbyalignment, recordkind, CanDeclareRecordKind, DeclareRecordKind) THEN (* continue looping *) - ELSIF ForeachTryDeclare (finishedalignment, FinishedAlignment, + ELSIF ForeachTryDeclare (finishedalignment, recordfully, CanDeclareRecord, FinishDeclareRecord) THEN (* continue looping *) - ELSIF ForeachTryDeclare (todolist, ToDoList, + ELSIF ForeachTryDeclare (todolist, typeconstfully, TypeConstDependantsFullyDeclared, DeclareTypeConstFully) THEN - (* continue looping *) - ELSIF ForeachTryDeclare (todolist, ToDoList, - (* partiallydeclared, PartiallyDeclared, *) + (* Continue looping. *) + ELSIF ForeachTryDeclare (todolist, typefrompartial, CanBeDeclaredViaPartialDependants, DeclareTypeFromPartial) THEN - (* continue looping *) - ELSIF ForeachTryDeclare (partiallydeclared, PartiallyDeclared, + (* Continue looping. *) + ELSIF ForeachTryDeclare (partiallydeclared, partialfrompartial, CanBeDeclaredPartiallyViaPartialDependants, DeclareTypePartially) THEN - (* continue looping *) - ELSIF ForeachTryDeclare (partiallydeclared, PartiallyDeclared, + (* Continue looping. *) + ELSIF ForeachTryDeclare (partiallydeclared, partialtofully, TypeConstDependantsFullyDeclared, DeclareTypeConstFully) THEN - (* continue looping *) + (* Continue looping. *) ELSE - (* nothing left to do (and constants are resolved elsewhere) *) + (* Nothing left to do (and constants are resolved elsewhere). *) finished := TRUE END UNTIL finished ; + KillGroup (copy) ; IF ForceComplete THEN - IF ForeachTryDeclare (todolist, ToDoList, + IF ForeachTryDeclare (todolist, circulartodo, NotAllDependantsFullyDeclared, EmitCircularDependancyError) THEN - ELSIF ForeachTryDeclare (partiallydeclared, PartiallyDeclared, + ELSIF ForeachTryDeclare (partiallydeclared, circularpartial, NotAllDependantsPartiallyDeclared, EmitCircularDependancyError) THEN - ELSIF ForeachTryDeclare (niltypedarrays, NilTypedArrays, + ELSIF ForeachTryDeclare (niltypedarrays, circularniltyped, NotAllDependantsPartiallyDeclared, EmitCircularDependancyError) THEN END END ; - RETURN NoOfElementsInSet (ToDoList) = 0 + RETURN NoOfElementsInSet (GlobalGroup^.ToDoList) = 0 END DeclaredOutstandingTypes ; @@ -1661,7 +1824,7 @@ BEGIN IF IsConstructor(sym) AND (NOT GccKnowsAbout(sym)) THEN WalkConstructor(sym, TraverseDependants) ; - IF NOT IsElementInSet(ToBeSolvedByQuads, sym) + IF NOT IsElementInSet(GlobalGroup^.ToBeSolvedByQuads, sym) THEN TryEvaluateValue(sym) ; IF IsConstructorDependants(sym, IsFullyDeclared) @@ -1762,7 +1925,7 @@ BEGIN TraverseDependants(sym) ; RETURN END ; - IF IsElementInSet(ToBeSolvedByQuads, sym) + IF IsElementInSet(GlobalGroup^.ToBeSolvedByQuads, sym) THEN (* we allow the above rules to be executed even if it is fully declared so to ensure that types of compiler builtin constants (BitsetSize @@ -2084,8 +2247,8 @@ END WalkDependants ; PROCEDURE TraverseDependantsInner (sym: WORD) ; BEGIN - IF (NOT IsElementInSet(FullyDeclared, sym)) AND - (NOT IsElementInSet(ToDoList, sym)) + IF (NOT IsElementInSet(GlobalGroup^.FullyDeclared, sym)) AND + (NOT IsElementInSet(GlobalGroup^.ToDoList, sym)) THEN WatchIncludeList(sym, todolist) END ; @@ -2556,29 +2719,81 @@ BEGIN END FoldConstants ; +(* + ActivateWatch - activate a watch for any symbol (lista xor listb). +*) + +PROCEDURE ActivateWatch (lista, listb: Set) ; +VAR + smallest, + largest : Set ; + n, sym : CARDINAL ; +BEGIN + IF NoOfElementsInSet (lista) # NoOfElementsInSet (listb) + THEN + IF NoOfElementsInSet (lista) > NoOfElementsInSet (listb) + THEN + largest := lista ; + smallest := listb + ELSE + largest := listb ; + smallest := lista + END ; + printf0 ("adding the following symbols to the watch list as the declarator has detected an internal bug: ") ; + sym := 1 ; + n := FinalSymbol () ; + WHILE sym <= n DO + IF (IsElementInSet (largest, sym) AND (NOT IsElementInSet (smallest, sym))) OR + ((NOT IsElementInSet (largest, sym)) AND IsElementInSet (smallest, sym)) + THEN + AddSymToWatch (sym) ; + printf1 ("%d ", sym) + END ; + INC (sym) + END ; + printf0 ("\n") + END +END ActivateWatch ; + + (* DeclareTypesConstantsProceduresInRange - *) PROCEDURE DeclareTypesConstantsProceduresInRange (scope, start, end: CARDINAL) ; +CONST + DebugLoop = 1000 ; VAR - n, m: CARDINAL ; + copy: Group ; + loop: CARDINAL ; BEGIN IF DisplayQuadruples THEN DisplayQuadRange (scope, start, end) END ; + loop := 0 ; + copy := NIL ; REPEAT - n := NoOfElementsInSet(ToDoList) ; + copy := DupGroup (copy) ; WHILE ResolveConstantExpressions (DeclareConstFully, start, end) DO END ; (* we need to evaluate some constant expressions to resolve these types *) IF DeclaredOutstandingTypes (FALSE) THEN END ; - m := NoOfElementsInSet(ToDoList) + IF loop = DebugLoop + THEN + IF DisplayQuadruples + THEN + DisplayQuadRange (scope, start, end) + END ; + ActivateWatch (copy^.ToDoList, GlobalGroup^.ToDoList) ; + loop := 0 + END ; + INC (loop) UNTIL (NOT ResolveConstantExpressions (DeclareConstFully, start, end)) AND - (n=m) + EqualGroup (copy, GlobalGroup) ; + KillGroup (copy) END DeclareTypesConstantsProceduresInRange ; @@ -2638,17 +2853,21 @@ END PopBinding ; PROCEDURE DeclareTypesConstantsProcedures (scope: CARDINAL) ; VAR - s, t: CARDINAL ; + copy: Group ; sb : ScopeBlock ; BEGIN + IF Debugging + THEN + printf0 ("declaring types constants in: ") ; PrintTerse (scope) + END ; + copy := NIL ; sb := InitScopeBlock (scope) ; PushBinding (scope) ; REPEAT - s := NoOfElementsInSet (ToDoList) ; - (* ForeachLocalSymDo(scope, DeclareTypeInfo) ; *) - ForeachScopeBlockDo (sb, DeclareTypesConstantsProceduresInRange) ; - t := NoOfElementsInSet (ToDoList) ; - UNTIL s=t ; + copy := DupGroup (copy) ; + ForeachScopeBlockDo (sb, DeclareTypesConstantsProceduresInRange) + UNTIL EqualGroup (copy, GlobalGroup) ; + KillGroup (copy) ; PopBinding (scope) ; KillScopeBlock (sb) END DeclareTypesConstantsProcedures ; @@ -2908,7 +3127,7 @@ BEGIN location := BuiltinsLocation () ; t := GetDefaultType(location, KeyToCharStar(MakeKey(name)), gcctype) ; AddModGcc(sym, t) ; - IncludeElementIntoSet(FullyDeclared, sym) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, sym) ; WalkAssociatedUnbounded(sym, TraverseDependants) ; (* this is very simplistic and assumes that the caller only uses Subranges, Sets and GCC types. @@ -2952,9 +3171,9 @@ BEGIN AddModGcc(Boolean, GetBooleanType()) ; AddModGcc(True, GetBooleanTrue()) ; AddModGcc(False, GetBooleanFalse()) ; - IncludeElementIntoSet(FullyDeclared, Boolean) ; - IncludeElementIntoSet(FullyDeclared, True) ; - IncludeElementIntoSet(FullyDeclared, False) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, Boolean) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, True) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, False) ; WalkAssociatedUnbounded(Boolean, TraverseDependants) END DeclareBoolean ; @@ -2983,7 +3202,7 @@ BEGIN KeyToCharStar(GetFullSymName(typetype)), Mod2Gcc(GetSType(typetype)), Mod2Gcc(low), Mod2Gcc(high))) ; - IncludeElementIntoSet(FullyDeclared, typetype) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, typetype) ; WalkAssociatedUnbounded(typetype, TraverseDependants) END ; (* gcc back end supports, type *) @@ -3001,9 +3220,9 @@ BEGIN AddModGcc(ZType, GetM2ZType()) ; AddModGcc(RType, GetM2RType()) ; AddModGcc(CType, GetM2CType()) ; - IncludeElementIntoSet(FullyDeclared, ZType) ; - IncludeElementIntoSet(FullyDeclared, RType) ; - IncludeElementIntoSet(FullyDeclared, CType) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, ZType) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, RType) ; + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, CType) ; DeclareDefaultType(Cardinal , "CARDINAL" , GetM2CardinalType()) ; DeclareDefaultType(Integer , "INTEGER" , GetM2IntegerType()) ; @@ -3073,7 +3292,7 @@ VAR BEGIN e := GetPackedEquivalent(Boolean) ; AddModGcc(e, GetPackedBooleanType()) ; - IncludeElementIntoSet(FullyDeclared, e) + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, e) END DeclarePackedBoolean ; @@ -3111,7 +3330,7 @@ END DeclareDefaultTypes ; PROCEDURE DeclareDefaultConstants ; BEGIN AddModGcc(Nil, GetPointerZero(BuiltinsLocation ())) ; - IncludeElementIntoSet(FullyDeclared, Nil) + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, Nil) END DeclareDefaultConstants ; @@ -4536,7 +4755,7 @@ BEGIN IF NOT GccKnowsAbout(equiv) THEN p(equiv, sym) ; - IncludeElementIntoSet(FullyDeclared, equiv) + IncludeElementIntoSet(GlobalGroup^.FullyDeclared, equiv) END ; RETURN( Mod2Gcc(equiv) ) END doDeclareEquivalent ; @@ -6293,18 +6512,12 @@ END InitDeclarations ; BEGIN - ToDoList := InitSet(1) ; - FullyDeclared := InitSet(1) ; - PartiallyDeclared := InitSet(1) ; - NilTypedArrays := InitSet(1) ; - HeldByAlignment := InitSet(1) ; - FinishedAlignment := InitSet(1) ; - ToBeSolvedByQuads := InitSet(1) ; + FreeGroup := NIL ; + GlobalGroup := InitGroup () ; ChainedList := InitSet(1) ; WatchList := InitSet(1) ; VisitedList := NIL ; EnumerationIndex := InitIndex(1) ; - IncludeElementIntoSet(WatchList, 8) ; HaveInitDefaultTypes := FALSE ; recursionCaught := FALSE END M2GCCDeclare. diff --git a/gcc/m2/gm2-compiler/Sets.def b/gcc/m2/gm2-compiler/Sets.def index 7c4cea0ee27b..e9c1ed41c11d 100644 --- a/gcc/m2/gm2-compiler/Sets.def +++ b/gcc/m2/gm2-compiler/Sets.def @@ -34,11 +34,6 @@ DEFINITION MODULE Sets ; FROM SymbolKey IMPORT PerformOperation ; -EXPORT QUALIFIED Set, - InitSet, KillSet, - IncludeElementIntoSet, ExcludeElementFromSet, - NoOfElementsInSet, IsElementInSet, - ForeachElementInSetDo, DuplicateSet ; TYPE Set ; @@ -101,4 +96,11 @@ PROCEDURE ExcludeElementFromSet (s: Set; i: CARDINAL) ; PROCEDURE IncludeElementIntoSet (s: Set; i: CARDINAL) ; +(* + EqualSet - return TRUE if left = right. +*) + +PROCEDURE EqualSet (left, right: Set) : BOOLEAN ; + + END Sets. diff --git a/gcc/m2/gm2-compiler/Sets.mod b/gcc/m2/gm2-compiler/Sets.mod index fd07f58e76cd..59f8210369e4 100644 --- a/gcc/m2/gm2-compiler/Sets.mod +++ b/gcc/m2/gm2-compiler/Sets.mod @@ -31,9 +31,9 @@ FROM Assertion IMPORT Assert ; CONST - BitsetSize = SIZE(BITSET) ; - MaxBitset = MAX(BITSET) ; - BitsPerByte = (MaxBitset+1) DIV BitsetSize ; + BitsetSize = SIZE (BITSET) ; + MaxBitset = MAX (BITSET) ; + BitsPerByte = (MaxBitset + 1) DIV BitsetSize ; Debugging = FALSE ; TYPE @@ -315,4 +315,59 @@ BEGIN END IncludeElementIntoSet ; +(* + EqualSet - return TRUE if left = right. +*) + +PROCEDURE EqualSet (left, right: Set) : BOOLEAN ; +VAR + v : PtrToByte ; + lptr, + rptr: PtrToBitset ; + last, + el : CARDINAL ; +BEGIN + IF (left^.init = right^.init) AND + (left^.start = right^.start) AND + (left^.end = right^.end) AND + (left^.elements = right^.elements) + THEN + (* Now check contents. *) + el := left^.start ; + last := left^.end ; + WHILE el <= last DO + lptr := findPos (left^.pb, el) ; + rptr := findPos (right^.pb, el) ; + IF el + BitsetSize < last + THEN + (* We can check complete bitset, *) + IF lptr^ # rptr^ + THEN + RETURN FALSE + END ; + INC (el, BitsetSize) ; + v := PtrToByte (lptr) ; + INC (v, BitsetSize) ; (* Avoid implications of C address arithmetic in mc PtrToByte *) + lptr := PtrToBitset (v) ; + v := PtrToByte (rptr) ; + INC (v, BitsetSize) ; (* Avoid implications of C address arithmetic in mc PtrToByte *) + rptr := PtrToBitset (v) + ELSE + (* We must check remaining bits only. *) + WHILE (el <= last) AND (el >= left^.init) DO + IF IsElementInSet (left, el) # IsElementInSet (right, el) + THEN + RETURN FALSE + END ; + INC (el) + END ; + RETURN TRUE + END + END ; + RETURN TRUE + END ; + RETURN FALSE +END EqualSet ; + + END Sets. -- 2.43.5