From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1499) id E0E273858C39; Sat, 25 Dec 2021 11:36:01 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E0E273858C39 Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Gaius Mulley To: gcc-cvs@gcc.gnu.org Subject: [gcc/devel/modula-2] Bugfixes for default scope, tidying up of code and neater error messages. X-Act-Checkin: gcc X-Git-Author: Gaius Mulley X-Git-Refname: refs/heads/devel/modula-2 X-Git-Oldrev: c9afa63c3b00e843a703ae959000133a12fc4fcd X-Git-Newrev: 966f05c85e437c04c9138c10a3c957888c21ee48 Message-Id: <20211225113601.E0E273858C39@sourceware.org> Date: Sat, 25 Dec 2021 11:36:01 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 25 Dec 2021 11:36:02 -0000 https://gcc.gnu.org/g:966f05c85e437c04c9138c10a3c957888c21ee48 commit 966f05c85e437c04c9138c10a3c957888c21ee48 Author: Gaius Mulley Date: Sat Dec 25 11:22:00 2021 +0000 Bugfixes for default scope, tidying up of code and neater error messages. gcc/m2/ChangeLog: * m2/Make-lang.in (m2/gm2-compiler-boot/M2Error.o): New rule to build M2Error.o using the --entended-opaque option since M2Error.mod aggressively uses opaque data types. * bnf/m2-1.bnf (DefProcedureHeading) ensure DefaultProcedure scope is created before any further tokens are consumed. Call LeaveErrorScope at the end of the rule. * bnf/m2-2.bnf (DefProcedureHeading): Call LeaveErrorScope at the end of the rule. * bnf/m2-3.bnf (DefProcedureHeading): Call LeaveErrorScope at the end of the rule. * bnf/m2-c.bnf (DefProcedureHeading): Call LeaveErrorScope at the end of the rule. * bnf/m2-h.bnf (DefProcedureHeading): Call DefaultProcedure and the beginning and LeaveErrorScope at the end of the rule. * bnf/m2.bnf (DefProcedureHeading): Call DefaultProcedure and the beginning of the rule. * gm2-compiler/M2Comp.mod (M2Error): Import list replaced identifiers ParsingComplete; and ResetErrorScope;. * gm2-compiler/M2Error.def (NameKey): Renamed ParsingComplete to ResetErrorScope. Call ResetErrorScope before each pass commenses. Import list replaced identifiers LeaveScope, ParsingComplete by EnterErrorScope, ErrorScope, GetCurrentErrorScope, (LeaveErrorScope): New procedure. (ResetErrorScope): New procedure. (LeaveScope) Removed. * gm2-compiler/M2Error.mod (M2Options): Import StackOfAddress. (printf2) Imported. (printf3) Imported. (IsErrorScopeNul): New procedure function. (GetAnnounceScope): Re-implementation. (IsSameScope): New procedure function. (AnnounceScope): Detect no scope. (newErrorScope): Use scopeArray to push a new scope. (DefaultProgramModule): New implementation. (DefaultImplementationModule): New implementation. (DefaultDefinitionModule): New implementation. (DefaultInnerModule): New implementation. (GetCurrentErrorScope): New procedure function. * gm2-compiler/M2MetaError.def: Extend the specifiers to allow error contents to be pushed to a string stack; string stack contents to be popped onto the output string; replace dictionary string by the current output string and remove all contents in the dictionary. * gm2-compiler/M2MetaError.mod (addEntry) New procedure. (killEntry) New procedure function. (lookupDefine) New procedure function. (lookupString) New procedure function. (newEntry) New procedure function. (popOutput) New procedure function. (processDefine) New procedure. (pushOutput) New procedure function. (readWord) New procedure function. (resetDictionary) New procedure. (doErrorScopeMod) Enter error scope before generate an error. (doErrorScopeDef) Enter error scope before generate an error. (op): Handle 'Q', 'X', 'Y', 'Z' format directives. * gm2-compiler/M2Scope.mod (SymbolTable): Import list includes identifier GetErrorScope. (enter): Re-implemented. * gm2-compiler/M2StackWord.mod: Renamed data types so they are easier to debug during bootstrap (avoid name clashes with the M2StackAddress module). * gm2-compiler/P0SymBuild.mod (EndProcedure): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. * gm2-compiler/P2SymBuild.mod (P2EndBuildDefModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (P2EndBuildImplementationModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (P2EndBuildProgramModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (EndBuildInnerModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (P3EndBuildImpModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (P3EndBuildProgModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (EndBuildInnerModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. * gm2-compiler/PCSymBuild.mod (PCEndBuildDefModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (PCEndBuildImpModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (PCEndBuildProgModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. (PCEndBuildInnerModule): Call LeaseErrorScope instead of LeaveScope at the end of the procedure. * gm2-compiler/SymbolKey.def (NoOfNodes): New procedure function. (ForeachNodeConditionDo) New procedure. * gm2-compiler/SymbolKey.mod (NoOfNodes): New procedure function. (ContainsSymKey): Call FindNodeParentInTree instead of FindNodeAndParentInTree. (GetSymKey): Call FindNodeParentInTree instead of FindNodeAndParentInTree. (DelSymKey): Call FindNodeParentInTree instead of FindNodeAndParentInTree. (FindNodeParentInTree): Renamed from FindNodeAndParentInTree. (IsEmptyTree): Reformatted. (DoesTreeContainAny): Reformatted. (SearchForAny): Reformatted. (ForeachNodeConditionDo) New procedure. (SearchConditional) New procedure. * gm2-compiler/SymbolTable.def (GetErrorScope): New procedure function. (PutErrorScope) New procedure. * gm2-compiler/SymbolTable.def (GetErrorScope): New procedure function implemented. (PutErrorScope) New procedure implemented. (AddListify) New procedure. (Listify) New procedure. (errorScope) field added to procedure, module, defimp symbols and initialized during their construction. Signed-off-by: Gaius Mulley Diff: --- gcc/m2/Make-lang.in | 7 + gcc/m2/bnf/m2-1.bnf | 5 +- gcc/m2/bnf/m2-2.bnf | 2 +- gcc/m2/bnf/m2-3.bnf | 1 + gcc/m2/bnf/m2-c.bnf | 1 + gcc/m2/bnf/m2-h.bnf | 4 +- gcc/m2/bnf/m2.bnf | 4 +- gcc/m2/gm2-compiler/M2Comp.mod | 12 +- gcc/m2/gm2-compiler/M2Error.def | 44 +++-- gcc/m2/gm2-compiler/M2Error.mod | 324 +++++++++++++++++++++++------------- gcc/m2/gm2-compiler/M2MetaError.def | 5 + gcc/m2/gm2-compiler/M2MetaError.mod | 278 +++++++++++++++++++++++++++---- gcc/m2/gm2-compiler/M2Scope.mod | 14 +- gcc/m2/gm2-compiler/M2StackWord.mod | 26 +-- gcc/m2/gm2-compiler/P0SymBuild.mod | 4 +- gcc/m2/gm2-compiler/P2SymBuild.mod | 10 +- gcc/m2/gm2-compiler/P3SymBuild.mod | 10 +- gcc/m2/gm2-compiler/PCSymBuild.mod | 10 +- gcc/m2/gm2-compiler/SymbolKey.def | 20 ++- gcc/m2/gm2-compiler/SymbolKey.mod | 111 +++++++++--- gcc/m2/gm2-compiler/SymbolTable.def | 20 +++ gcc/m2/gm2-compiler/SymbolTable.mod | 115 ++++++++++++- 22 files changed, 789 insertions(+), 238 deletions(-) diff --git a/gcc/m2/Make-lang.in b/gcc/m2/Make-lang.in index 04e37419f3c..4b2803eb4ab 100644 --- a/gcc/m2/Make-lang.in +++ b/gcc/m2/Make-lang.in @@ -975,6 +975,13 @@ m2/gm2-compiler-boot/M2GCCDeclare.o: $(srcdir)/m2/gm2-compiler/M2GCCDeclare.mod -I. -Im2/gm2-libs-boot -Im2/gm2-compiler-boot \ -I$(srcdir)/m2/gm2-libiberty $(MCINCLUDES) $(INCLUDES) m2/gm2-compiler-boot/M2GCCDeclare.c -o $@ +m2/gm2-compiler-boot/M2Error.o: $(srcdir)/m2/gm2-compiler/M2Error.mod $(MCDEPS) $(BUILD-BOOT-H) + $(MC) --extended-opaque -o=m2/gm2-compiler-boot/M2Error.c $< + $(COMPILER) -c -fpermissive $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(GM2GCC) \ + -I. -I$(srcdir)/../include -I$(srcdir) \ + -I. -Im2/gm2-libs-boot -Im2/gm2-compiler-boot \ + -I$(srcdir)/m2/gm2-libiberty $(MCINCLUDES) $(INCLUDES) m2/gm2-compiler-boot/M2Error.c -o $@ + m2/gm2-compiler-boot/%.o: $(srcdir)/m2/gm2-compiler/%.mod $(BUILD-BOOT-H) $(MCDEPS) $(MC) -o=m2/gm2-compiler-boot/$*.c $(srcdir)/m2/gm2-compiler/$*.mod $(COMPILER) -c -fpermissive $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(GM2GCC) \ diff --git a/gcc/m2/bnf/m2-1.bnf b/gcc/m2/bnf/m2-1.bnf index c51ce0cd293..4d1237d1acb 100644 --- a/gcc/m2/bnf/m2-1.bnf +++ b/gcc/m2/bnf/m2-1.bnf @@ -907,14 +907,15 @@ Builtin := "__BUILTIN__" % Pus | % PushT(NulTok) % =: -DefProcedureHeading := "PROCEDURE" % PushAutoOn % - Builtin +DefProcedureHeading := "PROCEDURE" % M2Error.DefaultProcedure % + Builtin % PushAutoOn % ( PossiblyExportIdent % StartBuildProcedure % % PushAutoOff % [ DefFormalParameters ] AttributeNoReturn % PopAuto % % BuildProcedureHeading % ) % PopAuto % + % M2Error.LeaveErrorScope % =: AttributeNoReturn := [ "<*" Ident "*>" ] =: diff --git a/gcc/m2/bnf/m2-2.bnf b/gcc/m2/bnf/m2-2.bnf index 4bee2acc559..7bf687e7fea 100644 --- a/gcc/m2/bnf/m2-2.bnf +++ b/gcc/m2/bnf/m2-2.bnf @@ -1006,7 +1006,7 @@ DefProcedureHeading := "PROCEDURE" % M2E [ DefFormalParameters ] AttributeNoReturn % EndBuildFormalParameters % % BuildProcedureHeading % - ) + ) % M2Error.LeaveErrorScope % =: AttributeNoReturn := [ "<*" % PushAutoOff % diff --git a/gcc/m2/bnf/m2-3.bnf b/gcc/m2/bnf/m2-3.bnf index d91c6cf912f..836528f86d2 100644 --- a/gcc/m2/bnf/m2-3.bnf +++ b/gcc/m2/bnf/m2-3.bnf @@ -1293,6 +1293,7 @@ DefProcedureHeading := "PROCEDURE" % M2E % BuildProcedureHeading ; PopAuto % ) % PopAuto % + % M2Error.LeaveErrorScope % =: AttributeNoReturn := [ "<*" Ident "*>" ] =: diff --git a/gcc/m2/bnf/m2-c.bnf b/gcc/m2/bnf/m2-c.bnf index e5ddc516064..5f9ea360d05 100644 --- a/gcc/m2/bnf/m2-c.bnf +++ b/gcc/m2/bnf/m2-c.bnf @@ -1104,6 +1104,7 @@ DefProcedureHeading := "PROCEDURE" % M2E % PCBuildProcedureHeading ; PopAuto % ) % PopAuto % + % M2Error.LeaveErrorScope % =: AttributeNoReturn := [ "<*" Ident "*>" ] =: diff --git a/gcc/m2/bnf/m2-h.bnf b/gcc/m2/bnf/m2-h.bnf index c6d0d26a9b1..b9297b20da9 100644 --- a/gcc/m2/bnf/m2-h.bnf +++ b/gcc/m2/bnf/m2-h.bnf @@ -1120,11 +1120,11 @@ ProcedureHeading := "PROCEDURE" % M2E Builtin := [ "__BUILTIN__" | "__INLINE__" ] =: -DefProcedureHeading := "PROCEDURE" +DefProcedureHeading := "PROCEDURE" % M2Error.DefaultProcedure % Builtin ( Ident [ DefFormalParameters ] AttributeNoReturn - ) + ) % M2Error.LeaveErrorScope % =: AttributeNoReturn := [ "<*" Ident "*>" ] =: diff --git a/gcc/m2/bnf/m2.bnf b/gcc/m2/bnf/m2.bnf index 515d9997641..67834ee19a3 100644 --- a/gcc/m2/bnf/m2.bnf +++ b/gcc/m2/bnf/m2.bnf @@ -807,8 +807,10 @@ AttributeNoReturn := [ "<*" Ident "*>" ] =: Builtin := [ "__BUILTIN__" % PutModuleContainsBuiltin % | "__INLINE__" ] =: -DefProcedureHeading := "PROCEDURE" Builtin +DefProcedureHeading := "PROCEDURE" % M2Error.DefaultProcedure % + Builtin ( Ident [ DefFormalParameters ] AttributeNoReturn ) + % M2Error.LeaveErrorScope % =: -- introduced procedure block so we can produce more informative diff --git a/gcc/m2/gm2-compiler/M2Comp.mod b/gcc/m2/gm2-compiler/M2Comp.mod index 700f96eb9b5..a5b3dc52dde 100644 --- a/gcc/m2/gm2-compiler/M2Comp.mod +++ b/gcc/m2/gm2-compiler/M2Comp.mod @@ -36,7 +36,7 @@ FROM M2Preprocess IMPORT PreprocessModule ; FROM libc IMPORT exit ; FROM M2Error IMPORT ErrorStringAt, ErrorStringAt2, ErrorStringsAt2, - WriteFormat0, FlushErrors, FlushWarnings, ParsingComplete ; + WriteFormat0, FlushErrors, FlushWarnings, ResetErrorScope ; FROM M2MetaError IMPORT MetaErrorString1, MetaError0, MetaError1 ; FROM FormatStrings IMPORT Sprintf1 ; @@ -126,22 +126,22 @@ PROCEDURE Compile (s: String) ; BEGIN DoPass0(s) ; FlushWarnings ; FlushErrors ; - ResetForNewPass ; + ResetForNewPass ; ResetErrorScope ; qprintf0('Pass 1: scopes, enumerated types, imports and exports\n') ; DoPass1 ; FlushWarnings ; FlushErrors ; qprintf0('Pass 2: constants and types\n') ; - ResetForNewPass ; + ResetForNewPass ; ResetErrorScope ; DoPass2 ; FlushWarnings ; FlushErrors ; qprintf0('Pass C: aggregate constants\n') ; - ResetForNewPass ; + ResetForNewPass ; ResetErrorScope ; DoPassC ; FlushWarnings ; FlushErrors ; qprintf0('Pass 3: quadruple generation\n') ; - ResetForNewPass ; + ResetForNewPass ; ResetErrorScope ; DoPass3 ; - FlushWarnings ; FlushErrors ; ParsingComplete ; + FlushWarnings ; FlushErrors ; qprintf0('Pass 4: gcc tree generation\n') ; Code ; FlushWarnings ; FlushErrors diff --git a/gcc/m2/gm2-compiler/M2Error.def b/gcc/m2/gm2-compiler/M2Error.def index 842eccd18ba..d9d312c5b99 100644 --- a/gcc/m2/gm2-compiler/M2Error.def +++ b/gcc/m2/gm2-compiler/M2Error.def @@ -32,7 +32,8 @@ DEFINITION MODULE M2Error ; FROM SYSTEM IMPORT BYTE ; FROM DynamicStrings IMPORT String ; FROM NameKey IMPORT Name ; -EXPORT QUALIFIED Error, + +EXPORT QUALIFIED Error, ErrorScope, InternalError, WriteFormat0, WriteFormat1, WriteFormat2, WriteFormat3, NewError, ErrorFormat0, ErrorFormat1, ErrorFormat2, ErrorFormat3, @@ -45,13 +46,16 @@ EXPORT QUALIFIED Error, WarnFormat0, WarnFormat1, MoveError, AnnounceScope, EnterImplementationScope, EnterModuleScope, EnterDefinitionScope, EnterProgramScope, - EnterProcedureScope, LeaveScope, DepthScope, GetAnnounceScope, + EnterProcedureScope, DepthScope, GetAnnounceScope, DefaultProgramModule, DefaultImplementationModule, DefaultDefinitionModule, DefaultInnerModule, DefaultProcedure, - ParsingComplete ; + EnterErrorScope, GetCurrentErrorScope, ResetErrorScope, + LeaveErrorScope ; + TYPE Error ; + ErrorScope ; (* @@ -273,13 +277,6 @@ PROCEDURE EnterDefinitionScope (scopename: Name) ; PROCEDURE EnterProcedureScope (scopename: Name) ; -(* - LeaveScope - leave the current scope and pop into the previous one. -*) - -PROCEDURE LeaveScope ; - - (* DepthScope - returns the depth of the scope stack. *) @@ -336,11 +333,32 @@ PROCEDURE DefaultProcedure ; (* - ParsingComplete - after this is called the Enter scope procedure - will not assert the default scope was set. + EnterErrorScope - pushes the currentScope and sets currentScope to scope. +*) + +PROCEDURE EnterErrorScope (scope: ErrorScope) ; + + +(* + LeaveErrorScope - leave the current scope and pop into the previous one. +*) + +PROCEDURE LeaveErrorScope ; + + +(* + GetCurrentErrorScope - returns currentScope. +*) + +PROCEDURE GetCurrentErrorScope () : ErrorScope ; + + +(* + ResetErrorScope - should be called at the start of each pass to + reset the error scope index. *) -PROCEDURE ParsingComplete ; +PROCEDURE ResetErrorScope ; END M2Error. diff --git a/gcc/m2/gm2-compiler/M2Error.mod b/gcc/m2/gm2-compiler/M2Error.mod index 4eb4580d790..420ccf7a4de 100644 --- a/gcc/m2/gm2-compiler/M2Error.mod +++ b/gcc/m2/gm2-compiler/M2Error.mod @@ -28,14 +28,17 @@ FROM StrLib IMPORT StrLen, StrEqual ; FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ; FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToColumnNo, GetTokenNo ; FROM Storage IMPORT ALLOCATE, DEALLOCATE ; -FROM M2Printf IMPORT printf0, printf1, printf2 ; +FROM M2Printf IMPORT printf0, printf1, printf2, printf3 ; FROM M2Options IMPORT Xcode ; FROM M2RTS IMPORT ExitOnHalt ; FROM SYSTEM IMPORT ADDRESS ; FROM M2Emit IMPORT EmitError ; FROM M2LexBuf IMPORT UnknownTokenNo ; -FROM M2StackWord IMPORT StackOfWord, InitStackWord, InitStackWord, PushWord, PopWord, NoOfItemsInStackWord ; +FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, PushAddress, PopAddress, NoOfItemsInStackAddress ; +FROM Indexing IMPORT Index, HighIndice, InitIndex, GetIndice, PutIndice ; FROM M2Debug IMPORT Assert ; +FROM M2Pass IMPORT IsPass0, IsPass1 ; +FROM SymbolTable IMPORT NulSym ; FROM M2ColorString IMPORT filenameColor, endColor, errorColor, warningColor, noteColor, range1Color, range2Color, quoteOpen, quoteClose ; @@ -46,6 +49,7 @@ IMPORT M2Emit ; CONST Debugging = TRUE ; DebugTrace = FALSE ; + DebugError = FALSE ; TYPE Error = POINTER TO RECORD @@ -58,20 +62,26 @@ TYPE (* index of token causing the error *) token : CARDINAL ; color : BOOLEAN ; + scope : ErrorScope ; + END ; + + KindScope = (noscope, definition, implementation, program, module, procedure) ; + + ErrorScope = POINTER TO RECORD scopeKind: KindScope ; scopeName: Name ; + symbol : CARDINAL ; (* symbol table entry. *) END ; - KindScope = (noscope, definition, implementation, program, module, procedure) ; VAR head : Error ; InInternal : BOOLEAN ; - scopeName : Name ; - lastKind, - scopeKind : KindScope ; - scopeStack : StackOfWord ; - parsing : BOOLEAN ; + lastScope : ErrorScope ; + scopeIndex : CARDINAL ; + scopeArray : Index ; + currentScope: ErrorScope ; + scopeStack : StackOfAddress ; (* @@ -405,8 +415,7 @@ BEGIN color := FALSE ; END ; (* Assert (scopeKind # noscope) ; *) - e^.scopeKind := scopeKind ; - e^.scopeName := scopeName ; + e^.scope := currentScope ; IF (head=NIL) OR (head^.token>AtTokenNo) THEN e^.next := head ; @@ -435,7 +444,7 @@ BEGIN e := NewError(AtTokenNo) ; e^.fatal := FALSE ; e^.note := FALSE ; - RETURN( e ) + RETURN e END NewWarning ; @@ -451,7 +460,7 @@ BEGIN e := NewError(AtTokenNo) ; e^.fatal := FALSE ; e^.note := TRUE ; - RETURN( e ) + RETURN e END NewNote ; @@ -477,8 +486,7 @@ BEGIN parent := e ; child := NIL ; fatal := e^.fatal ; - scopeKind := e^.scopeKind ; - scopeName := e^.scopeName + scope := e^.scope END ; e^.child := f END ; @@ -568,11 +576,10 @@ PROCEDURE Init ; BEGIN head := NIL ; InInternal := FALSE ; - scopeStack := InitStackWord () ; - scopeName := NulName ; - scopeKind := noscope ; - lastKind := noscope ; - parsing := TRUE + scopeStack := InitStackAddress () ; + scopeArray := InitIndex (1) ; + currentScope := NIL ; + scopeIndex := 0 END Init ; @@ -812,6 +819,16 @@ BEGIN END ErrorAbort0 ; +(* + IsErrorScopeNul - returns TRUE if es is NIL or it has a NulName. +*) + +PROCEDURE IsErrorScopeNul (es: ErrorScope) : BOOLEAN ; +BEGIN + RETURN (es = NIL) OR (es^.scopeName = NulName) +END IsErrorScopeNul ; + + (* GetAnnounceScope - return message with the error scope attached to message. filename and message are treated as read only by this @@ -832,30 +849,59 @@ BEGIN pre := Sprintf1 (Mark (InitString ("%s: ")), filename) END ; - quoted := InitString ('') ; - IF scopeName # NulName + IF NOT IsErrorScopeNul (currentScope) THEN + quoted := InitString ('') ; quoted := quoteOpen (quoted) ; - quoted := ConCat (quoted, Mark (InitStringCharStar (KeyToCharStar (scopeName)))) ; + quoted := ConCat (quoted, Mark (InitStringCharStar (KeyToCharStar (currentScope^.scopeName)))) ; quoted := quoteClose (quoted) END ; - CASE scopeKind OF - definition : desc := InitString ("In definition module") | - implementation: desc := InitString ("In implementation module") | - program : desc := InitString ("In program module") | - module : desc := InitString ("In inner module") | - procedure : desc := InitString ("In procedure") + IF currentScope = NIL + THEN + desc := InitString ('') + ELSE + CASE currentScope^.scopeKind OF + + definition : desc := InitString ("In definition module") | + implementation: desc := InitString ("In implementation module") | + program : desc := InitString ("In program module") | + module : desc := InitString ("In inner module") | + procedure : desc := InitString ("In procedure") + END + END ; + fmt := ConCat (pre, Mark (desc)) ; + IF IsErrorScopeNul (currentScope) + THEN + fmt := ConCat (fmt, Sprintf0 (Mark (InitString (": ")))) + ELSE + fmt := ConCat (fmt, Sprintf1 (Mark (InitString (" %s: ")), quoted)) END ; - fmt := ConCat (pre, desc) ; - fmt := ConCat (fmt, Sprintf1 (Mark (InitString (" %s:\n")), quoted)) ; RETURN ConCat (fmt, message) END GetAnnounceScope ; (* + IsSameScope - return TRUE if a and b refer to the same scope. +*) + +PROCEDURE IsSameScope (a, b: ErrorScope) : BOOLEAN ; +BEGIN + IF a = b + THEN + RETURN TRUE + ELSIF (a = NIL) OR (b = NIL) + THEN + RETURN FALSE + ELSE + (* this does not compare the symbol field. *) + RETURN (a^.scopeKind = b^.scopeKind) AND (a^.scopeName = b^.scopeName) + END +END IsSameScope ; + +(* AnnounceScope - return the error string s with a scope description prepended assuming that scope has changed. *) @@ -864,18 +910,16 @@ PROCEDURE AnnounceScope (e: Error; message: String) : String ; VAR filename: String ; BEGIN - IF (scopeKind#e^.scopeKind) OR (scopeName#e^.scopeName) OR (lastKind#e^.scopeKind) + IF NOT IsSameScope (lastScope, e^.scope) THEN - lastKind := e^.scopeKind ; - scopeKind := e^.scopeKind ; - scopeName := e^.scopeName ; - IF e^.scopeKind = noscope + lastScope := e^.scope ; + IF IsErrorScopeNul (lastScope) THEN - RETURN InitString ("no scope active") + RETURN ConCat (InitString ("no scope active"), message) ELSE - Assert (e^.scopeKind # noscope) ; - filename := FindFileNameFromToken (e^.token, 0) ; - message := GetAnnounceScope (filename, message) + Assert ((e^.scope # NIL) AND (e^.scope^.scopeKind # noscope)) ; + (* filename := FindFileNameFromToken (e^.token, 0) ; *) + message := GetAnnounceScope (NIL, message) END END ; RETURN message @@ -883,18 +927,53 @@ END AnnounceScope ; (* - DefaultProgramModule - sets up an unnamed program scope before the Ident is seen. + newErrorScope - create an ErrorScope of kindScope and return the object. + It is also added the a dynamic array. *) -PROCEDURE DefaultProgramModule ; +PROCEDURE newErrorScope (kind: KindScope) : ErrorScope ; +VAR + es: ErrorScope ; + c : CARDINAL ; BEGIN - IF parsing + IF IsPass0 () + THEN + NEW (es) ; + es^.scopeKind := kind ; + es^.scopeName := NulName ; + es^.symbol := NulSym ; + PutIndice (scopeArray, HighIndice (scopeArray) + 1, es) ; + IF DebugError + THEN + c := HighIndice (scopeArray) ; + printf2 ("pass 0: %d %d\n", c, kind) + END + ELSE + INC (scopeIndex) ; + es := GetIndice (scopeArray, scopeIndex) ; + IF DebugError THEN - scopeKind := program ; - scopeName := NulName ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) + IF IsPass1 () + THEN + printf3 ("pass 1: %d %d %d\n", scopeIndex, es^.scopeKind, kind) + ELSE + printf3 ("pass 2: %d %d %d\n", scopeIndex, es^.scopeKind, kind) END + END ; + Assert (es^.scopeKind = kind) + END ; + RETURN es +END newErrorScope ; + + +(* + DefaultProgramModule - sets up an unnamed program scope before the Ident is seen. +*) + +PROCEDURE DefaultProgramModule ; +BEGIN + PushAddress (scopeStack, currentScope) ; + currentScope := newErrorScope (program) END DefaultProgramModule ; @@ -905,13 +984,8 @@ END DefaultProgramModule ; PROCEDURE DefaultImplementationModule ; BEGIN - IF parsing - THEN - scopeKind := implementation ; - scopeName := NulName ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) - END + PushAddress (scopeStack, currentScope) ; + currentScope := newErrorScope (implementation) END DefaultImplementationModule ; @@ -922,13 +996,8 @@ END DefaultImplementationModule ; PROCEDURE DefaultDefinitionModule ; BEGIN - IF parsing - THEN - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) ; - scopeKind := definition ; - scopeName := NulName - END + PushAddress (scopeStack, currentScope) ; + currentScope := newErrorScope (definition) END DefaultDefinitionModule ; @@ -939,13 +1008,8 @@ END DefaultDefinitionModule ; PROCEDURE DefaultInnerModule ; BEGIN - IF parsing - THEN - scopeKind := module ; - scopeName := NulName ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) - END + PushAddress (scopeStack, currentScope) ; + currentScope := newErrorScope (module) END DefaultInnerModule ; @@ -956,13 +1020,8 @@ END DefaultInnerModule ; PROCEDURE DefaultProcedure ; BEGIN - IF parsing - THEN - scopeKind := procedure ; - scopeName := NulName ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) - END ; + PushAddress (scopeStack, currentScope) ; + currentScope := newErrorScope (procedure) END DefaultProcedure ; @@ -973,15 +1032,16 @@ END DefaultProcedure ; PROCEDURE EnterImplementationScope (scopename: Name) ; BEGIN - IF parsing + Assert (currentScope # NIL) ; + Assert (currentScope^.scopeKind = implementation) ; + IF currentScope^.scopeName = NulName + THEN + IF DebugError THEN - Assert (scopeKind = implementation) ; - LeaveScope (* shutdown the default implementation scope. *) + printf1 ("seen implementation: %a\n", scopename) END ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) ; - scopeKind := implementation ; - scopeName := scopename + currentScope^.scopeName := scopename + END END EnterImplementationScope ; @@ -992,15 +1052,16 @@ END EnterImplementationScope ; PROCEDURE EnterProgramScope (scopename: Name) ; BEGIN - IF parsing + Assert (currentScope # NIL) ; + Assert (currentScope^.scopeKind = program) ; + IF currentScope^.scopeName = NulName + THEN + IF DebugError THEN - Assert (scopeKind = program) ; - LeaveScope (* shutdown the default program scope. *) + printf1 ("seen program: %a\n", scopename) END ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) ; - scopeKind := program ; - scopeName := scopename + currentScope^.scopeName := scopename + END END EnterProgramScope ; @@ -1011,15 +1072,16 @@ END EnterProgramScope ; PROCEDURE EnterModuleScope (scopename: Name) ; BEGIN - IF parsing + Assert (currentScope # NIL) ; + Assert (currentScope^.scopeKind = module) ; + IF currentScope^.scopeName = NulName THEN - Assert (scopeKind = module) ; - LeaveScope (* shutdown the default inner module scope. *) + IF DebugError + THEN + printf1 ("seen module: %a\n", scopename) END ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) ; - scopeKind := module ; - scopeName := scopename + currentScope^.scopeName := scopename + END END EnterModuleScope ; @@ -1030,15 +1092,16 @@ END EnterModuleScope ; PROCEDURE EnterDefinitionScope (scopename: Name) ; BEGIN - IF parsing + Assert (currentScope # NIL) ; + Assert (currentScope^.scopeKind = definition) ; + IF currentScope^.scopeName = NulName THEN - Assert (scopeKind = definition) + IF DebugError + THEN + printf1 ("seen definition: %a\n", scopename) END ; - LeaveScope ; (* shutdown the default definition module scope. *) - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) ; - scopeKind := definition ; - scopeName := scopename + currentScope^.scopeName := scopename + END END EnterDefinitionScope ; @@ -1049,27 +1112,48 @@ END EnterDefinitionScope ; PROCEDURE EnterProcedureScope (scopename: Name) ; BEGIN - IF parsing + Assert (currentScope # NIL) ; + Assert (currentScope^.scopeKind = procedure) ; + IF currentScope^.scopeName = NulName THEN - Assert (scopeKind = procedure) ; - LeaveScope (* shutdown the default procedure scope. *) + IF DebugError + THEN + printf1 ("seen procedure: %a\n", scopename) END ; - PushWord (scopeStack, scopeKind) ; - PushWord (scopeStack, scopeName) ; - scopeKind := procedure ; - scopeName := scopename + currentScope^.scopeName := scopename + END END EnterProcedureScope ; (* - LeaveScope - leave the current scope and pop into the previous one. + LeaveErrorScope - leave the current scope and pop into the previous one. +*) + +PROCEDURE LeaveErrorScope ; +BEGIN + currentScope := PopAddress (scopeStack) +END LeaveErrorScope ; + + +(* + EnterErrorScope - pushes the currentScope and sets currentScope to scope. +*) + +PROCEDURE EnterErrorScope (scope: ErrorScope) ; +BEGIN + PushAddress (scopeStack, currentScope) ; + currentScope := scope +END EnterErrorScope ; + + +(* + GetCurrentErrorScope - returns currentScope. *) -PROCEDURE LeaveScope ; +PROCEDURE GetCurrentErrorScope () : ErrorScope ; BEGIN - scopeName := PopWord (scopeStack) ; - scopeKind := PopWord (scopeStack) -END LeaveScope ; + RETURN currentScope +END GetCurrentErrorScope ; (* @@ -1078,19 +1162,19 @@ END LeaveScope ; PROCEDURE DepthScope () : CARDINAL ; BEGIN - RETURN NoOfItemsInStackWord (scopeStack) + RETURN NoOfItemsInStackAddress (scopeStack) END DepthScope ; (* - ParsingComplete - after this is called the Enter scope procedure - will not assert the default scope was set. + ResetErrorScope - should be called at the start of each pass to + reset the error scope index. *) -PROCEDURE ParsingComplete ; +PROCEDURE ResetErrorScope ; BEGIN - parsing := FALSE -END ParsingComplete ; + scopeIndex := 0 +END ResetErrorScope ; BEGIN diff --git a/gcc/m2/gm2-compiler/M2MetaError.def b/gcc/m2/gm2-compiler/M2MetaError.def index b266f9cae42..a041fcae67c 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.def +++ b/gcc/m2/gm2-compiler/M2MetaError.def @@ -85,6 +85,11 @@ EXPORT QUALIFIED MetaError0, MetaError1, MetaError2, MetaError3, MetaError4, {%R} this error will be the root of the future chained errors. {%n} decimal number. Not quoted. {%N} count (number), for example, 1st, 2nd, 3rd, 4th. Not quoted. + {%X} push contents of the output string onto the string stack. + {%Yname} place contents of dictionary entry name onto the output string. + {%Zname} replace dictionary entry name for the output string. + Pop contents of the string stack onto the output string. + {%Q} remove all entries in the dictionary. {%P} push the current color state. {%p} pop the current color state. {%Ffilename} the string filename will be rendered using the filename color. diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod index 6bb5f6aa832..e96313a07be 100644 --- a/gcc/m2/gm2-compiler/M2MetaError.mod +++ b/gcc/m2/gm2-compiler/M2MetaError.mod @@ -38,9 +38,12 @@ FROM SYSTEM IMPORT ADDRESS ; FROM M2Error IMPORT MoveError ; FROM M2Debug IMPORT Assert ; +FROM Indexing IMPORT Index, InitIndex, KillIndex, GetIndice, PutIndice, + DeleteIndice, HighIndice ; + FROM DynamicStrings IMPORT String, InitString, InitStringCharStar, ConCat, ConCatChar, Mark, string, KillString, - Dup, char, Length, Mult, EqualArray ; + Dup, char, Length, Mult, EqualArray, Equal ; FROM SymbolTable IMPORT NulSym, IsDefImp, IsModule, IsInnerModule, @@ -55,7 +58,7 @@ FROM SymbolTable IMPORT NulSym, IsError, GetSymName, GetScope, IsExported, GetType, SkipType, GetDeclaredDef, GetDeclaredMod, GetDeclaredModule, GetDeclaredDefinition, GetScope, - GetFirstUsed, IsNameAnonymous ; + GetFirstUsed, IsNameAnonymous, GetErrorScope ; IMPORT M2ColorString ; IMPORT M2Error ; @@ -92,10 +95,232 @@ TYPE stackPtr : CARDINAL ; END ; + + dictionaryEntry = POINTER TO RECORD + key, + value: String ; + next : dictionaryEntry ; + END ; + + VAR lastRoot : Error ; lastColor : colorType ; seenAbort : BOOLEAN ; + dictionary : Index ; + outputStack: Index ; + freeEntry : dictionaryEntry ; + + +(* + pushOutput - +*) + +PROCEDURE pushOutput (VAR eb: errorBlock) ; +BEGIN + PutIndice (outputStack, HighIndice (outputStack)+1, eb.out) ; + eb.out := InitString ('') ; + eb.glyph := FALSE +END pushOutput ; + + +(* + readWord - reads and returns a word delimited by '}' it uses '%' as + the escape character. +*) + +PROCEDURE readWord (VAR eb: errorBlock) : String ; +VAR + word: String ; +BEGIN + word := InitString ('') ; + WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO + IF char (eb.in, eb.ini) = "%" + THEN + INC (eb.ini) + END ; + word := ConCatChar (word, char (eb.in, eb.ini)) ; + INC (eb.ini) + END ; + RETURN word +END readWord ; + + +(* + addEntry - +*) + +PROCEDURE addEntry (key, value: String) ; +VAR + e: dictionaryEntry ; + s: String ; + i: CARDINAL ; +BEGIN + s := lookupString (key) ; + IF s = NIL + THEN + e := newEntry () ; + e^.key := key ; + e^.value := value ; + PutIndice (dictionary, HighIndice (dictionary)+1, e) + ELSE + i := 1 ; + WHILE i <= HighIndice (dictionary) DO + e := GetIndice (dictionary, i) ; + IF Equal (e^.key, key) + THEN + e^.value := KillString (e^.value) ; + e^.value := value ; + RETURN + END ; + INC (i) + END + END +END addEntry ; + + +(* + popOutput - +*) + +PROCEDURE popOutput (VAR eb: errorBlock) ; +VAR + key, + previous: String ; +BEGIN + IF HighIndice (outputStack) >= 1 + THEN + previous := GetIndice (outputStack, HighIndice (outputStack)) ; + DeleteIndice (outputStack, HighIndice (outputStack)) ; + key := readWord (eb) ; + addEntry (key, eb.out) ; + eb.out := previous + END +END popOutput ; + + +(* + newEntry - +*) + +PROCEDURE newEntry () : dictionaryEntry ; +VAR + e: dictionaryEntry ; +BEGIN + IF freeEntry = NIL + THEN + NEW (e) + ELSE + e := freeEntry ; + freeEntry := freeEntry^.next + END ; + WITH e^ DO + key := NIL ; + value := NIL ; + next := NIL + END ; + RETURN e +END newEntry ; + + +(* + killEntry - dispose e and delete any strings. +*) + +PROCEDURE killEntry (e: dictionaryEntry) ; +BEGIN + e^.next := freeEntry ; + freeEntry := e ; + IF e^.key # NIL + THEN + e^.key := KillString (e^.key) + END ; + IF e^.value # NIL + THEN + e^.value := KillString (e^.value) + END +END killEntry ; + + +(* + resetDictionary - remove all entries in the dictionary. +*) + +PROCEDURE resetDictionary ; +VAR + i: CARDINAL ; + e: dictionaryEntry ; +BEGIN + i := 1 ; + WHILE i <= HighIndice (dictionary) DO + e := GetIndice (dictionary, i) ; + killEntry (e) ; + INC (i) + END ; + dictionary := KillIndex (dictionary) ; + dictionary := InitIndex (1) +END resetDictionary ; + + +(* + lookupString - lookup and return a duplicate of the string value for key s. + NIL is returned if the key s is unknown. +*) + +PROCEDURE lookupString (s: String) : String ; +VAR + i: CARDINAL ; + e: dictionaryEntry ; +BEGIN + i := 1 ; + WHILE i <= HighIndice (dictionary) DO + e := GetIndice (dictionary, i) ; + IF Equal (e^.key, s) + THEN + RETURN Dup (e^.value) + END ; + INC (i) + END ; + RETURN NIL +END lookupString ; + + +(* + lookupDefine - looks up the word in the input string (ending with '}'). + It uses this word as a key into the dictionary and returns + the entry. +*) + +PROCEDURE lookupDefine (VAR eb: errorBlock) : String ; +VAR + s: String ; +BEGIN + s := InitString ('') ; + WHILE (eb.ini < eb.len) AND (char (eb.in, eb.ini) # "}") DO + IF char (eb.in, eb.ini) = "%" + THEN + INC (eb.ini) + END ; + s := ConCatChar (s, char (eb.in, eb.ini)) ; + INC (eb.ini) + END ; + s := lookupString (s) ; + IF s = NIL + THEN + s := InitString ('') + END ; + RETURN s +END lookupDefine ; + + +(* + processDefine - place contents of dictionary entry name onto the output string. +*) + +PROCEDURE processDefine (VAR eb: errorBlock) ; +BEGIN + eb.out := ConCat (eb.out, lookupDefine (eb)) +END processDefine ; (* @@ -972,24 +1197,20 @@ BEGIN scope := GetScope (sym) ; IF scope = NulSym THEN + M2Error.EnterErrorScope (NIL) ; doError (eb, GetDeclaredMod (sym)) ELSE + M2Error.EnterErrorScope (GetErrorScope (scope)) ; IF IsProcedure (scope) THEN - M2Error.DefaultProcedure ; - M2Error.EnterProcedureScope (GetSymName (scope)) ; - doError (eb, GetDeclaredMod (sym)) ; + doError (eb, GetDeclaredMod (sym)) ELSE IF IsModule (scope) THEN IF IsInnerModule (scope) THEN - M2Error.DefaultInnerModule ; - M2Error.EnterModuleScope (GetSymName (scope)) ; doError (eb, GetDeclaredMod (sym)) ELSE - M2Error.DefaultProgramModule ; - M2Error.EnterProgramScope (GetSymName (scope)) ; doError (eb, GetDeclaredMod (sym)) END ELSE @@ -1000,18 +1221,14 @@ BEGIN UNTIL GetScope(OuterModule)=NulSym ; *) IF GetDeclaredModule (sym) = UnknownTokenNo THEN - M2Error.DefaultDefinitionModule ; - M2Error.EnterDefinitionScope (GetSymName (scope)) ; doError (eb, GetDeclaredDef (sym)) ELSE - M2Error.DefaultImplementationModule ; - M2Error.EnterImplementationScope (GetSymName (scope)) ; doError (eb, GetDeclaredMod (sym)) END END - END ; - M2Error.LeaveScope - END + END + END ; + M2Error.LeaveErrorScope END doErrorScopeMod ; @@ -1028,24 +1245,20 @@ BEGIN scope := GetScope (sym) ; IF scope = NulSym THEN + M2Error.EnterErrorScope (NIL) ; doError (eb, GetDeclaredDef (sym)) ELSE + M2Error.EnterErrorScope (GetErrorScope (scope)) ; IF IsProcedure (scope) THEN - M2Error.DefaultProcedure ; - M2Error.EnterProcedureScope (GetSymName (scope)) ; - doError (eb, GetDeclaredDef (sym)) ; + doError (eb, GetDeclaredDef (sym)) ELSE IF IsModule (scope) THEN IF IsInnerModule (scope) THEN - M2Error.DefaultInnerModule ; - M2Error.EnterModuleScope (GetSymName (scope)) ; doError (eb, GetDeclaredDef (sym)) ELSE - M2Error.DefaultProgramModule ; - M2Error.EnterProgramScope (GetSymName (scope)) ; doError (eb, GetDeclaredDef (sym)) END ELSE @@ -1056,18 +1269,14 @@ BEGIN UNTIL GetScope(OuterModule)=NulSym ; *) IF GetDeclaredDefinition (sym) = UnknownTokenNo THEN - M2Error.DefaultImplementationModule ; - M2Error.EnterImplementationScope (GetSymName (scope)) ; doError (eb, GetDeclaredMod (sym)) ELSE - M2Error.DefaultDefinitionModule ; - M2Error.EnterDefinitionScope (GetSymName (scope)) ; doError (eb, GetDeclaredDef (sym)) END END - END ; - M2Error.LeaveScope END + END ; + M2Error.LeaveErrorScope END doErrorScopeDef ; @@ -1305,6 +1514,10 @@ BEGIN DEC (eb.ini) | 'k': unquotedKeyword (eb) ; DEC (eb.ini) | + 'Q': resetDictionary | + 'X': pushOutput (eb) | + 'Y': processDefine (eb) | + 'Z': popOutput (eb) | 'F': filename (eb) ; DEC (eb.ini) | 'u': eb.quotes := FALSE | @@ -1312,7 +1525,7 @@ BEGIN DEC (eb.ini) ELSE - InternalFormat (eb, 'expecting one of [akqtdnpsuCDEKNPOUW:<>%]', __LINE__) + InternalFormat (eb, 'expecting one of [akqtdnpsuCDEFKNOPQRSTUWXYZ:<>%]', __LINE__) END ; INC (eb.ini) END ; @@ -2236,5 +2449,8 @@ END MetaString4 ; BEGIN lastRoot := NIL ; lastColor := noColor ; - seenAbort := FALSE + seenAbort := FALSE ; + outputStack := InitIndex (1) ; + dictionary := InitIndex (1) ; + freeEntry := NIL END M2MetaError. diff --git a/gcc/m2/gm2-compiler/M2Scope.mod b/gcc/m2/gm2-compiler/M2Scope.mod index 61d03fa49cc..29955aac4e9 100644 --- a/gcc/m2/gm2-compiler/M2Scope.mod +++ b/gcc/m2/gm2-compiler/M2Scope.mod @@ -27,7 +27,7 @@ FROM NameKey IMPORT Name ; FROM SymbolTable IMPORT IsProcedure, IsDefImp, GetProcedureQuads, GetScope, GetProcedureScope, IsModule, IsModuleWithinProcedure, - GetSymName, NulSym ; + GetSymName, GetErrorScope, NulSym ; FROM M2Options IMPORT DisplayQuadruples ; FROM M2Printf IMPORT printf0, printf1 ; @@ -433,11 +433,11 @@ BEGIN unsetscope, ignorescope : | - procedurescope : M2Error.EnterProcedureScope (GetSymName (scopeSym)) | - modulescope : M2Error.EnterModuleScope (GetSymName (scopeSym)) | - definitionscope : M2Error.EnterDefinitionScope (GetSymName (scopeSym)) | - implementationscope: M2Error.EnterImplementationScope (GetSymName (scopeSym)) | - programscope : M2Error.EnterProgramScope (GetSymName (scopeSym)) + procedurescope , + modulescope , + definitionscope , + implementationscope, + programscope : M2Error.EnterErrorScope (GetErrorScope (scopeSym)) END END @@ -456,7 +456,7 @@ BEGIN ignorescope : | ELSE - M2Error.LeaveScope + M2Error.LeaveErrorScope END END leave ; diff --git a/gcc/m2/gm2-compiler/M2StackWord.mod b/gcc/m2/gm2-compiler/M2StackWord.mod index 0507380165f..9a133ff8ed4 100644 --- a/gcc/m2/gm2-compiler/M2StackWord.mod +++ b/gcc/m2/gm2-compiler/M2StackWord.mod @@ -29,16 +29,16 @@ CONST MaxBucket = 10 ; TYPE - StackBucket = POINTER TO Bucket ; - Bucket = RECORD + StackBucketWord = POINTER TO BucketWord ; + BucketWord = RECORD bucket: ARRAY [0..MaxBucket-1] OF WORD ; items : CARDINAL ; - last : StackBucket ; + last : StackBucketWord ; END ; StackOfWord = POINTER TO StackDescriptor ; StackDescriptor = RECORD - tail: StackBucket ; + tail: StackBucketWord ; END ; @@ -59,10 +59,10 @@ END InitStackWord ; (* - KillBucket - destroys a StackBucket and returns, NIL. + KillBucket - destroys a StackBucketWord and returns, NIL. *) -PROCEDURE KillBucket (b: StackBucket) : StackBucket ; +PROCEDURE KillBucket (b: StackBucketWord) : StackBucketWord ; BEGIN IF b#NIL THEN @@ -89,12 +89,12 @@ END KillStackWord ; (* - InitBucket - returns an empty StackBucket. + InitBucket - returns an empty StackBucketWord. *) -PROCEDURE InitBucket (l: StackBucket) : StackBucket ; +PROCEDURE InitBucket (l: StackBucketWord) : StackBucketWord ; VAR - b: StackBucket ; + b: StackBucketWord ; BEGIN NEW(b) ; WITH b^ DO @@ -138,7 +138,7 @@ END PushWord ; PROCEDURE PopWord (s: StackOfWord) : WORD ; VAR - b: StackBucket ; + b: StackBucketWord ; BEGIN IF s=NIL THEN @@ -185,7 +185,7 @@ END IsEmptyWord ; PROCEDURE PeepWord (s: StackOfWord; n: CARDINAL) : WORD ; VAR - b: StackBucket ; + b: StackBucketWord ; BEGIN IF s^.tail=NIL THEN @@ -227,7 +227,7 @@ END PeepWord ; PROCEDURE ReduceWord (s: StackOfWord; n: CARDINAL) ; VAR - b: StackBucket ; + b: StackBucketWord ; BEGIN IF s^.tail=NIL THEN @@ -279,7 +279,7 @@ END RemoveTop ; PROCEDURE NoOfItemsInStackWord (s: StackOfWord) : CARDINAL ; VAR - b: StackBucket ; + b: StackBucketWord ; n: CARDINAL ; BEGIN IF IsEmptyWord(s) diff --git a/gcc/m2/gm2-compiler/P0SymBuild.mod b/gcc/m2/gm2-compiler/P0SymBuild.mod index 5bde3d1edf4..9575fd52e14 100644 --- a/gcc/m2/gm2-compiler/P0SymBuild.mod +++ b/gcc/m2/gm2-compiler/P0SymBuild.mod @@ -507,7 +507,7 @@ BEGIN END END ; EndBlock ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END EndProcedure ; @@ -543,7 +543,7 @@ BEGIN END END ; EndBlock ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END EndModule ; diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod index b3e139c7907..8bedf3604e0 100644 --- a/gcc/m2/gm2-compiler/P2SymBuild.mod +++ b/gcc/m2/gm2-compiler/P2SymBuild.mod @@ -227,7 +227,7 @@ BEGIN THEN WriteFormat2('inconsistant definition module name, module began as (%a) and ended with (%a)', NameStart, NameEnd) END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END P2EndBuildDefModule ; @@ -295,7 +295,7 @@ BEGIN THEN WriteFormat1('inconsistant implementation module name %a', NameStart) END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END P2EndBuildImplementationModule ; @@ -368,7 +368,7 @@ BEGIN THEN WriteFormat2('inconsistant program module name %a does not match %a', NameStart, NameEnd) END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END P2EndBuildProgramModule ; @@ -433,7 +433,7 @@ BEGIN WriteFormat2('inconsistant inner module name %a does not match %a', NameStart, NameEnd) END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END EndBuildInnerModule ; @@ -1272,7 +1272,7 @@ BEGIN WriteFormat2('end procedure name does not match beginning %a name %a', NameStart, NameEnd) END ; EndScope ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END EndBuildProcedure ; diff --git a/gcc/m2/gm2-compiler/P3SymBuild.mod b/gcc/m2/gm2-compiler/P3SymBuild.mod index fd8a9e22c78..b493c69db39 100644 --- a/gcc/m2/gm2-compiler/P3SymBuild.mod +++ b/gcc/m2/gm2-compiler/P3SymBuild.mod @@ -129,7 +129,7 @@ BEGIN WriteFormat2('inconsistant definition module was named (%a) and concluded as (%a)', NameStart, NameEnd) END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END P3EndBuildDefModule ; @@ -200,7 +200,7 @@ BEGIN WriteFormat0('too many errors in pass 3') ; FlushErrors END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END P3EndBuildImpModule ; @@ -273,7 +273,7 @@ BEGIN WriteFormat0('too many errors in pass 3') ; FlushErrors END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END P3EndBuildProgModule ; @@ -343,7 +343,7 @@ BEGIN FlushErrors END ; SetCurrentModule(GetModuleScope(GetCurrentModule())) ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END EndBuildInnerModule ; @@ -511,7 +511,7 @@ BEGIN FlushErrors END ; EndScope ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END EndBuildProcedure ; diff --git a/gcc/m2/gm2-compiler/PCSymBuild.mod b/gcc/m2/gm2-compiler/PCSymBuild.mod index bdfada86008..c817f0197bf 100644 --- a/gcc/m2/gm2-compiler/PCSymBuild.mod +++ b/gcc/m2/gm2-compiler/PCSymBuild.mod @@ -256,7 +256,7 @@ BEGIN WriteFormat2('inconsistant definition module was named (%a) and concluded as (%a)', NameStart, NameEnd) END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END PCEndBuildDefModule ; @@ -327,7 +327,7 @@ BEGIN WriteFormat0('too many errors in pass 3') ; FlushErrors END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END PCEndBuildImpModule ; @@ -400,7 +400,7 @@ BEGIN WriteFormat0('too many errors in pass 3') ; FlushErrors END ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END PCEndBuildProgModule ; @@ -470,7 +470,7 @@ BEGIN FlushErrors END ; SetCurrentModule(GetModuleScope(GetCurrentModule())) ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END PCEndBuildInnerModule ; @@ -663,7 +663,7 @@ BEGIN FlushErrors END ; EndScope ; - M2Error.LeaveScope + M2Error.LeaveErrorScope END PCEndBuildProcedure ; diff --git a/gcc/m2/gm2-compiler/SymbolKey.def b/gcc/m2/gm2-compiler/SymbolKey.def index bd0bc7b5fbd..cfa9116831f 100644 --- a/gcc/m2/gm2-compiler/SymbolKey.def +++ b/gcc/m2/gm2-compiler/SymbolKey.def @@ -37,7 +37,8 @@ EXPORT QUALIFIED NulKey, SymbolTree, IsSymbol, PerformOperation, InitTree, KillTree, GetSymKey, PutSymKey, DelSymKey, IsEmptyTree, - DoesTreeContainAny, ForeachNodeDo, ContainsSymKey ; + DoesTreeContainAny, ForeachNodeDo, ContainsSymKey, + NoOfNodes, ForeachNodeConditionDo ; CONST NulKey = 0 ; @@ -118,4 +119,21 @@ PROCEDURE ForeachNodeDo (t: SymbolTree; P: PerformOperation) ; PROCEDURE ContainsSymKey (t: SymbolTree; NameKey: Name) : BOOLEAN ; +(* + NoOfNodes - returns the number of nodes in the tree t. +*) + +PROCEDURE NoOfNodes (t: SymbolTree; condition: IsSymbol) : CARDINAL ; + + +(* + ForeachNodeConditionDo - traverse the tree t and for any node which satisfied + condition call P. +*) + +PROCEDURE ForeachNodeConditionDo (t: SymbolTree; + condition: IsSymbol; + P: PerformOperation) ; + + END SymbolKey. diff --git a/gcc/m2/gm2-compiler/SymbolKey.mod b/gcc/m2/gm2-compiler/SymbolKey.mod index 0e31c9d20e8..cc217301150 100644 --- a/gcc/m2/gm2-compiler/SymbolKey.mod +++ b/gcc/m2/gm2-compiler/SymbolKey.mod @@ -26,6 +26,7 @@ FROM Storage IMPORT ALLOCATE, DEALLOCATE ; FROM StrIO IMPORT WriteString, WriteLn ; FROM NumberIO IMPORT WriteCard ; FROM NameKey IMPORT WriteKey ; +FROM Assertion IMPORT Assert ; FROM Debug IMPORT Halt ; @@ -100,7 +101,7 @@ VAR father, child : SymbolTree ; BEGIN - FindNodeAndParentInTree(t, NameKey, child, father) ; + FindNodeParentInTree(t, NameKey, child, father) ; RETURN child#NIL END ContainsSymKey ; @@ -110,12 +111,12 @@ VAR father, child : SymbolTree ; BEGIN - FindNodeAndParentInTree(t, NameKey, child, father) ; + FindNodeParentInTree(t, NameKey, child, father) ; IF child=NIL THEN - RETURN( NulKey ) + RETURN NulKey ELSE - RETURN( child^.KeySym ) + RETURN child^.KeySym END END GetSymKey ; @@ -125,7 +126,7 @@ VAR father, child : SymbolTree ; BEGIN - FindNodeAndParentInTree(t, NameKey, child, father) ; + FindNodeParentInTree(t, NameKey, child, father) ; IF child=NIL THEN (* no child found, now is NameKey less than father or greater? *) @@ -168,7 +169,7 @@ PROCEDURE DelSymKey (t: SymbolTree; NameKey: Name) ; VAR i, child, father: SymbolTree ; BEGIN - FindNodeAndParentInTree(t, NameKey, child, father) ; (* find father and child of the node *) + FindNodeParentInTree(t, NameKey, child, father) ; (* find father and child of the node *) IF (child#NIL) AND (child^.KeyName=NameKey) THEN (* Have found the node to be deleted *) @@ -225,35 +226,36 @@ END DelSymKey ; (* - FindNodeAndParentInTree - find a node, child, in a binary tree, t, with name equal to n. - if an entry is found, father is set to the node above child. + FindNodeParentInTree - find a node, child, in a binary tree, t, with name equal to n. + if an entry is found, parent is set to the node above child. *) -PROCEDURE FindNodeAndParentInTree (t: SymbolTree; n: Name; - VAR child, father: SymbolTree) ; +PROCEDURE FindNodeParentInTree (t: SymbolTree; n: Name; + VAR child, parent: SymbolTree) ; BEGIN - (* remember to skip the sentinal value and assign father and child *) - father := t ; + (* remember to skip the sentinal value and assign parent and child *) + parent := t ; IF t=NIL THEN Halt('parameter t should never be NIL', __LINE__, __FILE__) END ; + Assert (t^.Right = NIL) ; child := t^.Left ; IF child#NIL THEN REPEAT IF nchild^.KeyName THEN - father := child ; + parent := child ; child := child^.Right END UNTIL (child=NIL) OR (n=child^.KeyName) END -END FindNodeAndParentInTree ; +END FindNodeParentInTree ; (* @@ -262,7 +264,7 @@ END FindNodeAndParentInTree ; PROCEDURE IsEmptyTree (t: SymbolTree) : BOOLEAN ; BEGIN - RETURN( t^.Left=NIL ) + RETURN t^.Left = NIL END IsEmptyTree ; @@ -276,7 +278,7 @@ END IsEmptyTree ; PROCEDURE DoesTreeContainAny (t: SymbolTree; P: IsSymbol) : BOOLEAN ; BEGIN - RETURN( SearchForAny(t^.Left, P) ) + RETURN SearchForAny (t^.Left, P) END DoesTreeContainAny ; @@ -290,9 +292,10 @@ PROCEDURE SearchForAny (t: SymbolTree; P: IsSymbol) : BOOLEAN ; BEGIN IF t=NIL THEN - RETURN( FALSE ) + RETURN FALSE ELSE - RETURN( P(t^.KeySym) OR SearchForAny(t^.Left, P) OR + RETURN( P (t^.KeySym) OR + SearchForAny (t^.Left, P) OR SearchForAny(t^.Right, P) ) END @@ -331,4 +334,74 @@ BEGIN END SearchAndDo ; +(* + CountNodes - wrapper for NoOfNodes. +*) + +PROCEDURE CountNodes (t: SymbolTree; condition: IsSymbol; count: CARDINAL) : CARDINAL ; +BEGIN + IF t # NIL + THEN + WITH t^ DO + IF condition (KeySym) + THEN + INC (count) + END ; + count := CountNodes (Left, condition, count) ; + count := CountNodes (Right, condition, count) + END + END ; + RETURN count +END CountNodes ; + + +(* + NoOfNodes - returns the number of nodes in the tree t. +*) + +PROCEDURE NoOfNodes (t: SymbolTree; condition: IsSymbol) : CARDINAL ; +BEGIN + RETURN CountNodes (t^.Left, condition, 0) +END NoOfNodes ; + + +(* + SearchConditional - wrapper for ForeachNodeConditionDo. +*) + +PROCEDURE SearchConditional (t: SymbolTree; condition: IsSymbol; P: PerformOperation) ; +BEGIN + IF t#NIL + THEN + WITH t^ DO + SearchConditional (Right, condition, P) ; + IF (KeySym # 0) AND condition (KeySym) + THEN + P (KeySym) + END ; + SearchConditional (Left, condition, P) + END + END +END SearchConditional ; + + +(* + ForeachNodeConditionDo - traverse the tree t and for any node which satisfied + condition call P. +*) + +PROCEDURE ForeachNodeConditionDo (t: SymbolTree; + condition: IsSymbol; + P: PerformOperation) ; +BEGIN + IF t#NIL + THEN + WITH t^ DO + Assert (Right = NIL) ; + SearchConditional (Left, condition, P) + END + END +END ForeachNodeConditionDo ; + + END SymbolKey. diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def index aaba4c4b893..24329a7e1ae 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.def +++ b/gcc/m2/gm2-compiler/SymbolTable.def @@ -34,6 +34,7 @@ FROM SymbolKey IMPORT PerformOperation ; FROM NameKey IMPORT Name ; FROM m2tree IMPORT Tree ; FROM DynamicStrings IMPORT String ; +FROM M2Error IMPORT ErrorScope ; EXPORT QUALIFIED NulSym, FinalSymbol, @@ -311,6 +312,7 @@ EXPORT QUALIFIED NulSym, PutModuleContainsBuiltin, IsBuiltinInModule, HasVarParameters, + GetErrorScope, IsSizeSolved, IsOffsetSolved, @@ -3202,4 +3204,22 @@ PROCEDURE DisplayTrees (ModSym: CARDINAL) ; PROCEDURE DebugLineNumbers (sym: CARDINAL) ; +(* + GetErrorScope - returns the error scope for a symbol. + The error scope is the title scope which is used to + announce the symbol in the GCC error message. +*) + +PROCEDURE GetErrorScope (sym: CARDINAL) : ErrorScope ; + + +(* + PutErrorScope - sets the error scope for a symbol. + The error scope is the title scope which is used to + announce the symbol in the GCC error message. + +PROCEDURE PutErrorScope (sym: CARDINAL; errorScope: ErrorScope) ; +*) + + END SymbolTable. diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod index f3e6b0b5bd6..14e89f36740 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -41,7 +41,7 @@ FROM M2ALU IMPORT InitValue, PtrToValue, PushCard, PopInto, FROM M2Error IMPORT Error, NewError, ChainError, InternalError, ErrorFormat0, ErrorFormat1, ErrorFormat2, WriteFormat0, WriteFormat1, WriteFormat2, ErrorString, - ErrorAbort0, FlushErrors ; + ErrorAbort0, FlushErrors, ErrorScope, GetCurrentErrorScope ; FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3, MetaErrors1, MetaErrorT0, @@ -63,10 +63,11 @@ FROM Lists IMPORT List, InitList, GetItemFromList, PutItemIntoList, FROM NameKey IMPORT Name, MakeKey, makekey, NulName, WriteKey, LengthKey, GetKey, KeyToCharStar ; -FROM SymbolKey IMPORT NulKey, SymbolTree, +FROM SymbolKey IMPORT NulKey, SymbolTree, IsSymbol, InitTree, GetSymKey, PutSymKey, DelSymKey, IsEmptyTree, - DoesTreeContainAny, ForeachNodeDo ; + DoesTreeContainAny, ForeachNodeDo, ForeachNodeConditionDo, + NoOfNodes ; FROM M2Base IMPORT MixTypes, InitBase, Char, Integer, LongReal, Cardinal, LongInt, LongCard, ZType, RType ; @@ -165,6 +166,8 @@ TYPE name : Name ; (* Index into name array, name *) (* of record. *) oafamily : CARDINAL ; (* The oafamily for this sym *) + errorScope: ErrorScope ; (* Title scope used if an *) + (* error is emitted. *) At : Where ; (* Where was sym declared/used *) END ; @@ -365,6 +368,7 @@ TYPE ExceptionFinally, ExceptionBlock: BOOLEAN ; (* does it have an exception? *) Scope : CARDINAL ; (* Scope of declaration. *) + errorScope : ErrorScope ; (* The title scope. *) ListOfModules : List ; (* List of all inner modules. *) Begin, End : CARDINAL ; (* Tokens marking the BEGIN END *) At : Where ; (* Where was sym declared/used *) @@ -660,6 +664,7 @@ TYPE ListOfProcs : List ; (* List of all procedures *) (* declared within this module. *) ListOfModules : List ; (* List of all inner modules. *) + errorScope : ErrorScope ; (* The title scope. *) At : Where ; (* Where was sym declared/used *) END ; @@ -722,6 +727,7 @@ TYPE ListOfProcs : List ; (* List of all procedures *) (* declared within this module. *) ListOfModules : List ; (* List of all inner modules. *) + errorScope : ErrorScope ; (* The title scope. *) At : Where ; (* Where was sym declared/used *) END ; @@ -2808,7 +2814,8 @@ BEGIN Scope := NulSym ELSE Scope := pCall^.Main - END + END ; + errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; PutSymKey(ModuleTree, ModuleName, Sym) ; @@ -2919,7 +2926,8 @@ BEGIN ELSE Scope := GetCurrentScope() ; AddModuleToParent(Sym, Scope) - END + END ; + errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END ; END ; AddSymToScope(Sym, ModuleName) @@ -3039,6 +3047,7 @@ BEGIN InitList(ListOfModules) ; (* List of all inner modules. *) InitWhereDeclaredTok(tok, At) ; (* Where symbol declared. *) InitWhereFirstUsedTok(tok, At) ; (* Where symbol first used. *) + errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; PutSymKey(ModuleTree, DefImpName, Sym) ; @@ -3122,6 +3131,7 @@ BEGIN Begin := 0 ; (* token number for BEGIN *) End := 0 ; (* token number for END *) InitWhereDeclaredTok(tok, At) ; (* Where symbol declared. *) + errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; (* Now add this procedure to the symbol table of the current scope *) @@ -7897,6 +7907,45 @@ BEGIN END IsUnreportedUnknown ; +VAR + ListifySentance : String ; + ListifyTotal, + ListifyWordCount: CARDINAL ; + + +(* + AddListify - +*) + +PROCEDURE AddListify (sym: CARDINAL) ; +BEGIN + INC (ListifyWordCount) ; + IF ListifyWordCount = ListifyTotal + THEN + ListifySentance := ConCat (ListifySentance, Mark (InitString (" and "))) + ELSIF ListifyWordCount > 1 + THEN + ListifySentance := ConCat (ListifySentance, Mark (InitString (", "))) + END ; + ListifySentance := ConCat (ListifySentance, + Mark (InitStringCharStar (KeyToCharStar (GetSymName (sym))))) +END AddListify ; + + +(* + Listify - convert tree into a string list and return the result. +*) + +PROCEDURE Listify (tree: SymbolTree; isCondition: IsSymbol) : String ; +BEGIN + ListifyTotal := NoOfNodes (tree, isCondition) ; + ListifyWordCount := 0 ; + ListifySentance := InitString ('') ; + ForeachNodeConditionDo (tree, isCondition, AddListify) ; + RETURN ListifySentance +END Listify ; + + (* CheckForUnknowns - checks a binary tree, Tree, to see whether it contains an unknown symbol. All unknown symbols are displayed @@ -7915,6 +7964,8 @@ BEGIN s := ConCat(s, Mark(InitStringCharStar(KeyToCharStar(name)))) ; s := ConCat(s, Mark(InitString('%> were '))) ; s := ConCat(s, Mark(InitString(a))) ; + s := ConCat (s, Mark (InitString (': '))) ; + s := ConCat (s, Mark (Listify (Tree, IsUnreportedUnknown))) ; MetaErrorStringT0(GetTokenNo(), s) ; ForeachNodeDo(Tree, UnknownSymbolError) END @@ -9678,6 +9729,7 @@ BEGIN WITH Undefined DO name := SymName ; oafamily := NulSym ; + errorScope := GetCurrentErrorScope () ; InitWhereFirstUsedTok (tok, At) END END @@ -13283,6 +13335,59 @@ END DumpSymbols ; *) +(* + GetErrorScope - returns the error scope for a symbol. + The error scope is the title scope which is used to + announce the symbol in the GCC error message. +*) + +PROCEDURE GetErrorScope (sym: CARDINAL) : ErrorScope ; +VAR + pSym: PtrToSymbol ; +BEGIN + pSym := GetPsym (sym) ; + WITH pSym^ DO + CASE SymbolType OF + + ProcedureSym: RETURN Procedure.errorScope | + ModuleSym : RETURN Module.errorScope | + DefImpSym : RETURN DefImp.errorScope | + UndefinedSym: RETURN Undefined.errorScope + + ELSE + InternalError ('expecting procedure, module or defimp symbol') + END + END +END GetErrorScope ; + + +(* + PutErrorScope - sets the error scope for a symbol. + The error scope is the title scope which is used to + announce the symbol in the GCC error message. +*) + +(* +PROCEDURE PutErrorScope (sym: CARDINAL; errorScope: ErrorScope) ; +VAR + pSym: PtrToSymbol ; +BEGIN + pSym := GetPsym (type) ; + WITH pSym^ DO + CASE SymbolType OF + + ProcedureSym: Procedure.errorScope := errorScope | + ModuleSym : Module.errorScope := errorScope | + DefImpSym : DefImp.errorScope := errorScope + + ELSE + InternalError ('expecting procedure, module or defimp symbol') + END + END +END PutErrorScope ; +*) + + (* IsLegal - returns TRUE if, sym, is a legal symbol. *)