| (* M2Scope.mod derive the subset of quadruples for each scope. |
| |
| Copyright (C) 2003-2026 Free Software Foundation, Inc. |
| Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>. |
| |
| This file is part of GNU Modula-2. |
| |
| GNU Modula-2 is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 3, or (at your option) |
| any later version. |
| |
| GNU Modula-2 is distributed in the hope that it will be useful, but |
| WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GNU Modula-2; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. *) |
| |
| IMPLEMENTATION MODULE M2Scope ; |
| |
| FROM Storage IMPORT ALLOCATE, DEALLOCATE ; |
| FROM M2Debug IMPORT Assert ; |
| FROM NameKey IMPORT Name ; |
| |
| FROM SymbolTable IMPORT IsProcedure, IsDefImp, GetProcedureQuads, GetScope, |
| GetProcedureScope, IsModule, IsModuleWithinProcedure, |
| GetSymName, GetErrorScope, NulSym ; |
| |
| FROM M2Printf IMPORT printf0, printf1 ; |
| FROM M2Quads IMPORT QuadOperator, GetFirstQuad, GetNextQuad, GetQuad, DisplayQuadRange ; |
| FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord, |
| PopWord, PushWord, PeepWord ; |
| IMPORT M2Error ; |
| |
| |
| CONST |
| Debugging = FALSE ; |
| TraceQuadruples = FALSE ; |
| |
| TYPE |
| scopeKind = (unsetscope, ignorescope, procedurescope, modulescope, definitionscope, implementationscope, programscope) ; |
| |
| ScopeBlock = POINTER TO RECORD |
| scopeSym : CARDINAL ; |
| kindScope: scopeKind ; |
| low, high: CARDINAL ; |
| next : ScopeBlock ; |
| END ; |
| |
| VAR |
| FreeList: ScopeBlock ; |
| |
| |
| (* |
| New - |
| *) |
| |
| PROCEDURE New (VAR sb: ScopeBlock) ; |
| BEGIN |
| IF FreeList = NIL |
| THEN |
| NEW (sb) |
| ELSE |
| sb := FreeList ; |
| FreeList := FreeList^.next |
| END |
| END New ; |
| |
| |
| (* |
| Dispose - |
| *) |
| |
| PROCEDURE Dispose (VAR sb: ScopeBlock) ; |
| BEGIN |
| sb^.next := FreeList ; |
| FreeList := sb ; |
| sb := NIL |
| END Dispose ; |
| |
| |
| (* |
| SetScope - assigns the scopeSym and kindScope. |
| *) |
| |
| PROCEDURE SetScope (sb: ScopeBlock; sym: CARDINAL; kindScope: scopeKind) ; |
| BEGIN |
| sb^.scopeSym := sym ; |
| sb^.kindScope := kindScope |
| END SetScope ; |
| |
| |
| (* |
| AddToRange - returns a ScopeBlock pointer to the last block. The, |
| quad, will be added to the end of sb or a later block |
| if First is TRUE. |
| *) |
| |
| PROCEDURE AddToRange (sb: ScopeBlock; |
| First: BOOLEAN; quad: CARDINAL) : ScopeBlock ; |
| BEGIN |
| IF First |
| THEN |
| IF sb^.high=0 |
| THEN |
| sb^.high := sb^.low |
| END ; |
| sb^.next := InitScopeBlock (NulSym) ; |
| sb := sb^.next |
| END ; |
| IF sb^.low=0 |
| THEN |
| sb^.low := quad |
| END ; |
| sb^.high := quad ; |
| RETURN sb |
| END AddToRange ; |
| |
| |
| (* |
| GetGlobalQuads - |
| *) |
| |
| PROCEDURE GetGlobalQuads (sb: ScopeBlock; scope: CARDINAL) : ScopeBlock ; |
| VAR |
| prev, |
| nb : ScopeBlock ; |
| NestedLevel, |
| i : CARDINAL ; |
| op : QuadOperator ; |
| op1, op2, op3: CARDINAL ; |
| First : BOOLEAN ; |
| start, end : CARDINAL ; |
| BEGIN |
| NestedLevel := 0 ; |
| prev := NIL ; |
| First := FALSE ; |
| IF (GetScope(scope)#NulSym) AND |
| (IsProcedure(GetScope(scope)) OR |
| (IsModule(scope) AND IsModuleWithinProcedure(scope))) |
| THEN |
| GetProcedureQuads (GetProcedureScope (scope), i, start, end) ; |
| GetQuad (i, op, op1, op2, op3) ; |
| WHILE (op#ModuleScopeOp) OR (op3#scope) DO |
| i := GetNextQuad (i) ; |
| GetQuad (i, op, op1, op2, op3) |
| END ; |
| end := i ; |
| GetQuad (end, op, op1, op2, op3) ; |
| WHILE (op#FinallyEndOp) OR (op3#scope) DO |
| end := GetNextQuad (end) ; |
| GetQuad (end, op, op1, op2, op3) |
| END |
| ELSE |
| i := GetFirstQuad () ; |
| end := 0 |
| END ; |
| nb := sb ; |
| sb^.low := 0 ; |
| sb^.high := 0 ; |
| LOOP |
| IF i=0 |
| THEN |
| IF Debugging |
| THEN |
| DisplayScope (sb) |
| END ; |
| RETURN sb |
| END ; |
| GetQuad (i, op, op1, op2, op3) ; |
| IF op=ProcedureScopeOp |
| THEN |
| INC (NestedLevel) |
| ELSIF op=ReturnOp |
| THEN |
| IF NestedLevel>0 |
| THEN |
| DEC (NestedLevel) |
| END ; |
| IF NestedLevel=0 |
| THEN |
| First := TRUE |
| END |
| ELSIF NestedLevel=0 |
| THEN |
| IF op=StartDefFileOp |
| THEN |
| nb := AddToRange (nb, TRUE, i) ; |
| SetScope (nb, op3, definitionscope) ; |
| prev := nb |
| ELSIF (op=StartModFileOp) OR (op=InitStartOp) |
| THEN |
| nb := AddToRange (nb, TRUE, i) ; |
| IF IsDefImp (op3) |
| THEN |
| SetScope (nb, op3, implementationscope) |
| ELSE |
| SetScope (nb, op3, programscope) |
| END ; |
| prev := nb |
| ELSE |
| nb := AddToRange (nb, First, i) ; |
| IF op = InitEndOp |
| THEN |
| IF IsDefImp (op3) |
| THEN |
| SetScope (nb, op3, implementationscope) |
| ELSE |
| SetScope (nb, op3, programscope) |
| END ; |
| prev := nb |
| ELSIF First |
| THEN |
| Assert (prev # NIL) ; |
| SetScope (nb, prev^.scopeSym, prev^.kindScope) |
| END |
| END ; |
| First := FALSE |
| END ; |
| IF i=end |
| THEN |
| IF Debugging |
| THEN |
| DisplayScope (sb) |
| END ; |
| RETURN sb |
| END ; |
| i := GetNextQuad (i) |
| END |
| END GetGlobalQuads ; |
| |
| |
| (* |
| GetProcQuads - |
| *) |
| |
| PROCEDURE GetProcQuads (sb: ScopeBlock; |
| proc: CARDINAL) : ScopeBlock ; |
| VAR |
| nb : ScopeBlock ; |
| scope, start, |
| end, i, last : CARDINAL ; |
| op : QuadOperator ; |
| op1, op2, op3: CARDINAL ; |
| First : BOOLEAN ; |
| s : StackOfWord ; |
| n : Name ; |
| BEGIN |
| s := InitStackWord () ; |
| IF Debugging |
| THEN |
| n := GetSymName (proc) ; |
| printf1("GetProcQuads for %a\n", n) |
| END ; |
| Assert(IsProcedure(proc)) ; |
| GetProcedureQuads(proc, scope, start, end) ; |
| IF Debugging |
| THEN |
| printf1(" proc %d\n", proc) ; |
| printf1(" scope %d\n", scope) ; |
| printf1(" start %d\n", start) ; |
| printf1(" end %d\n", end) |
| END ; |
| PushWord(s, 0) ; |
| First := FALSE ; |
| i := scope ; |
| last := scope ; |
| nb := sb ; |
| sb^.low := scope ; |
| sb^.high := 0 ; |
| SetScope (sb, proc, procedurescope) ; |
| WHILE (i<=end) AND (start#0) DO |
| GetQuad (i, op, op1, op2, op3) ; |
| IF (op=ProcedureScopeOp) OR (op=ModuleScopeOp) |
| THEN |
| IF (PeepWord(s, 1)=proc) AND (op3=proc) |
| THEN |
| nb := AddToRange (nb, First, last) ; |
| First := FALSE |
| END ; |
| PushWord (s, op3) ; |
| IF op=ProcedureScopeOp |
| THEN |
| SetScope (nb, proc, procedurescope) |
| ELSE |
| SetScope (nb, proc, modulescope) |
| END |
| ELSIF (op=ReturnOp) OR (op=FinallyEndOp) |
| THEN |
| op3 := PopWord (s) ; |
| IF PeepWord (s, 1) = proc |
| THEN |
| First := TRUE |
| END |
| ELSE |
| IF PeepWord (s, 1) = proc |
| THEN |
| nb := AddToRange (nb, First, i) ; |
| First := FALSE |
| END |
| END ; |
| last := i ; |
| i := GetNextQuad (i) |
| END ; |
| IF start<=nb^.high |
| THEN |
| nb^.high := end |
| ELSE |
| nb^.next := InitScopeBlock (NulSym) ; |
| nb := nb^.next ; |
| SetScope (nb, proc, unsetscope) ; |
| WITH nb^ DO |
| low := start ; |
| high := end |
| END |
| END ; |
| s := KillStackWord (s) ; |
| RETURN sb |
| END GetProcQuads ; |
| |
| |
| (* |
| DisplayScope - |
| *) |
| |
| PROCEDURE DisplayScope (sb: ScopeBlock) ; |
| VAR |
| name: Name ; |
| BEGIN |
| WITH sb^ DO |
| printf0 ("scope: ") ; |
| CASE sb^.kindScope OF |
| |
| unsetscope : printf0 ("unset") | |
| ignorescope : printf0 ("ignore") | |
| procedurescope : name := GetSymName (scopeSym) ; |
| printf1 ("procedure %a", name) | |
| modulescope : name := GetSymName (scopeSym) ; |
| printf1 ("inner module %a", name) | |
| definitionscope : name := GetSymName (scopeSym) ; |
| printf1 ("definition module %a", name) | |
| implementationscope: name := GetSymName (scopeSym) ; |
| printf1 ("implementation module %a", name) | |
| programscope : name := GetSymName (scopeSym) ; |
| printf1 ("program module %a", name) |
| |
| END ; |
| printf0 ("\n") ; |
| DisplayQuadRange (scopeSym, low, high) ; |
| IF next#NIL |
| THEN |
| DisplayScope (next) |
| END |
| END |
| END DisplayScope ; |
| |
| |
| (* |
| InitScopeBlock - |
| *) |
| |
| PROCEDURE InitScopeBlock (scope: CARDINAL) : ScopeBlock ; |
| VAR |
| sb: ScopeBlock ; |
| BEGIN |
| New (sb) ; |
| WITH sb^ DO |
| next := NIL ; |
| kindScope := unsetscope ; |
| IF scope=NulSym |
| THEN |
| low := 0 ; |
| high := 0 |
| ELSE |
| IF IsProcedure (scope) |
| THEN |
| sb := GetProcQuads (sb, scope) |
| ELSE |
| sb := GetGlobalQuads (sb, scope) ; |
| END ; |
| IF TraceQuadruples |
| THEN |
| DisplayScope (sb) |
| END |
| END |
| END ; |
| RETURN sb |
| END InitScopeBlock ; |
| |
| |
| (* |
| KillScopeBlock - destroys the ScopeBlock sb and assign sb to NIL. |
| *) |
| |
| PROCEDURE KillScopeBlock (VAR sb: ScopeBlock) ; |
| VAR |
| t: ScopeBlock ; |
| BEGIN |
| t := sb ; |
| WHILE t # NIL DO |
| sb := t ; |
| t := t^.next ; |
| Dispose (sb) ; |
| END ; |
| sb := NIL |
| END KillScopeBlock ; |
| |
| |
| (* |
| ForeachScopeBlockDo2 - calls a procedure p for each block of contigeous quadruples |
| defining an outer scope sb. |
| *) |
| |
| PROCEDURE ForeachScopeBlockDo2 (sb: ScopeBlock; p: ScopeProcedure2) ; |
| BEGIN |
| IF TraceQuadruples |
| THEN |
| printf0 ("ForeachScopeBlockDo\n") |
| END ; |
| WHILE sb#NIL DO |
| WITH sb^ DO |
| IF TraceQuadruples |
| THEN |
| DisplayScope (sb) |
| END ; |
| enter (sb) ; |
| IF (low # 0) AND (high # 0) |
| THEN |
| p (low, high) |
| END ; |
| leave (sb) |
| END ; |
| sb := sb^.next |
| END ; |
| IF TraceQuadruples |
| THEN |
| printf0 ("end ForeachScopeBlockDo\n\n") |
| END ; |
| END ForeachScopeBlockDo2 ; |
| |
| |
| (* |
| ForeachScopeBlockDo3 - calls a procedure p for each block of contigeous quadruples |
| defining an outer scope sb. |
| *) |
| |
| PROCEDURE ForeachScopeBlockDo3 (sb: ScopeBlock; p: ScopeProcedure3) ; |
| BEGIN |
| IF TraceQuadruples |
| THEN |
| printf0 ("ForeachScopeBlockDo\n") |
| END ; |
| WHILE sb#NIL DO |
| WITH sb^ DO |
| IF TraceQuadruples |
| THEN |
| DisplayScope (sb) |
| END ; |
| enter (sb) ; |
| IF (low # 0) AND (high # 0) |
| THEN |
| p (scopeSym, low, high) |
| END ; |
| leave (sb) |
| END ; |
| sb := sb^.next |
| END ; |
| IF TraceQuadruples |
| THEN |
| printf0 ("end ForeachScopeBlockDo\n\n") |
| END ; |
| END ForeachScopeBlockDo3 ; |
| |
| |
| (* |
| enter - |
| *) |
| |
| PROCEDURE enter (sb: ScopeBlock) ; |
| BEGIN |
| WITH sb^ DO |
| CASE kindScope OF |
| |
| unsetscope, |
| ignorescope : | |
| procedurescope , |
| modulescope , |
| definitionscope , |
| implementationscope, |
| programscope : M2Error.EnterErrorScope (GetErrorScope (scopeSym)) |
| |
| END |
| END |
| END enter ; |
| |
| |
| (* |
| leave - |
| *) |
| |
| PROCEDURE leave (sb: ScopeBlock) ; |
| BEGIN |
| CASE sb^.kindScope OF |
| |
| unsetscope, |
| ignorescope : | |
| |
| ELSE |
| M2Error.LeaveErrorScope |
| END |
| END leave ; |
| |
| |
| |
| (* |
| Init - initializes the global variables for this module. |
| *) |
| |
| PROCEDURE Init ; |
| BEGIN |
| FreeList := NIL |
| END Init ; |
| |
| |
| BEGIN |
| Init |
| END M2Scope. |
