https://gcc.gnu.org/g:48d49200510198cafcab55601cd8e5f8eb541f01
commit r14-9599-g48d49200510198cafcab55601cd8e5f8eb541f01
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Thu Mar 21 19:38:03 2024 +0000
PR modula2/113836 gm2 does not dump gimple or quadruples to file
This patch provides the localized modula2 changes to gcc/m2
which facilitate the dumping of gimple and quadruples to file.
PR modula2/113836 will be full complete after a subsequent patch
adding changes to lang.opt and documentation. The lang.opt
patch requires all language bootstrap regression testing whereas
this patch is isolated to gcc/m2 and only the m2 language.
gcc/m2/ChangeLog:
PR modula2/113836
* Make-lang.in (GM2_C_OBJS): Add m2/gm2-gcc/m2pp.o.
(m2/m2pp.o): Remove rule.
(GM2-COMP-BOOT-DEFS): Add M2LangDump.def.
(GM2-COMP-BOOT-MODS): Add M2LangDump.mod.
(GM2-GCC-DEFS): Add M2LangDump.def.
(GM2-GCC-MODS): Add M2LangDump.mod.
* gm2-compiler/M2CaseList.mod (WriteCase): Rewrite.
* gm2-compiler/M2Code.mod (DoModuleDeclare): Call
DumpFilteredResolver depending upon DumpLangDecl.
(DoCodeBlock): Call CreateDumpGimple depending upon
DumpLangGimple.
(Code): Replace DisplayQuadList blocks with DumpQuadruples.
(DisplayQuadsInScope): Remove.
(DisplayQuadNumbers): Remove.
(CodeBlock): Rewrite.
* gm2-compiler/M2GCCDeclare.def (IncludeDumpSymbol): New procedure.
(DumpFilteredResolver): New procedure.
(DumpFilteredDefinitive): New procedure.
* gm2-compiler/M2GCCDeclare.mod (IncludeDumpSymbol): New procedure.
(DumpFilteredResolver): New procedure.
(DumpFilteredDefinitive): New procedure.
(doInclude): Rewrite to use GetDumpFile.
(WatchIncludeList): Remove fixed debugging value.
(doExclude): Rewrite to use GetDumpFile.
(DeclareTypesConstantsProceduresInRange): Remove fixed debugging
values.
(PreAddModGcc): Rename parameter t as tree.
(IncludeGetNth): Rewrite to use GetDumpFile.
(IncludeType): Ditto.
(IncludeSubscript): Ditto.
(PrintLocalSymbol): Ditto.
(PrintLocalSymbols): Ditto.
(IncludeGetVarient): Ditto.
(PrintDeclared): Ditto.
(PrintAlignment): Ditto.
(PrintDecl): Ditto.
(PrintScope): Ditto.
(PrintProcedure): Ditto.
(PrintSym): Ditto.
(PrintSymbol): Ditto.
(PrintTerse): Ditto.
* gm2-compiler/M2Options.def (GetDumpLangDeclFilename): New
procedure function.
(SetDumpLangDeclFilename): New procedure.
(GetDumpLangQuadFilename): New procedure function.
(SetDumpLangQuadFilename): New procedure.
(GetDumpLangGimpleFilename): New procedure function.
(SetDumpLangGimpleFilename): New procedure.
(SetM2DumpFilter): New procedure.
(GetM2DumpFilter): New procedure function.
(GetDumpLangGimple): New procedure function.
* gm2-compiler/M2Options.mod (GetDumpLangDeclFilename): New
procedure function.
(SetDumpLangDeclFilename): New procedure.
(GetDumpLangQuadFilename): New procedure function.
(SetDumpLangQuadFilename): New procedure.
(GetDumpLangGimpleFilename): New procedure function.
(SetDumpLangGimpleFilename): New procedure.
(SetM2DumpFilter): New procedure.
(GetM2DumpFilter): New procedure function.
(GetDumpLangGimple): New procedure function.
* gm2-compiler/M2Quads.def (DumpQuadruples): New procedure.
* gm2-compiler/M2Quads.mod (DumpUntil): New procedure.
(GetCtorInit): New procedure function.
(GetCtorFini): New procedure function.
(DumpQuadrupleFilter): New procedure function.
(DumpQuadrupleAll): New procedure.
(DisplayQuadList): Remove procedure.
(DumpQuadruples): New procedure.
(DisplayQuadRange): Rewrite.
(DisplayQuad): Ditto.
(DisplayProcedureAttributes): Ditto.
(WriteOperator): Ditto.
(WriteMode): Ditto.
* gm2-compiler/M2Scope.mod (ForeachScopeBlockDo2): Replace
DisplayQuadruples with TraceQuadruples.
(ForeachScopeBlockDo3): Replace DisplayQuadruples with
TraceQuadruples.
* gm2-compiler/SymbolConversion.def (Gcc2Mod): New procedure
function.
* gm2-compiler/SymbolConversion.mod: New procedure function.
* gm2-gcc/m2misc.cc (m2misc_DebugTree): New function.
(m2misc_DebugTreeChain): New function.
* gm2-gcc/m2options.h (M2Options_GetDumpLangDeclFilename): New
prototype.
(M2Options_SetDumpLangDeclFilename): New prototype.
(M2Options_GetDumpLangQuadFilename): New prototype.
(M2Options_SetDumpLangQuadFilename): New prototype.
(M2Options_GetDumpLangGimpleFilename): New prototype.
(M2Options_SetDumpLangGimpleFilename): New prototype.
(M2Options_GetDumpLangGimple): New prototype.
(M2Options_SetM2DumpFilter): New prototype.
(M2Options_GetM2DumpFilter): New prototype.
* m2pp.cc: Move to...
* gm2-gcc/m2pp.cc: ...here.
* m2pp.h: Move to...
* gm2-gcc/m2pp.h: ...here.
* gm2-gcc/m2statement.cc (m2statement_BuildEndFunctionCode): Call
m2pp_dump_gimple.
* gm2-lang.cc (ENABLE_QUAD_DUMP_ALL): New define.
(gm2_langhook_init_options): Add switch cases for proposed new
command line options.
* gm2-libs/DynamicStrings.def (ReverseIndex): New procedure
function.
* gm2-libs/DynamicStrings.mod: New procedure function.
* gm2-compiler/M2LangDump.def: New file.
* gm2-compiler/M2LangDump.mod: New file.
* gm2-gcc/m2langdump.h: New file.
* gm2-gcc/m2pp.def: New file.
Signed-off-by: Gaius Mulley <gaiusm...@gmail.com>
Diff:
---
gcc/m2/Make-lang.in | 12 +-
gcc/m2/gm2-compiler/M2CaseList.mod | 4 +-
gcc/m2/gm2-compiler/M2Code.mod | 111 ++---
gcc/m2/gm2-compiler/M2GCCDeclare.def | 21 +
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 434 +++++++++--------
gcc/m2/gm2-compiler/M2LangDump.def | 102 ++++
gcc/m2/gm2-compiler/M2LangDump.mod | 802 +++++++++++++++++++++++++++++++
gcc/m2/gm2-compiler/M2Options.def | 68 ++-
gcc/m2/gm2-compiler/M2Options.mod | 135 +++++-
gcc/m2/gm2-compiler/M2Quads.def | 8 +-
gcc/m2/gm2-compiler/M2Quads.mod | 392 +++++++++------
gcc/m2/gm2-compiler/M2Scope.mod | 18 +-
gcc/m2/gm2-compiler/SymbolConversion.def | 9 +-
gcc/m2/gm2-compiler/SymbolConversion.mod | 25 +-
gcc/m2/gm2-gcc/m2langdump.h | 41 ++
gcc/m2/gm2-gcc/m2misc.cc | 6 +-
gcc/m2/gm2-gcc/m2options.h | 9 +
gcc/m2/{ => gm2-gcc}/m2pp.cc | 309 ++++++++----
gcc/m2/gm2-gcc/m2pp.def | 45 ++
gcc/m2/{ => gm2-gcc}/m2pp.h | 38 +-
gcc/m2/gm2-gcc/m2statement.cc | 7 +-
gcc/m2/gm2-lang.cc | 38 +-
gcc/m2/gm2-libs/DynamicStrings.def | 20 +-
gcc/m2/gm2-libs/DynamicStrings.mod | 46 +-
24 files changed, 2139 insertions(+), 561 deletions(-)
diff --git a/gcc/m2/Make-lang.in b/gcc/m2/Make-lang.in
index 33b9ce8d8e8..49ec168b205 100644
--- a/gcc/m2/Make-lang.in
+++ b/gcc/m2/Make-lang.in
@@ -519,7 +519,7 @@ SO=-O0 -g -fPIC
# Language-specific object files for the gm2 compiler.
GM2_C_OBJS = m2/gm2-lang.o \
- m2/m2pp.o \
+ m2/gm2-gcc/m2pp.o \
m2/gm2-gcc/m2assert.o \
m2/gm2-gcc/m2block.o \
m2/gm2-gcc/m2builtins.o \
@@ -608,11 +608,6 @@ m2/gm2-lang.o: $(srcdir)/m2/gm2-lang.cc gt-m2-gm2-lang.h
$(GCC_HEADER_DEPENDENCI
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
$(POSTCOMPILE)
-m2/m2pp.o : $(srcdir)/m2/m2pp.cc $(GCC_HEADER_DEPENDENCIES_FOR_M2)
- $(COMPILER) $(CM2DEP) -c -g -DGM2 $(ALL_COMPILERFLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
- $(POSTCOMPILE)
-
m2/gm2-gcc/rtegraph.o: $(srcdir)/m2/gm2-gcc/rtegraph.cc
$(GCC_HEADER_DEPENDENCIES_FOR_M2) \
gt-m2-rtegraph.h
-test -d $(@D)/$(DEPDIR) || $(mkinstalldirs) $(@D)/$(DEPDIR)
@@ -761,6 +756,7 @@ GM2-COMP-BOOT-DEFS = \
M2GCCDeclare.def \
M2GenGCC.def \
M2Graph.def \
+ M2LangDump.def \
M2LexBuf.def \
M2MetaError.def \
M2Optimize.def \
@@ -834,6 +830,7 @@ GM2-COMP-BOOT-MODS = \
M2GCCDeclare.mod \
M2GenGCC.mod \
M2Graph.mod \
+ M2LangDump.mod \
M2LexBuf.mod \
M2MetaError.mod \
M2Optimize.mod \
@@ -886,6 +883,7 @@ GM2-GCC-DEFS = \
m2expr.def \
m2linemap.def \
m2misc.def \
+ m2pp.def \
m2statement.def \
m2top.def \
m2tree.def \
@@ -1040,6 +1038,7 @@ GM2-COMP-DEFS = \
M2GCCDeclare.def \
M2GenGCC.def \
M2Graph.def \
+ M2LangDump.def \
M2LexBuf.def \
M2MetaError.def \
M2Optimize.def \
@@ -1110,6 +1109,7 @@ GM2-COMP-MODS = \
M2GCCDeclare.mod \
M2GenGCC.mod \
M2Graph.mod \
+ M2LangDump.mod \
M2LexBuf.mod \
M2MetaError.mod \
M2Optimize.mod \
diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod
b/gcc/m2/gm2-compiler/M2CaseList.mod
index 08a6052e796..b98f55375bd 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -39,8 +39,8 @@ FROM m2type IMPORT GetMinFrom ;
FROM m2expr IMPORT GetIntegerOne, CSTIntToString, CSTIntToChar ;
FROM Storage IMPORT ALLOCATE ;
FROM M2Base IMPORT IsExpressionCompatible, Char ;
-FROM M2Printf IMPORT printf1 ;
FROM M2LexBuf IMPORT TokenToLocation ;
+FROM NumberIO IMPORT WriteCard ;
FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord,
IsRecordField, GetVarientTag, GetType,
ForeachLocalSymDo, GetSymName, IsEnumeration,
SkipType, NoOfElements, GetNth,
@@ -1191,7 +1191,7 @@ end InRangeList ;
PROCEDURE WriteCase (c: CARDINAL) ;
BEGIN
(* this debugging PROCEDURE should be finished. *)
- printf1 ("%d", c)
+ WriteCard (c, 0)
END WriteCase ;
diff --git a/gcc/m2/gm2-compiler/M2Code.mod b/gcc/m2/gm2-compiler/M2Code.mod
index 010e1d02fca..ea1126d756e 100644
--- a/gcc/m2/gm2-compiler/M2Code.mod
+++ b/gcc/m2/gm2-compiler/M2Code.mod
@@ -23,10 +23,12 @@ IMPLEMENTATION MODULE M2Code ;
FROM SYSTEM IMPORT WORD ;
-FROM M2Options IMPORT Statistics, DisplayQuadruples,
OptimizeUncalledProcedures,
- (* OptimizeDynamic, *) OptimizeCommonSubExpressions,
- StyleChecking, Optimizing, WholeProgram ;
+FROM M2Options IMPORT Statistics, OptimizeUncalledProcedures,
+ OptimizeCommonSubExpressions,
+ StyleChecking, Optimizing, WholeProgram,
+ DumpLangDecl, DumpLangGimple ;
+FROM M2LangDump IMPORT CreateDumpDecl, CloseDumpDecl, MakeGimpleTemplate ;
FROM M2Error IMPORT InternalError ;
FROM M2Students IMPORT StudentVariableCheck ;
@@ -41,7 +43,8 @@ FROM M2Printf IMPORT printf2, printf1, printf0 ;
FROM NameKey IMPORT Name ;
FROM M2Batch IMPORT ForeachSourceModuleDo ;
-FROM M2Quads IMPORT CountQuads, GetFirstQuad, DisplayQuadList,
DisplayQuadRange,
+FROM M2Quads IMPORT CountQuads, GetFirstQuad,
+ DumpQuadruples, DisplayQuadRange,
BackPatchSubrangesAndOptParam,
LoopAnalysis, ForLoopAnalysis, GetQuad, QuadOperator ;
@@ -59,7 +62,8 @@ FROM M2GenGCC IMPORT ConvertQuadsToTree ;
FROM M2GCCDeclare IMPORT FoldConstants, StartDeclareScope,
DeclareProcedure, InitDeclarations,
- DeclareModuleVariables, MarkExported ;
+ DeclareModuleVariables, MarkExported,
+ DumpFilteredResolver, DumpFilteredDefinitive ;
FROM M2Scope IMPORT ScopeBlock, InitScopeBlock, KillScopeBlock,
ForeachScopeBlockDo2, ForeachScopeBlockDo3 ;
@@ -71,12 +75,14 @@ FROM m2flex IMPORT GetTotalLines ;
FROM FIO IMPORT FlushBuffer, StdOut ;
FROM M2Quiet IMPORT qprintf0 ;
FROM M2SSA IMPORT DiscoverSSA ;
+FROM m2pp IMPORT CreateDumpGimple, CloseDumpGimple ;
+FROM DynamicStrings IMPORT String, KillString ;
CONST
- MaxOptimTimes = 10 ; (* upper limit of no of times we run through all
optimization *)
- Debugging = TRUE ;
-
+ MaxOptimTimes = 10 ; (* upper limit of no of times we run through all
optimization *)
+ Debugging = TRUE ;
+ TraceQuadruples = FALSE ;
VAR
Total,
@@ -139,11 +145,7 @@ BEGIN
printf1 ('Total source lines compiled : %6d\n', Count) ;
FlushBuffer (StdOut)
END ;
- IF DisplayQuadruples
- THEN
- printf0 ('after all front end optimization\n') ;
- DisplayQuadList
- END
+ DumpQuadruples ('after all front end optimization\n')
END OptimizationAnalysis ;
@@ -169,11 +171,23 @@ END RemoveUnreachableCode ;
PROCEDURE DoModuleDeclare ;
BEGIN
+ IF DumpLangDecl
+ THEN
+ CreateDumpDecl ("symbol resolver of filtered symbols\n") ;
+ DumpFilteredResolver
+ END ;
IF WholeProgram
THEN
ForeachSourceModuleDo (StartDeclareScope)
ELSE
StartDeclareScope (GetMainModule ())
+ END ;
+ IF DumpLangDecl
+ THEN
+ CloseDumpDecl ;
+ CreateDumpDecl ("definitive declaration of filtered symbols\n") ;
+ DumpFilteredDefinitive ;
+ CloseDumpDecl
END
END DoModuleDeclare ;
@@ -198,11 +212,17 @@ END PrintModule ;
*)
PROCEDURE DoCodeBlock ;
+VAR
+ filename: String ;
+ len : CARDINAL ;
BEGIN
- IF WholeProgram
+ IF DumpLangGimple
THEN
- (* ForeachSourceModuleDo(PrintModule) ; *)
- CodeBlock (GetMainModule ())
+ filename := MakeGimpleTemplate (len) ;
+ CreateDumpGimple (filename, len) ;
+ filename := KillString (filename) ;
+ CodeBlock (GetMainModule ()) ;
+ CloseDumpGimple
ELSE
CodeBlock (GetMainModule ())
END
@@ -231,6 +251,7 @@ END DetermineSubExpTemporaries ;
PROCEDURE Code ;
BEGIN
+ DumpQuadruples ('before any optimization\n') ;
CheckHiddenTypeAreAddress ;
SetPassToNoPass ;
BackPatchSubrangesAndOptParam ;
@@ -238,11 +259,7 @@ BEGIN
ForLoopAnalysis ; (* must be done before any optimization as the index
variable increment quad might change *)
- IF DisplayQuadruples
- THEN
- printf0 ('before any optimization\n') ;
- DisplayQuadList
- END ;
+ DumpQuadruples ('before declaring symbols to gcc\n') ;
(* now is a suitable time to check for student errors as *)
(* we know all the front end symbols must be resolved. *)
@@ -258,20 +275,9 @@ BEGIN
InitDeclarations ; (* default and fixed sized types are all declared
from now on. *)
RemoveUnreachableCode ;
-
- IF DisplayQuadruples
- THEN
- printf0 ('after dead procedure elimination\n') ;
- DisplayQuadList
- END ;
-
+ DumpQuadruples ('after dead procedure elimination\n') ;
DetermineSubExpTemporaries ;
-
- IF DisplayQuadruples
- THEN
- printf0 ('after identifying simple subexpression temporaries\n') ;
- DisplayQuadList
- END ;
+ DumpQuadruples ('after identifying simple subexpression temporaries\n') ;
qprintf0 (' symbols to gcc trees\n') ;
DoModuleDeclare ;
@@ -377,20 +383,6 @@ BEGIN
END Init ;
-(*
- DisplayQuadsInScope -
-*)
-
-(*
-PROCEDURE DisplayQuadsInScope (sb: ScopeBlock) ;
-BEGIN
- printf0 ('Quads in scope\n') ;
- ForeachScopeBlockDo (sb, DisplayQuadRange) ;
- printf0 ('===============\n')
-END DisplayQuadsInScope ;
-*)
-
-
(*
OptimizeScopeBlock -
*)
@@ -416,21 +408,6 @@ BEGIN
END OptimizeScopeBlock ;
-(*
- DisplayQuadNumbers - the range, start..end.
-*)
-
-(*
-PROCEDURE DisplayQuadNumbers (start, end: CARDINAL) ;
-BEGIN
- IF DisplayQuadruples
- THEN
- printf2 ('Coding [%d..%d]\n', start, end)
- END
-END DisplayQuadNumbers ;
-*)
-
-
(*
CodeProceduresWithinBlock - codes the procedures within the module scope.
*)
@@ -465,7 +442,7 @@ VAR
sb: ScopeBlock ;
n : Name ;
BEGIN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
n := GetSymName (scope) ;
printf1 ('before coding block %a\n', n)
@@ -474,7 +451,7 @@ BEGIN
OptimizeScopeBlock (sb) ;
IF IsProcedure (scope)
THEN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
n := GetSymName(scope) ;
printf1('before coding procedure %a\n', n) ;
@@ -484,7 +461,7 @@ BEGIN
ForeachScopeBlockDo2 (sb, ConvertQuadsToTree)
ELSIF IsModuleWithinProcedure(scope)
THEN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
n := GetSymName(scope) ;
printf1('before coding module %a within procedure\n', n) ;
@@ -494,7 +471,7 @@ BEGIN
ForeachScopeBlockDo2 (sb, ConvertQuadsToTree) ;
ForeachProcedureDo(scope, CodeBlock)
ELSE
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
n := GetSymName(scope) ;
printf1('before coding module %a\n', n) ;
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.def
b/gcc/m2/gm2-compiler/M2GCCDeclare.def
index 2e77695678c..28bbb1a41b5 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.def
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.def
@@ -223,6 +223,27 @@ PROCEDURE GetTypeMax (type: CARDINAL) : CARDINAL ;
PROCEDURE PrintSym (sym: CARDINAL) ;
+(*
+ IncludeDumpSymbol - include sym into the watch list and all syms dependants.
+*)
+
+PROCEDURE IncludeDumpSymbol (sym: CARDINAL) ;
+
+
+(*
+ DumpFilteredResolver - dumps the gimple or tree representation of all
watched symbols.
+*)
+
+PROCEDURE DumpFilteredResolver ;
+
+
+(*
+ DumpFilteredDefinitive - dumps the gimple or tree representation of all
watched symbols.
+*)
+
+PROCEDURE DumpFilteredDefinitive ;
+
+
(*
InitDeclarations - initializes default types and the source filename.
*)
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 6f0a749c526..9607085b967 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -35,11 +35,11 @@ FROM ASCII IMPORT nul ;
FROM Storage IMPORT ALLOCATE ;
FROM M2Debug IMPORT Assert ;
FROM M2Quads IMPORT DisplayQuadRange ;
+FROM m2pp IMPORT DumpGimpleFd ;
IMPORT FIO ;
-FROM M2Options IMPORT DisplayQuadruples,
- GenerateDebugging, GenerateLineDebug, Iso, Optimizing,
WholeProgram,
+FROM M2Options IMPORT GenerateDebugging, GenerateLineDebug, Iso, Optimizing,
WholeProgram,
ScaffoldStatic, GetRuntimeModuleOverride ;
FROM M2AsmUtil IMPORT GetFullSymName, GetFullScopeAsmName ;
@@ -52,7 +52,10 @@ FROM FormatStrings IMPORT Sprintf1 ;
FROM M2LexBuf IMPORT TokenToLineNo, FindFileNameFromToken, TokenToLocation,
UnknownTokenNo, BuiltinTokenNo ;
FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3 ;
FROM M2Error IMPORT FlushErrors, InternalError ;
-FROM M2Printf IMPORT printf0, printf1, printf2, printf3 ;
+FROM M2LangDump IMPORT GetDumpFile ;
+
+FROM M2Printf IMPORT printf0, printf1, printf2, printf3,
+ fprintf0, fprintf1, fprintf2, fprintf3 ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, InBounds,
IncludeIndiceIntoIndex, HighIndice,
@@ -206,14 +209,12 @@ TYPE
tobesolvedbyquads, finishedsetarray) ;
doDeclareProcedure = PROCEDURE (CARDINAL, CARDINAL) ;
-
-
CONST
- Debugging = FALSE ;
- Progress = FALSE ;
- EnableSSA = FALSE ;
- EnableWatch = FALSE ;
-
+ Debugging = FALSE ;
+ Progress = FALSE ;
+ EnableSSA = FALSE ;
+ EnableWatch = TRUE ;
+ TraceQuadruples = FALSE ;
TYPE
Group = POINTER TO RECORD
@@ -256,6 +257,7 @@ VAR
PROCEDURE mystop ; BEGIN END mystop ;
+
(* *************************************************** *)
(*
PrintNum -
@@ -340,8 +342,7 @@ BEGIN
THEN
IncludeElementIntoSet (WatchList, sym) ;
WalkDependants (sym, AddSymToWatch) ;
- printf1 ("watching symbol %d\n", sym) ;
- FIO.FlushBuffer (FIO.StdOut)
+ fprintf1 (GetDumpFile (), "%d, ", sym)
END
END AddSymToWatch ;
@@ -377,12 +378,11 @@ PROCEDURE doInclude (l: Set; a: ARRAY OF CHAR; sym:
CARDINAL) ;
BEGIN
IF NOT IsElementInSet(l, sym)
THEN
- printf0('rule: ') ;
+ fprintf0 (GetDumpFile (), 'rule: ') ;
WriteRule ;
- printf0(' ') ;
- printf1(a, sym) ;
- FIO.FlushBuffer(FIO.StdOut) ;
- IncludeElementIntoSet(l, sym)
+ fprintf0 (GetDumpFile (), ' ') ;
+ fprintf1 (GetDumpFile (), a, sym) ;
+ IncludeElementIntoSet (l, sym)
END
END doInclude ;
@@ -420,11 +420,7 @@ BEGIN
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 |
+ todolist : IncludeElementIntoSet (GlobalGroup^.ToDoList, sym) |
niltypedarrays : IncludeElementIntoSet (GlobalGroup^.NilTypedArrays,
sym) |
finishedsetarray : IncludeElementIntoSet
(GlobalGroup^.FinishedSetArray, sym)
@@ -443,11 +439,10 @@ PROCEDURE doExclude (l: Set; a: ARRAY OF CHAR; sym:
CARDINAL) ;
BEGIN
IF IsElementInSet (l, sym)
THEN
- printf0 ('rule: ') ;
+ fprintf0 (GetDumpFile (), 'rule: ') ;
WriteRule ;
- printf0 (' ') ;
- printf1 (a, sym) ;
- FIO.FlushBuffer (FIO.StdOut) ;
+ fprintf0 (GetDumpFile (), ' ') ;
+ fprintf1 (GetDumpFile (), a, sym) ;
ExcludeElementFromSet (l, sym)
END
END doExclude ;
@@ -2784,7 +2779,7 @@ VAR
copy: Group ;
loop: CARDINAL ;
BEGIN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayQuadRange (scope, start, end)
END ;
@@ -2800,7 +2795,7 @@ BEGIN
END ;
IF loop = DebugLoop
THEN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayQuadRange (scope, start, end)
END ;
@@ -3052,41 +3047,6 @@ PROCEDURE StartDeclareScope (scope: CARDINAL) ;
VAR
n: Name ;
BEGIN
- (* AddSymToWatch (8821) ; *)
- (* AddSymToWatch (1157) ; *) (* watch goes here *)
- (* AddSymToWatch(TryFindSymbol('IOLink', 'DeviceId')) ; *)
- (* AddSymToWatch(819) ; *)
- (*
- AddSymToWatch(2125) ; (* watch goes here *)
- DebugSets ;
- *)
- (*
- AddSymToWatch(2125) ; (* watch goes here *)
- *)
- (*
- IncludeElementIntoSet(WatchList, 369) ;
- IncludeElementIntoSet(WatchList, 709) ;
- *)
- (*
- IncludeElementIntoSet(WatchList, 1006) ;
- *)
- (* AddSymToWatch(8) ; *)
- (* IncludeElementIntoSet(WatchList, 4188) ; *)
- (* AddSymToWatch(1420) ; *)
- (* AddSymToWatch(5889) ; *)
- (* IncludeElementIntoSet(WatchList, 717) ; *)
- (* IncludeElementIntoSet(WatchList, 829) ; *)
- (* IncludeElementIntoSet(WatchList, 2714) ; *)
- (* IncludeElementIntoSet(WatchList, 23222) ; *)
- (* IncludeElementIntoSet(WatchList, 1104) ; *)
- (* IncludeElementIntoSet(WatchList, 859) ; *)
- (* IncludeElementIntoSet(WatchList, 858) ; *)
-
- (* IncludeElementIntoSet(WatchList, 720) ; *)
- (* IncludeElementIntoSet(WatchList, 706) ; *)
- (* IncludeElementIntoSet(WatchList, 1948) ; *)
- (* IncludeElementIntoSet(WatchList, 865) ; *)
-
IF Debugging
THEN
n := GetSymName (scope) ;
@@ -3117,15 +3077,83 @@ END EndDeclareScope ;
(*
- PreAddModGcc - adds a relationship between sym and t.
- It also determines whether an unbounded
- for sym is required and if so this is also
- created.
+ IncludeDumpSymbol - include sym into the watch list and all syms dependants.
+*)
+
+PROCEDURE IncludeDumpSymbol (sym: CARDINAL) ;
+BEGIN
+ IF sym # NulSym
+ THEN
+ AddSymToWatch (sym)
+ (*
+ fprintf0 (GetDumpFile (), "\n") ;
+ PrintVerbose (sym) ;
+ fprintf0 (GetDumpFile (), "\n")
+ *)
+ END
+END IncludeDumpSymbol ;
+
+
+(*
+ DumpResolver - dumps the m2 representation of sym.
+*)
+
+PROCEDURE DumpResolver (sym: CARDINAL) ;
+BEGIN
+ fprintf1 (GetDumpFile (), "dump filtered symbol %d and dependants\n", sym) ;
+ PrintVerbose (sym) ;
+END DumpResolver ;
+
+
+(*
+ DumpFilteredResolver - dumps the gimple or tree representation of all
watched symbols.
+*)
+
+PROCEDURE DumpFilteredResolver ;
+BEGIN
+ ForeachElementInSetDo (WatchList, DumpResolver)
+END DumpFilteredResolver ;
+
+
+(*
+ DumpDefinitive - dumps the m2 and m2 gimple representation of sym.
+*)
+
+PROCEDURE DumpDefinitive (sym: CARDINAL) ;
+VAR
+ fd: INTEGER ;
+BEGIN
+ fprintf1 (GetDumpFile (), "\nm2 symbol synopsis: %d\n", sym) ;
+ PrintVerbose (sym) ;
+ IF GccKnowsAbout (sym)
+ THEN
+ fprintf1 (GetDumpFile (), "\nm2 gimple: %d", sym) ;
+ FIO.FlushBuffer (GetDumpFile ()) ;
+ fd := FIO.GetUnixFileDescriptor (GetDumpFile ()) ;
+ DumpGimpleFd (fd, Mod2Gcc (sym))
+ ELSE
+ fprintf1 (GetDumpFile (), "\nno m2 gimple for %d\n", sym)
+ END
+END DumpDefinitive ;
+
+
+(*
+ DumpFilteredDefinitive - dumps the gimple or tree representation of all
watched symbols.
+*)
+
+PROCEDURE DumpFilteredDefinitive ;
+BEGIN
+ ForeachElementInSetDo (WatchList, DumpDefinitive)
+END DumpFilteredDefinitive ;
+
+
+(*
+ PreAddModGcc - adds a relationship between sym and tree.
*)
-PROCEDURE PreAddModGcc (sym: CARDINAL; t: Tree) ;
+PROCEDURE PreAddModGcc (sym: CARDINAL; tree: Tree) ;
BEGIN
- AddModGcc(sym, t)
+ AddModGcc (sym, tree)
END PreAddModGcc ;
@@ -3829,18 +3857,18 @@ PROCEDURE IncludeGetNth (l: List; sym: CARDINAL) ;
VAR
i: CARDINAL ;
BEGIN
- printf0 (' ListOfSons [') ;
+ fprintf0 (GetDumpFile (), ' ListOfSons [') ;
i := 1 ;
WHILE GetNth (sym, i) # NulSym DO
IF i>1
THEN
- printf0 (', ')
+ fprintf0 (GetDumpFile (), ', ')
END ;
IncludeItemIntoList (l, GetNth(sym, i)) ;
PrintTerse (GetNth (sym, i)) ;
INC (i)
END ;
- printf0 (']')
+ fprintf0 (GetDumpFile (), ']')
END IncludeGetNth ;
@@ -3855,17 +3883,17 @@ BEGIN
t := GetSType(sym) ;
IF t#NulSym
THEN
- printf0(' type [') ;
+ fprintf0 (GetDumpFile(), ' type [') ;
PrintTerse(t) ;
IncludeItemIntoList(l, t) ;
- printf0(']') ;
+ fprintf0 (GetDumpFile(), ']') ;
t := GetVarBackEndType(sym) ;
IF t#NulSym
THEN
- printf0(' gcc type [') ;
+ fprintf0 (GetDumpFile(), ' gcc type [') ;
PrintTerse(t) ;
IncludeItemIntoList(l, t) ;
- printf0(']')
+ fprintf0 (GetDumpFile(), ']')
END
END
END IncludeType ;
@@ -3882,10 +3910,10 @@ BEGIN
t := GetArraySubscript(sym) ;
IF t#NulSym
THEN
- printf0(' subrange [') ;
+ fprintf0 (GetDumpFile(), ' subrange [') ;
PrintTerse(t) ;
IncludeItemIntoList(l, t) ;
- printf0(']') ;
+ fprintf0 (GetDumpFile(), ']') ;
END
END IncludeSubscript ;
@@ -3896,7 +3924,7 @@ END IncludeSubscript ;
PROCEDURE PrintLocalSymbol (sym: CARDINAL) ;
BEGIN
- PrintTerse(sym) ; printf0(', ')
+ PrintTerse(sym) ; fprintf0 (GetDumpFile(), ', ')
END PrintLocalSymbol ;
@@ -3906,9 +3934,9 @@ END PrintLocalSymbol ;
PROCEDURE PrintLocalSymbols (sym: CARDINAL) ;
BEGIN
- printf0('Local Symbols {') ;
+ fprintf0 (GetDumpFile(), 'Local Symbols {') ;
ForeachLocalSymDo(sym, PrintLocalSymbol) ;
- printf0('}')
+ fprintf0 (GetDumpFile(), '}')
END PrintLocalSymbols ;
@@ -3920,9 +3948,9 @@ PROCEDURE IncludeGetVarient (l: List; sym: CARDINAL) ;
BEGIN
IF GetVarient(sym)#NulSym
THEN
- printf0(' Varient [') ;
+ fprintf0 (GetDumpFile(), ' Varient [') ;
PrintTerse(GetVarient(sym)) ;
- printf0(']') ;
+ fprintf0 (GetDumpFile(), ']') ;
IncludeItemIntoList(l, GetVarient(sym))
END
END IncludeGetVarient ;
@@ -3967,7 +3995,7 @@ BEGIN
tokenno := GetDeclaredMod(sym) ;
filename := FindFileNameFromToken(tokenno, 0) ;
lineno := TokenToLineNo(tokenno, 0) ;
- printf2(" declared in %s:%d", filename, lineno)
+ fprintf2 (GetDumpFile (), " declared in %s:%d", filename, lineno)
END PrintDeclared ;
@@ -3984,7 +4012,7 @@ BEGIN
align := GetAlignment(sym) ;
IF align#NulSym
THEN
- printf1(" aligned [%d]", align)
+ fprintf1 (GetDumpFile(), " aligned [%d]", align)
END
END
END PrintAlignment ;
@@ -3996,10 +4024,10 @@ END PrintAlignment ;
PROCEDURE IncludeGetParent (l: List; sym: CARDINAL) ;
BEGIN
- printf0(' Parent [') ;
+ fprintf0 (GetDumpFile(), ' Parent [') ;
IncludeItemIntoList(l, GetParent(sym)) ;
PrintTerse(GetParent(sym)) ;
- printf0(']')
+ fprintf0 (GetDumpFile(), ']')
END IncludeGetParent ;
@@ -4013,12 +4041,12 @@ BEGIN
THEN
IF IsDeclaredPacked(sym)
THEN
- printf0(' packed')
+ fprintf0 (GetDumpFile(), ' packed')
ELSE
- printf0(' unpacked')
+ fprintf0 (GetDumpFile(), ' unpacked')
END
ELSE
- printf0(' unknown if packed')
+ fprintf0 (GetDumpFile(), ' unknown if packed')
END
END PrintDecl ;
@@ -4036,7 +4064,7 @@ BEGIN
line := TokenToLineNo (GetDeclaredMod (sym), 0) ;
scope := GetScope (sym) ;
name := GetSymName (scope) ;
- printf3 (' scope %a:%d %d', name, line, scope)
+ fprintf3 (GetDumpFile (), ' scope %a:%d %d', name, line, scope)
END PrintScope ;
@@ -4049,23 +4077,23 @@ VAR
n: Name ;
BEGIN
n := GetSymName (sym) ;
- printf2('sym %d IsProcedure (%a)', sym, n);
+ fprintf2 (GetDumpFile (), 'sym %d IsProcedure (%a)', sym, n);
IF IsProcedureReachable(sym)
THEN
- printf0(' IsProcedureReachable')
+ fprintf0 (GetDumpFile(), ' IsProcedureReachable')
END ;
PrintScope (sym) ;
IF IsExtern (sym)
THEN
- printf0 (' extern')
+ fprintf0 (GetDumpFile (), ' extern')
END ;
IF IsPublic (sym)
THEN
- printf0 (' public')
+ fprintf0 (GetDumpFile (), ' public')
END ;
IF IsCtor (sym)
THEN
- printf0 (' ctor')
+ fprintf0 (GetDumpFile (), ' ctor')
END ;
PrintDeclared(sym)
END PrintProcedure ;
@@ -4084,22 +4112,22 @@ BEGIN
THEN
IF IsConstStringM2 (sym)
THEN
- printf0 ('a Modula-2 string')
+ fprintf0 (GetDumpFile (), 'a Modula-2 string')
ELSIF IsConstStringC (sym)
THEN
- printf0 (' a C string')
+ fprintf0 (GetDumpFile (), ' a C string')
ELSIF IsConstStringM2nul (sym)
THEN
- printf0 (' a nul terminated Modula-2 string')
+ fprintf0 (GetDumpFile (), ' a nul terminated Modula-2 string')
ELSIF IsConstStringCnul (sym)
THEN
- printf0 (' a nul terminated C string')
+ fprintf0 (GetDumpFile (), ' a nul terminated C string')
END ;
tokenno := GetDeclaredMod (sym) ;
len := GetStringLength (tokenno, sym) ;
- printf1 (' length %d', len)
+ fprintf1 (GetDumpFile (), ' length %d', len)
ELSE
- printf0 ('is not currently known')
+ fprintf0 (GetDumpFile (), 'is not currently known')
END
END PrintString ;
@@ -4120,35 +4148,35 @@ BEGIN
n := GetSymName(sym) ;
IF IsError(sym)
THEN
- printf2('sym %d IsError (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsError (%a)', sym, n)
ELSIF IsDefImp(sym)
THEN
- printf2('sym %d IsDefImp (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsDefImp (%a)', sym, n) ;
IF IsDefinitionForC(sym)
THEN
- printf0('and IsDefinitionForC')
+ fprintf0 (GetDumpFile(), 'and IsDefinitionForC')
END ;
IF IsHiddenTypeDeclared(sym)
THEN
- printf0(' IsHiddenTypeDeclared')
+ fprintf0 (GetDumpFile(), ' IsHiddenTypeDeclared')
END ;
ForeachProcedureDo (sym, PrintProcedure)
ELSIF IsModule(sym)
THEN
- printf2('sym %d IsModule (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsModule (%a)', sym, n) ;
IF IsModuleWithinProcedure(sym)
THEN
- printf0(' and IsModuleWithinProcedure')
+ fprintf0 (GetDumpFile(), ' and IsModuleWithinProcedure')
END
ELSIF IsInnerModule(sym)
THEN
- printf2('sym %d IsInnerModule (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsInnerModule (%a)', sym, n)
ELSIF IsUnknown(sym)
THEN
- printf2('sym %d IsUnknown (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsUnknown (%a)', sym, n)
ELSIF IsType(sym)
THEN
- printf2('sym %d IsType (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsType (%a)', sym, n) ;
IncludeType(l, sym) ;
PrintAlignment(sym)
ELSIF IsProcedure(sym)
@@ -4156,72 +4184,72 @@ BEGIN
PrintProcedure (sym)
ELSIF IsParameter(sym)
THEN
- printf2('sym %d IsParameter (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsParameter (%a)', sym, n) ;
IF GetParameterShadowVar(sym)=NulSym
THEN
- printf0(' no shadow local variable')
+ fprintf0 (GetDumpFile(), ' no shadow local variable')
ELSE
- printf0(' shadow ') ;
+ fprintf0 (GetDumpFile(), ' shadow ') ;
IncludeType(l, GetParameterShadowVar(sym))
(* PrintVerboseFromList(l, GetParameterShadowVar(sym)) *)
END ;
IncludeType(l, sym)
ELSIF IsPointer(sym)
THEN
- printf2('sym %d IsPointer (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsPointer (%a)', sym, n) ;
IncludeType(l, sym) ;
PrintAlignment(sym)
ELSIF IsRecord(sym)
THEN
- printf2('sym %d IsRecord (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsRecord (%a)', sym, n) ;
PrintLocalSymbols(sym) ;
IncludeGetNth(l, sym) ;
PrintAlignment(sym) ;
PrintDecl(sym)
ELSIF IsVarient(sym)
THEN
- printf2('sym %d IsVarient (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsVarient (%a)', sym, n) ;
PrintDecl(sym) ;
IncludeGetNth(l, sym) ;
IncludeGetVarient(l, sym) ;
IncludeGetParent(l, sym)
ELSIF IsFieldVarient(sym)
THEN
- printf2('sym %d IsFieldVarient (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsFieldVarient (%a)', sym, n) ;
PrintDecl(sym) ;
IncludeGetNth(l, sym) ;
IncludeGetVarient(l, sym) ;
IncludeGetParent(l, sym)
ELSIF IsFieldEnumeration(sym)
THEN
- printf2('sym %d IsFieldEnumeration (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsFieldEnumeration (%a)', sym, n)
ELSIF IsArray(sym)
THEN
- printf2('sym %d IsArray (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsArray (%a)', sym, n) ;
IncludeSubscript(l, sym) ;
IncludeType(l, sym) ;
PrintAlignment(sym)
ELSIF IsEnumeration(sym)
THEN
- printf2('sym %d IsEnumeration (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsEnumeration (%a)', sym, n)
ELSIF IsSet(sym)
THEN
- printf2('sym %d IsSet (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsSet (%a)', sym, n) ;
IncludeType(l, sym)
ELSIF IsUnbounded(sym)
THEN
- printf2('sym %d IsUnbounded (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsUnbounded (%a)', sym, n) ;
IncludeUnbounded(l, sym)
ELSIF IsPartialUnbounded(sym)
THEN
- printf2('sym %d IsPartialUnbounded (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsPartialUnbounded (%a)', sym, n) ;
IncludePartialUnbounded(l, sym)
ELSIF IsRecordField(sym)
THEN
- printf2('sym %d IsRecordField (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsRecordField (%a)', sym, n) ;
IF IsRecordFieldAVarientTag(sym)
THEN
- printf0(' variant tag')
+ fprintf0 (GetDumpFile(), ' variant tag')
END ;
IncludeType(l, sym) ;
IncludeGetVarient(l, sym) ;
@@ -4230,76 +4258,76 @@ BEGIN
PrintDecl(sym)
ELSIF IsProcType(sym)
THEN
- printf2('sym %d IsProcType (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsProcType (%a)', sym, n)
ELSIF IsVar(sym)
THEN
- printf2('sym %d IsVar (%a) declared in ', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsVar (%a) declared in ', sym, n) ;
PrintScope (sym) ;
- printf0 ('mode ') ;
+ fprintf0 (GetDumpFile (), 'mode ') ;
CASE GetMode(sym) OF
- LeftValue : printf0('l ') |
- RightValue : printf0('r ') |
- ImmediateValue: printf0('i ') |
- NoValue : printf0('n ')
+ LeftValue : fprintf0 (GetDumpFile(), 'l ') |
+ RightValue : fprintf0 (GetDumpFile(), 'r ') |
+ ImmediateValue: fprintf0 (GetDumpFile(), 'i ') |
+ NoValue : fprintf0 (GetDumpFile(), 'n ')
END ;
IF IsTemporary(sym)
THEN
- printf0('temporary ')
+ fprintf0 (GetDumpFile(), 'temporary ')
END ;
IF IsComponent(sym)
THEN
- printf0('component ')
+ fprintf0 (GetDumpFile(), 'component ')
END ;
IF IsVarHeap (sym)
THEN
- printf0('heap ')
+ fprintf0 (GetDumpFile(), 'heap ')
END ;
- printf0 ('\n') ;
+ fprintf0 (GetDumpFile (), '\n') ;
PrintInitialized (sym) ;
IncludeType(l, sym)
ELSIF IsConst(sym)
THEN
- printf2('sym %d IsConst (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsConst (%a)', sym, n) ;
IF IsConstString(sym)
THEN
- printf1 (' also IsConstString (%a) ', n) ;
+ fprintf1 (GetDumpFile(), ' also IsConstString (%a)', n) ;
PrintString (sym)
ELSIF IsConstructor(sym)
THEN
- printf0(' constant constructor ') ;
+ fprintf0 (GetDumpFile(), ' constant constructor ') ;
IncludeType(l, sym)
ELSIF IsConstSet(sym)
THEN
- printf0(' constant constructor set ') ;
+ fprintf0 (GetDumpFile(), ' constant constructor set ') ;
IncludeType(l, sym)
ELSE
IncludeType(l, sym)
END
ELSIF IsConstructor(sym)
THEN
- printf2('sym %d IsConstructor (non constant) (%a)', sym, n) ;
+ fprintf2 (GetDumpFile(), 'sym %d IsConstructor (non constant) (%a)',
sym, n) ;
IncludeType(l, sym)
ELSIF IsConstLit(sym)
THEN
- printf2('sym %d IsConstLit (%a)', sym, n)
+ fprintf2 (GetDumpFile(), 'sym %d IsConstLit (%a)', sym, n)
ELSIF IsDummy(sym)
THEN
- printf2('sym %d IsDummy (%a)', sym, n)
+ fprintf2 (GetDumpFile(), 'sym %d IsDummy (%a)', sym, n)
ELSIF IsTemporary(sym)
THEN
- printf2('sym %d IsTemporary (%a)', sym, n)
+ fprintf2 (GetDumpFile(), 'sym %d IsTemporary (%a)', sym, n)
ELSIF IsVarAParam(sym)
THEN
- printf2('sym %d IsVarAParam (%a)', sym, n)
+ fprintf2 (GetDumpFile(), 'sym %d IsVarAParam (%a)', sym, n)
ELSIF IsSubscript(sym)
THEN
- printf2('sym %d IsSubscript (%a)', sym, n)
+ fprintf2 (GetDumpFile(), 'sym %d IsSubscript (%a)', sym, n)
ELSIF IsSubrange(sym)
THEN
GetSubrange(sym, high, low) ;
- printf2('sym %d IsSubrange (%a)', sym, n) ;
+ fprintf2 (GetDumpFile(), 'sym %d IsSubrange (%a)', sym, n) ;
IF (low#NulSym) AND (high#NulSym)
THEN
type := GetSType(sym) ;
@@ -4307,41 +4335,41 @@ BEGIN
THEN
IncludeType(l, sym) ;
n := GetSymName(type) ;
- printf1(' %a', n)
+ fprintf1 (GetDumpFile(), ' %a', n)
END ;
n := GetSymName(low) ;
n2 := GetSymName(high) ;
- printf2('[%a..%a]', n, n2)
+ fprintf2 (GetDumpFile (), '[%a..%a]', n, n2)
END
ELSIF IsProcedureVariable(sym)
THEN
- printf2('sym %d IsProcedureVariable (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsProcedureVariable (%a)', sym, n)
ELSIF IsProcedureNested(sym)
THEN
- printf2('sym %d IsProcedureNested (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsProcedureNested (%a)', sym, n)
ELSIF IsAModula2Type(sym)
THEN
- printf2('sym %d IsAModula2Type (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsAModula2Type (%a)', sym, n)
ELSIF IsObject(sym)
THEN
- printf2('sym %d IsObject (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsObject (%a)', sym, n)
ELSIF IsTuple(sym)
THEN
- printf2('sym %d IsTuple (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsTuple (%a)', sym, n) ;
low := GetNth(sym, 1) ;
high := GetNth(sym, 2) ;
- printf2('%d, %d\n', low, high)
+ fprintf2 (GetDumpFile (), '%d, %d\n', low, high)
ELSIF IsGnuAsm(sym)
THEN
IF IsGnuAsmVolatile(sym)
THEN
- printf2('sym %d IsGnuAsmVolatile (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsGnuAsmVolatile (%a)', sym, n)
ELSE
- printf2('sym %d IsGnuAsm (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsGnuAsm (%a)', sym, n)
END
ELSIF IsComponent(sym)
THEN
- printf2('sym %d IsComponent (%a) ', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsComponent (%a) ', sym, n) ;
i := 1 ;
REPEAT
type := GetNth(sym, i) ;
@@ -4349,7 +4377,7 @@ BEGIN
THEN
IncludeItemIntoList(l, type) ;
n := GetSymName(type) ;
- printf2("[%a %d] ", n, type) ;
+ fprintf2 (GetDumpFile (), "[%a %d] ", n, type) ;
INC(i)
END ;
UNTIL type=NulSym
@@ -4357,9 +4385,9 @@ BEGIN
IF IsHiddenType(sym)
THEN
- printf0(' IsHiddenType')
+ fprintf0 (GetDumpFile(), ' IsHiddenType')
END ;
- printf0('\n')
+ fprintf0 (GetDumpFile(), '\n')
END PrintVerboseFromList ;
@@ -4391,7 +4419,7 @@ END PrintVerbose ;
PROCEDURE PrintSym (sym: CARDINAL) ;
BEGIN
printf1 ('information about symbol: %d\n', sym) ;
- printf0 ('==============================\n') ;
+ fprintf0 (GetDumpFile (), '==============================\n') ;
PrintVerbose (sym)
END PrintSym ;
@@ -4404,7 +4432,7 @@ END PrintSym ;
PROCEDURE PrintSymbol (sym: CARDINAL) ;
BEGIN
PrintTerse(sym) ;
- printf0('\n')
+ fprintf0 (GetDumpFile(), '\n')
END PrintSymbol ;
******************************************* *)
@@ -4419,127 +4447,127 @@ BEGIN
n := GetSymName(sym) ;
IF IsError(sym)
THEN
- printf2('sym %d IsError (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsError (%a)', sym, n)
ELSIF IsDefImp(sym)
THEN
- printf2('sym %d IsDefImp (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsDefImp (%a)', sym, n) ;
IF IsDefinitionForC(sym)
THEN
- printf0('and IsDefinitionForC')
+ fprintf0 (GetDumpFile(), 'and IsDefinitionForC')
END ;
IF IsHiddenTypeDeclared(sym)
THEN
- printf0(' IsHiddenTypeDeclared')
+ fprintf0 (GetDumpFile(), ' IsHiddenTypeDeclared')
END
ELSIF IsModule(sym)
THEN
- printf2('sym %d IsModule (%a)', sym, n) ;
+ fprintf2 (GetDumpFile (), 'sym %d IsModule (%a)', sym, n) ;
IF IsModuleWithinProcedure(sym)
THEN
- printf0(' and IsModuleWithinProcedure')
+ fprintf0 (GetDumpFile(), ' and IsModuleWithinProcedure')
END
ELSIF IsInnerModule(sym)
THEN
- printf2('sym %d IsInnerModule (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsInnerModule (%a)', sym, n)
ELSIF IsUnknown(sym)
THEN
- printf2('sym %d IsUnknown (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsUnknown (%a)', sym, n)
ELSIF IsType(sym)
THEN
- printf2('sym %d IsType (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsType (%a)', sym, n)
ELSIF IsProcedure(sym)
THEN
- printf2('sym %d IsProcedure (%a)', sym, n);
+ fprintf2 (GetDumpFile (), 'sym %d IsProcedure (%a)', sym, n);
IF IsProcedureReachable(sym)
THEN
- printf0(' and IsProcedureReachable')
+ fprintf0 (GetDumpFile(), ' and IsProcedureReachable')
END
ELSIF IsParameter(sym)
THEN
- printf2('sym %d IsParameter (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsParameter (%a)', sym, n)
ELSIF IsPointer(sym)
THEN
- printf2('sym %d IsPointer (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsPointer (%a)', sym, n)
ELSIF IsRecord(sym)
THEN
- printf2('sym %d IsRecord (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsRecord (%a)', sym, n)
ELSIF IsVarient(sym)
THEN
- printf2('sym %d IsVarient (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsVarient (%a)', sym, n)
ELSIF IsFieldVarient(sym)
THEN
- printf2('sym %d IsFieldVarient (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsFieldVarient (%a)', sym, n)
ELSIF IsFieldEnumeration(sym)
THEN
- printf2('sym %d IsFieldEnumeration (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsFieldEnumeration (%a)', sym, n)
ELSIF IsArray(sym)
THEN
- printf2('sym %d IsArray (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsArray (%a)', sym, n)
ELSIF IsEnumeration(sym)
THEN
- printf2('sym %d IsEnumeration (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsEnumeration (%a)', sym, n)
ELSIF IsSet(sym)
THEN
- printf2('sym %d IsSet (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsSet (%a)', sym, n)
ELSIF IsUnbounded(sym)
THEN
- printf2('sym %d IsUnbounded (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsUnbounded (%a)', sym, n)
ELSIF IsRecordField(sym)
THEN
- printf2('sym %d IsRecordField (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsRecordField (%a)', sym, n)
ELSIF IsProcType(sym)
THEN
- printf2('sym %d IsProcType (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsProcType (%a)', sym, n)
ELSIF IsVar(sym)
THEN
- printf2('sym %d IsVar (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsVar (%a)', sym, n)
ELSIF IsConstString(sym)
THEN
- printf2('sym %d IsConstString (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsConstString (%a)', sym, n)
ELSIF IsConst(sym)
THEN
- printf2('sym %d IsConst (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsConst (%a)', sym, n)
ELSIF IsConstLit(sym)
THEN
- printf2('sym %d IsConstLit (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsConstLit (%a)', sym, n)
ELSIF IsDummy(sym)
THEN
- printf2('sym %d IsDummy (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsDummy (%a)', sym, n)
ELSIF IsTemporary(sym)
THEN
- printf2('sym %d IsTemporary (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsTemporary (%a)', sym, n)
ELSIF IsVarAParam(sym)
THEN
- printf2('sym %d IsVarAParam (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsVarAParam (%a)', sym, n)
ELSIF IsSubscript(sym)
THEN
- printf2('sym %d IsSubscript (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsSubscript (%a)', sym, n)
ELSIF IsSubrange(sym)
THEN
- printf2('sym %d IsSubrange (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsSubrange (%a)', sym, n)
ELSIF IsProcedureVariable(sym)
THEN
- printf2('sym %d IsProcedureVariable (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsProcedureVariable (%a)', sym, n)
ELSIF IsProcedureNested(sym)
THEN
- printf2('sym %d IsProcedureNested (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsProcedureNested (%a)', sym, n)
ELSIF IsAModula2Type(sym)
THEN
- printf2('sym %d IsAModula2Type (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsAModula2Type (%a)', sym, n)
ELSIF IsGnuAsm(sym)
THEN
- printf2('sym %d IsGnuAsm (%a)', sym, n)
+ fprintf2 (GetDumpFile (), 'sym %d IsGnuAsm (%a)', sym, n)
ELSIF IsImport (sym)
THEN
- printf1('sym %d IsImport', sym)
+ fprintf1 (GetDumpFile(), 'sym %d IsImport', sym)
ELSIF IsImportStatement (sym)
THEN
- printf1('sym %d IsImportStatement', sym)
+ fprintf1 (GetDumpFile(), 'sym %d IsImportStatement', sym)
END ;
IF IsHiddenType(sym)
THEN
- printf0(' IsHiddenType')
+ fprintf0 (GetDumpFile(), ' IsHiddenType')
END
END PrintTerse ;
diff --git a/gcc/m2/gm2-compiler/M2LangDump.def
b/gcc/m2/gm2-compiler/M2LangDump.def
new file mode 100644
index 00000000000..5d4c9b600a1
--- /dev/null
+++ b/gcc/m2/gm2-compiler/M2LangDump.def
@@ -0,0 +1,102 @@
+(* M2LangDump.def provides support routines for the -flang-dump.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusm...@gmail.com>.
+
+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/>. *)
+
+DEFINITION MODULE M2LangDump ;
+
+FROM m2tree IMPORT Tree ;
+FROM DynamicStrings IMPORT String ;
+FROM FIO IMPORT File ;
+
+
+(*
+ IsDumpRequiredTree - return TRUE if the gcc tree should be dumped.
+ If no filter is specified it will always return
default.
+*)
+
+PROCEDURE IsDumpRequiredTree (tree: Tree; default: BOOLEAN) : BOOLEAN ;
+
+
+(*
+ IsDumpRequired - return TRUE if symbol sym should be dumped
+ according to the rules of the filter.
+ If no filter is specified it will always return default.
+ The filter is a comma separated list. Each element
+ of the list can specify a symbol three ways.
+ Firstly by DECL name for example: m2pim_NumberIO_HexToStr
+ Secondly by qualified scope: [pathname.]NumberIO.HexToStr
+ Thirdly by filename and scope: NumberIO.mod:HexToStr
+*)
+
+PROCEDURE IsDumpRequired (sym: CARDINAL; default: BOOLEAN) : BOOLEAN ;
+
+
+(*
+ MakeQuadTemplate - return a template for the quad dump file.
+*)
+
+PROCEDURE MakeQuadTemplate () : String ;
+
+
+(*
+ MakeGimpleTemplate - return a template for the gimple dump file and assign
+ len to the max number of characters required to
complete
+ a template.
+*)
+
+PROCEDURE MakeGimpleTemplate (VAR len: CARDINAL) : String ;
+
+
+(*
+ GetDumpFile - return the dump output file.
+*)
+
+PROCEDURE GetDumpFile () : File ;
+
+
+(*
+ CreateDumpQuad - create the dump file for a quad dump.
+*)
+
+PROCEDURE CreateDumpQuad (title: ARRAY OF CHAR) ;
+
+
+(*
+ CloseDumpQuad - close the dump output file.
+*)
+
+PROCEDURE CloseDumpQuad ;
+
+
+(*
+ CreateDumpDecl - create the dump file for a decl dump.
+*)
+
+PROCEDURE CreateDumpDecl (title: ARRAY OF CHAR) ;
+
+
+(*
+ CloseDumpDecl - close the dump output file.
+*)
+
+PROCEDURE CloseDumpDecl ;
+
+
+END M2LangDump.
diff --git a/gcc/m2/gm2-compiler/M2LangDump.mod
b/gcc/m2/gm2-compiler/M2LangDump.mod
new file mode 100644
index 00000000000..17fab86bc0b
--- /dev/null
+++ b/gcc/m2/gm2-compiler/M2LangDump.mod
@@ -0,0 +1,802 @@
+(* M2LangDump.mod provides support routines for the -flang-dump.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusm...@gmail.com>.
+
+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 M2LangDump ;
+
+FROM SYSTEM IMPORT ADDRESS ;
+
+FROM DynamicStrings IMPORT String, Length, InitString, Mark, Slice, EqualArray,
+ InitStringCharStar, ConCatChar, ConCat, KillString,
+ Dup, string, char, Index, ReverseIndex, RIndex,
Equal,
+ PushAllocation, PopAllocationExemption ;
+
+FROM SymbolTable IMPORT NulSym,
+ GetSymName, GetLibName,
+ GetScope, GetModuleScope, GetMainModule,
GetDeclaredMod,
+ GetLocalSym,
+ IsInnerModule,
+ IsVar,
+ IsProcedure,
+ IsModule, IsDefImp,
+ IsExportQualified, IsExportUnQualified,
+ IsExported, IsPublic, IsExtern, IsMonoName,
+ IsDefinitionForC ;
+
+FROM M2Options IMPORT GetM2DumpFilter, GetDumpDir, GetDumpLangQuadFilename,
+ GetDumpLangDeclFilename, GetDumpLangGimpleFilename ;
+
+FROM M2GCCDeclare IMPORT IncludeDumpSymbol ;
+FROM FormatStrings IMPORT Sprintf0, Sprintf1 ;
+FROM NameKey IMPORT Name, GetKey, MakeKey, makekey, KeyToCharStar, NulName ;
+FROM SymbolConversion IMPORT Gcc2Mod, Mod2Gcc ;
+FROM M2AsmUtil IMPORT GetFullScopeAsmName ;
+FROM M2LexBuf IMPORT FindFileNameFromToken ;
+FROM M2Printf IMPORT fprintf0, fprintf1, printf0, printf1, printf2 ;
+FROM M2Error IMPORT InternalError ;
+FROM M2Batch IMPORT Get ;
+FROM StrLib IMPORT StrLen ;
+FROM libc IMPORT printf ;
+
+IMPORT FIO, SFIO, DynamicStrings, StdIO ;
+
+
+CONST
+ Debugging = FALSE ;
+
+VAR
+ outputFile : FIO.File ;
+ declActive,
+ quadActive,
+ mustClose : BOOLEAN ;
+ NoOfQuadDumps,
+ NoOfDeclDumps: CARDINAL ;
+
+
+(*
+ Assert - call InternalError is NOT value.
+*)
+
+PROCEDURE Assert (value: BOOLEAN) ;
+BEGIN
+ IF NOT value
+ THEN
+ InternalError ('assert failed in M2LangDump')
+ END
+END Assert ;
+
+
+(*
+ DumpWrite - writes a single ch to the dump output.
+*)
+
+PROCEDURE DumpWrite (ch: CHAR) ;
+BEGIN
+ FIO.WriteChar (outputFile, ch)
+END DumpWrite ;
+
+
+(*
+ CloseDump - close the dump file and pop the default write procedure.
+*)
+
+PROCEDURE CloseDump ;
+BEGIN
+ IF mustClose
+ THEN
+ FIO.Close (outputFile) ;
+ mustClose := FALSE
+ ELSE
+ FIO.FlushBuffer (outputFile)
+ END ;
+ StdIO.PopOutput ;
+ outputFile := FIO.StdOut ;
+END CloseDump ;
+
+
+(*
+ OpenDump - open filename as a dump file. The filename '-' is treated as
stdout.
+ It pushes a write procedure to StdIO.
+*)
+
+PROCEDURE OpenDump (filename: String; no: CARDINAL) ;
+BEGIN
+ IF DynamicStrings.EqualArray (filename, '-')
+ THEN
+ mustClose := FALSE ;
+ outputFile := FIO.StdOut
+ ELSE
+ filename := Sprintf1 (filename, no) ;
+ outputFile := SFIO.OpenToWrite (filename) ;
+ mustClose := FIO.IsNoError (outputFile)
+ END ;
+ filename := KillString (filename) ;
+ StdIO.PushOutput (DumpWrite)
+END OpenDump ;
+
+
+(*
+ CloseDumpDecl - close the dump output file.
+*)
+
+PROCEDURE CloseDumpDecl ;
+BEGIN
+ IF declActive
+ THEN
+ CloseDump ;
+ declActive := FALSE
+ END
+END CloseDumpDecl ;
+
+
+(*
+ AddRuleTextDump -
+*)
+
+PROCEDURE AddRuleTextDump (rule: String) ;
+BEGIN
+
+END AddRuleTextDump ;
+
+
+(*
+ AddRuleScopeQualidentDump -
+*)
+
+PROCEDURE AddRuleScopeQualidentDump (rule: String; dot: INTEGER; modsym:
CARDINAL) ;
+VAR
+ modstr,
+ idstr : String ;
+ start : INTEGER ;
+ sym : CARDINAL ;
+BEGIN
+ start := dot + 1 ;
+ dot := Index (rule, '.', start) ;
+ WHILE dot > 0 DO
+ modstr := Slice (rule, start, dot) ;
+ modsym := GetLocalSym (modsym, makekey (string (modstr))) ;
+ IF (modsym # NulSym) AND IsModule (modsym)
+ THEN
+ start := dot + 1 ;
+ dot := Index (rule, '.', start)
+ ELSE
+ modstr := KillString (modstr) ;
+ RETURN
+ END
+ END ;
+ idstr := Slice (rule, start, 0) ;
+ sym := GetLocalSym (modsym, makekey (string (idstr))) ;
+ IF sym # NulSym
+ THEN
+ IncludeDumpSymbol (sym)
+ END
+END AddRuleScopeQualidentDump ;
+
+
+(*
+ AddRuleScopeDump -
+*)
+
+PROCEDURE AddRuleScopeDump (rule: String) ;
+VAR
+ modsym: CARDINAL ;
+ libstr,
+ modstr: String ;
+ start,
+ dot : INTEGER ;
+BEGIN
+ dot := Index (rule, '.', 0) ;
+ Assert (dot # -1) ;
+ libstr := NIL ;
+ modstr := Slice (rule, 0, dot) ;
+ modsym := Get (makekey (string (modstr))) ;
+ IF modsym = NulSym
+ THEN
+ libstr := modstr ;
+ start := dot + 1 ;
+ dot := Index (rule, '.', start) ;
+ IF dot > 0
+ THEN
+ modstr := Slice (rule, start, dot) ;
+ modsym := Get (makekey (string (modstr))) ;
+ IF (modsym # NulSym) AND (makekey (string (libstr)) = GetLibName
(modsym))
+ THEN
+ AddRuleScopeQualidentDump (rule, dot, modsym)
+ END
+ END
+ ELSE
+ AddRuleScopeQualidentDump (rule, dot, modsym)
+ END
+END AddRuleScopeDump ;
+
+
+(*
+ AddRuleFilenameDump -
+*)
+
+PROCEDURE AddRuleFilenameDump (rule: String) ;
+BEGIN
+
+END AddRuleFilenameDump ;
+
+
+(*
+ AddRuleSymToDump -
+*)
+
+PROCEDURE AddRuleSymToDump (rule: String) ;
+BEGIN
+ IF Index (rule, ':', 0) # -1
+ THEN
+ (* Filename and scope rule. *)
+ AddRuleFilenameDump (rule)
+ ELSIF Index (rule, '.', 0) # -1
+ THEN
+ (* Modula-2 scoping tests. *)
+ AddRuleScopeDump (rule)
+ ELSE
+ (* Text decl tests. *)
+ AddRuleTextDump (rule)
+ END
+END AddRuleSymToDump ;
+
+
+(*
+ AddFilterListToDumpWatch -
+*)
+
+PROCEDURE AddFilterListToDumpWatch (filter: ADDRESS) ;
+VAR
+ rule,
+ full : String ;
+ start,
+ i : INTEGER ;
+BEGIN
+ full := InitStringCharStar (filter) ;
+ start := 0 ;
+ REPEAT
+ i := Index (full, ',', start) ;
+ IF i = -1
+ THEN
+ rule := Slice (full, start, 0)
+ ELSE
+ rule := Slice (full, start, i)
+ END ;
+ AddRuleSymToDump (rule) ;
+ rule := KillString (rule) ;
+ start := i+1 ;
+ UNTIL i = -1 ;
+ full := KillString (full) ;
+END AddFilterListToDumpWatch ;
+
+
+(*
+ CreateDumpTitle - creates the underlined title.
+*)
+
+PROCEDURE CreateDumpTitle (title: ARRAY OF CHAR) ;
+VAR
+ len,
+ text,
+ i : CARDINAL ;
+ s : String ;
+BEGIN
+ s := Sprintf0 (Mark (InitString (title))) ;
+ s := KillString (SFIO.WriteS (GetDumpFile (), s)) ;
+ len := StrLen (title) ;
+ i := 0 ;
+ text := 0 ;
+ WHILE i < len DO
+ IF title[i] = '\'
+ THEN
+ INC (i, 2)
+ ELSE
+ INC (i) ;
+ INC (text)
+ END
+ END ;
+ s := DynamicStrings.Mult (Mark (InitString ('=')), text) ;
+ s := KillString (SFIO.WriteS (GetDumpFile (), s)) ;
+ fprintf0 (GetDumpFile (), '\n');
+END CreateDumpTitle ;
+
+
+(*
+ CreateDumpDecl - create the dump file for a decl dump.
+*)
+
+PROCEDURE CreateDumpDecl (title: ARRAY OF CHAR) ;
+BEGIN
+ IF GetM2DumpFilter () # NIL
+ THEN
+ Assert (NOT declActive) ;
+ Assert (NOT quadActive) ;
+ declActive := TRUE ;
+ INC (NoOfDeclDumps) ;
+ OpenDump (MakeDeclTemplate (), NoOfDeclDumps) ;
+ CreateDumpTitle (title) ;
+ AddFilterListToDumpWatch (GetM2DumpFilter ())
+ END
+END CreateDumpDecl ;
+
+
+(*
+ CloseDumpQuad - close the dump output file.
+*)
+
+PROCEDURE CloseDumpQuad ;
+BEGIN
+ CloseDump ;
+ quadActive := FALSE
+END CloseDumpQuad ;
+
+
+(*
+ CreateDumpQuad - create the dump file for a quad dump.
+*)
+
+PROCEDURE CreateDumpQuad (title: ARRAY OF CHAR) ;
+BEGIN
+ Assert (NOT declActive) ;
+ Assert (NOT quadActive) ;
+ quadActive := TRUE ;
+ INC (NoOfQuadDumps) ;
+ OpenDump (MakeQuadTemplate (), NoOfQuadDumps) ;
+ CreateDumpTitle (title)
+END CreateDumpQuad ;
+
+
+(*
+ GetDumpFile - return the dump output file.
+*)
+
+PROCEDURE GetDumpFile () : File ;
+BEGIN
+ RETURN outputFile
+END GetDumpFile ;
+
+
+(*
+ IsDumpRequiredTree - return TRUE if the gcc tree should be dumped.
+*)
+
+PROCEDURE IsDumpRequiredTree (tree: Tree; default: BOOLEAN) : BOOLEAN ;
+VAR
+ sym: CARDINAL ;
+BEGIN
+ sym := Gcc2Mod (tree) ;
+ IF sym = NulSym
+ THEN
+ RETURN default
+ ELSE
+ RETURN IsDumpRequired (sym, default)
+ END
+END IsDumpRequiredTree ;
+
+
+(*
+ IsDumpRequired - return TRUE if symbol sym should be dumped
+ according to the rules of the filter.
+ No filter specified will always return default.
+ The filter is a comma separated list. Each element
+ of the list can specify a symbol three ways.
+ Firstly by DECL name for example: m2pim_NumberIO_HexToStr
+ Secondly by qualified scope: [pathname.]NumberIO.HexToStr
+ Thirdly by filename and scope: NumberIO.mod:HexToStr
+*)
+
+PROCEDURE IsDumpRequired (sym: CARDINAL; default: BOOLEAN) : BOOLEAN ;
+VAR
+ filter: String ;
+BEGIN
+ filter := GetM2DumpFilter () ;
+ IF filter = NIL
+ THEN
+ RETURN default
+ ELSE
+ RETURN Match (filter, sym)
+ END
+END IsDumpRequired ;
+
+
+(*
+ Match - return TRUE if sym matches any of the filter rules.
+*)
+
+PROCEDURE Match (filter: ADDRESS; sym: CARDINAL) : BOOLEAN ;
+VAR
+ result: BOOLEAN ;
+ rule,
+ full : String ;
+ start,
+ i : INTEGER ;
+BEGIN
+ full := InitStringCharStar (filter) ;
+ start := 0 ;
+ REPEAT
+ i := Index (full, ',', start) ;
+ IF i = -1
+ THEN
+ rule := Slice (full, start, 0)
+ ELSE
+ rule := Slice (full, start, i)
+ END ;
+ result := MatchRule (rule, sym) ;
+ rule := KillString (rule) ;
+ IF result
+ THEN
+ full := KillString (full) ;
+ RETURN TRUE
+ END ;
+ start := i+1 ;
+ UNTIL i = -1 ;
+ full := KillString (full) ;
+ RETURN FALSE
+END Match ;
+
+
+(*
+ MatchRule - return TRUE if rule matches sym.
+*)
+
+PROCEDURE MatchRule (rule: String; sym: CARDINAL) : BOOLEAN ;
+BEGIN
+ IF Index (rule, ':', 0) # -1
+ THEN
+ (* Filename and scope qualification tests. *)
+ RETURN MatchRuleFilenameScope (rule, sym)
+ ELSIF Index (rule, '.', 0) # -1
+ THEN
+ (* Modula-2 scoping tests. *)
+ RETURN MatchRuleScope (rule, sym)
+ ELSE
+ (* Text decl tests. *)
+ RETURN MatchRuleText (rule, sym)
+ END
+END MatchRule ;
+
+
+(*
+ MatchRuleFilenameScope - returns TRUE if rule contains
filename.ext:qualident
+ and it matches sym.
+*)
+
+PROCEDURE MatchRuleFilenameScope (rule: String; sym: CARDINAL) : BOOLEAN ;
+VAR
+ rulefile,
+ symfile,
+ subrule : String ;
+BEGIN
+ rulefile := Slice (rule, 0, Index (rule, ':', 0)) ;
+ (* Do not deallocate symfile. *)
+ symfile := FindFileNameFromToken (GetDeclaredMod (sym), 0) ;
+ IF TextMatch (rulefile, symfile)
+ THEN
+ subrule := Slice (rule, Index (rule, ':', 0) + 1, 0) ;
+ IF MatchRuleScope (subrule, sym)
+ THEN
+ subrule := KillString (subrule) ;
+ RETURN TRUE
+ END
+ END ;
+ rulefile := KillString (rulefile) ;
+ RETURN FALSE
+END MatchRuleFilenameScope ;
+
+
+(*
+ MatchRuleScope - returns TRUE if rule contains a [libname.]qualified.ident
+ and it matches sym.
+*)
+
+PROCEDURE MatchRuleScope (rule: String; sym: CARDINAL) : BOOLEAN ;
+VAR
+ i : INTEGER ;
+ name: Name ;
+BEGIN
+ IF Debugging
+ THEN
+ name := GetSymName (sym) ;
+ printf2 ("MatchRuleScope (%s, %a)\n", rule, name)
+ END ;
+ (* Compare qualident right to left. *)
+ i := RIndex (rule, '.', 0) ;
+ IF i = -1
+ THEN
+ (* No qualification, just the ident. *)
+ RETURN MatchRuleIdent (rule, sym)
+ ELSE
+ RETURN MatchRuleQualident (rule, Slice (rule, i+1, 0), i, sym)
+ END
+END MatchRuleScope ;
+
+
+(*
+ MatchRuleQualident - returns TRUE if rule matches qualified sym.
+ PostCondition: subrule will be deallocated upon exit.
+ TRUE is returned if rule matches
qualified sym.
+*)
+
+PROCEDURE MatchRuleQualident (rule, subrule: String; i: INTEGER; sym:
CARDINAL) : BOOLEAN ;
+VAR
+ scope: CARDINAL ;
+BEGIN
+ IF TextCompareName (subrule, GetSymName (sym))
+ THEN
+ IF NOT QualifiedScope (rule, sym, i, scope)
+ THEN
+ RETURN FALSE
+ END ;
+ IF OptionalLibname (rule, sym, i, scope)
+ THEN
+ RETURN TRUE
+ END
+ END ;
+ subrule := KillString (subrule) ;
+ IF Debugging
+ THEN
+ printf0 ("MatchRuleQualident FALSE\n")
+ END ;
+ RETURN FALSE
+END MatchRuleQualident ;
+
+
+(*
+ QualifiedScope - PostCondition: true is returned is rule matches a
qualified sym.
+ i is -1 if no more qualifications or
libname is found.
+ scope will be the set to the last outer
scope seen.
+*)
+
+PROCEDURE QualifiedScope (rule: String; sym: CARDINAL; VAR i: INTEGER; VAR
scope: CARDINAL) : BOOLEAN ;
+VAR
+ subrule: String ;
+ j : INTEGER ;
+ name : Name ;
+BEGIN
+ IF Debugging
+ THEN
+ name := GetSymName (sym) ;
+ printf2 ("seen ident name, QualifiedScope (rule = %s, %a)\n", rule, name)
+ END ;
+ scope := sym ;
+ subrule := NIL ;
+ REPEAT
+ j := i ;
+ scope := GetScope (scope) ;
+ i := ReverseIndex (rule, '.', j - 1) ;
+ IF Debugging
+ THEN
+ printf2 (" reverseindex (rule = %s, '.', j = %d)\n", rule, j);
+ printf1 (" returns i = %d\n", i)
+ END ;
+ IF scope # NulSym
+ THEN
+ subrule := KillString (subrule) ;
+ subrule := Slice (rule, i + 1, j) ;
+ IF Debugging
+ THEN
+ name := GetSymName (scope) ;
+ printf2 ("QualifiedScope (subrule = %s, %a)\n", subrule, name)
+ END ;
+ IF NOT TextCompareName (subrule, GetSymName (scope))
+ THEN
+ subrule := KillString (subrule) ;
+ IF Debugging
+ THEN
+ printf0 ("QualifiedScope FALSE\n")
+ END ;
+ RETURN FALSE
+ END
+ END
+ UNTIL (i <= 0) OR IsDefImp (scope) OR IsModule (scope) ;
+ subrule := KillString (subrule) ;
+ RETURN TRUE
+END QualifiedScope ;
+
+
+(*
+ OptionalLibname - returns TRUE if rule[0..dot] matches syms libname or
+ if there is no libname the scope is a module or defimp
+ symbol.
+*)
+
+PROCEDURE OptionalLibname (rule: String; sym: CARDINAL;
+ dot: INTEGER; scope: CARDINAL) : BOOLEAN ;
+VAR
+ subrule: String ;
+BEGIN
+ IF dot > 0
+ THEN
+ (* Check for optional libname. *)
+ subrule := Slice (rule, 0, dot) ;
+ IF Debugging
+ THEN
+ printf2 ("checking for optional libname (subrule = %s, '.', dot =
%d)\n",
+ rule, dot)
+ END ;
+ IF TextCompareName (subrule, GetLibName (GetModuleScope (sym)))
+ THEN
+ subrule := KillString (subrule) ;
+ IF Debugging
+ THEN
+ printf0 ("OptionalLibname TRUE\n")
+ END ;
+ RETURN TRUE
+ END ;
+ subrule := KillString (subrule)
+ ELSIF (scope # NulSym) AND (IsModule (scope) OR IsDefImp (scope))
+ THEN
+ IF Debugging
+ THEN
+ printf0 ("OptionalLibname TRUE\n")
+ END ;
+ RETURN TRUE
+ END ;
+ RETURN FALSE
+END OptionalLibname ;
+
+
+(*
+ MatchRuleIdent - return TRUE if ident sym matches rule.
+ The ident must be in a module or defimp scope.
+*)
+
+PROCEDURE MatchRuleIdent (rule: String; sym: CARDINAL) : BOOLEAN ;
+VAR
+ scope: CARDINAL ;
+BEGIN
+ IF TextCompareName (rule, GetSymName (sym))
+ THEN
+ scope := GetScope (sym) ;
+ RETURN IsModule (scope) OR IsDefImp (scope)
+ END ;
+ RETURN FALSE
+END MatchRuleIdent ;
+
+
+(*
+ MatchRuleText - returns TRUE if rule matches sym.
+*)
+
+PROCEDURE MatchRuleText (rule: String; sym: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN TextCompareName (rule, GetFullScopeAsmName (sym))
+END MatchRuleText ;
+
+
+(*
+ TextCompareName - return TRUE if rule matches name.
+*)
+
+PROCEDURE TextCompareName (rule: String; name: Name) : BOOLEAN ;
+VAR
+ result: BOOLEAN ;
+ text : String ;
+BEGIN
+ text := InitStringCharStar (KeyToCharStar (name)) ;
+ result := TextMatch (rule, text) ;
+ text := KillString (text) ;
+ RETURN result
+END TextCompareName ;
+
+
+(*
+ TextMatch - returns TRUE if rule matches text. Currently this
+ is a simple string compare, but could be extended
+ to implement regexp (seen in the rule).
+*)
+
+PROCEDURE TextMatch (rule, text: String) : BOOLEAN ;
+BEGIN
+ IF Debugging
+ THEN
+ printf2 ("TextMatch (%s, %s)\n", rule, text)
+ END ;
+ RETURN Equal (rule, text)
+END TextMatch ;
+
+
+(*
+ CreateTemplate - create and return a template filename with extension.
+ If the user has specified "-" then "-" is returned
otherwise
+ a template is formed from "dumpdir + filename +
.%03dl.extension".
+*)
+
+PROCEDURE CreateTemplate (filename, extension: String) : String ;
+BEGIN
+ IF filename = NIL
+ THEN
+ (* User has not specified a file. *)
+ IF GetDumpDir () = NIL
+ THEN
+ filename := InitStringCharStar (KeyToCharStar (GetSymName
(GetMainModule ())))
+ ELSE
+ filename := Dup (GetDumpDir ()) ;
+ filename := ConCat (filename, Mark (InitStringCharStar (KeyToCharStar
(GetSymName (GetMainModule ())))))
+ END ;
+ filename := ConCat (filename, Mark (InitString ('.mod')))
+ ELSE
+ (* We need to duplicate the filename to create a new string before ConCat
+ is used later on. *)
+ filename := Dup (filename)
+ END ;
+ IF NOT EqualArray (filename, '-')
+ THEN
+ filename := ConCat (ConCat (filename, InitString ('.%03dl.')), extension)
+ END ;
+ RETURN filename
+END CreateTemplate ;
+
+
+(*
+ MakeQuadTemplate - return a template for the quad dump file.
+*)
+
+PROCEDURE MakeQuadTemplate () : String ;
+BEGIN
+ RETURN CreateTemplate (GetDumpLangQuadFilename (), InitString ('quad'))
+END MakeQuadTemplate ;
+
+
+(*
+ MakeDeclTemplate - return a template for the decl dump file.
+*)
+
+PROCEDURE MakeDeclTemplate () : String ;
+BEGIN
+ RETURN CreateTemplate (GetDumpLangDeclFilename (), InitString ('decl'))
+END MakeDeclTemplate ;
+
+
+(*
+ MakeGimpleTemplate - return a template for the gimple dump file and assign
+ len to the max number of characters required to
complete
+ a template (including a nul terminator).
+*)
+
+PROCEDURE MakeGimpleTemplate (VAR len: CARDINAL) : String ;
+VAR
+ filename: String ;
+BEGIN
+ filename := CreateTemplate (GetDumpLangGimpleFilename (), InitString
('gimple')) ;
+ len := Length (filename) ; (* This is a short cut based on '%03d' format
+ specifier used above. *)
+ RETURN filename
+END MakeGimpleTemplate ;
+
+
+(*
+ Init - initialize the module global variables.
+*)
+
+PROCEDURE Init ;
+BEGIN
+ NoOfQuadDumps := 0 ;
+ NoOfDeclDumps := 0 ;
+ declActive := FALSE ;
+ quadActive := FALSE ;
+ mustClose := FALSE ;
+ outputFile := FIO.StdOut
+END Init ;
+
+
+BEGIN
+ Init
+END M2LangDump.
diff --git a/gcc/m2/gm2-compiler/M2Options.def
b/gcc/m2/gm2-compiler/M2Options.def
index 4e5f4993f82..90b5178f88a 100644
--- a/gcc/m2/gm2-compiler/M2Options.def
+++ b/gcc/m2/gm2-compiler/M2Options.def
@@ -55,7 +55,9 @@ VAR
PedanticCast, (* -Wpedantic-cast warns if sizes differ. *)
Statistics, (* -fstatistics information about code *)
StyleChecking, (* -Wstudents checks for common student errs*)
- DisplayQuadruples, (* -Wq option will display quadruples. *)
+ DumpLangDecl, (* -fdump-lang-decl. *)
+ DumpLangGimple, (* -fdump-lang-gimple. *)
+ DumpLangQuad, (* -fq, -fdump-lang-quad dump quadruples. *)
UnboundedByReference, (* -funbounded-by-reference *)
VerboseUnbounded, (* -Wverbose-unbounded *)
OptimizeUncalledProcedures, (* -Ouncalled removes uncalled procedures *)
@@ -1002,6 +1004,70 @@ PROCEDURE SetIEEELongDouble (value: BOOLEAN) ;
PROCEDURE GetIEEELongDouble () : BOOLEAN ;
+(*
+ GetDumpLangDeclFilename - returns the DumpLangDeclFilename.
+*)
+
+PROCEDURE GetDumpLangDeclFilename () : String ;
+
+
+(*
+ SetDumpLangDeclFilename - set DumpLangDeclFilename to filename.
+*)
+
+PROCEDURE SetDumpLangDeclFilename (value: BOOLEAN; filename: ADDRESS) ;
+
+
+(*
+ GetDumpLangQuadFilename - returns the DumpLangQuadFilename.
+*)
+
+PROCEDURE GetDumpLangQuadFilename () : String ;
+
+
+(*
+ SetDumpLangQuadFilename - set DumpLangQuadFilename to filename.
+*)
+
+PROCEDURE SetDumpLangQuadFilename (value: BOOLEAN; filename: ADDRESS) ;
+
+
+(*
+ GetDumpLangGimpleFilename - returns the DumpLangGimpleFilename.
+*)
+
+PROCEDURE GetDumpLangGimpleFilename () : String ;
+
+
+(*
+ SetDumpLangGimpleFilename - set DumpLangGimpleFilename to filename.
+*)
+
+PROCEDURE SetDumpLangGimpleFilename (value: BOOLEAN; filename: ADDRESS) ;
+
+
+(*
+ SetM2DumpFilter - sets the filter to a comma separated list of procedures
+ and modules.
+*)
+
+PROCEDURE SetM2DumpFilter (value: BOOLEAN; filter: ADDRESS) ;
+
+
+(*
+ GetM2DumpFilter - returns the dump filter.
+*)
+
+PROCEDURE GetM2DumpFilter () : ADDRESS ;
+
+
+(*
+ GetDumpLangGimple - return TRUE if -fdump-lang-gimple is set.
+*)
+
+PROCEDURE GetDumpLangGimple () : BOOLEAN ;
+
+
(*
FinaliseOptions - once all options have been parsed we set any inferred
values.
diff --git a/gcc/m2/gm2-compiler/M2Options.mod
b/gcc/m2/gm2-compiler/M2Options.mod
index ae4980860b0..30203158e5c 100644
--- a/gcc/m2/gm2-compiler/M2Options.mod
+++ b/gcc/m2/gm2-compiler/M2Options.mod
@@ -34,7 +34,6 @@ FROM m2linemap IMPORT location_t ;
FROM m2configure IMPORT FullPathCPP, TargetIEEEQuadDefault ;
FROM M2Error IMPORT InternalError ;
-
FROM DynamicStrings IMPORT String, Length, InitString, Mark, Slice, EqualArray,
InitStringCharStar, ConCatChar, ConCat, KillString,
Dup, string, char,
@@ -56,6 +55,10 @@ CONST
DefaultRuntimeModuleOverride =
"m2iso:RTentity,m2iso:Storage,m2iso:SYSTEM,m2iso:M2RTS,m2iso:RTExceptions,m2iso:IOLink"
;
VAR
+ DumpLangDeclFilename,
+ DumpLangQuadFilename,
+ DumpLangGimpleFilename,
+ M2DumpFilter,
M2Prefix,
M2PathName,
Barg,
@@ -1049,7 +1052,9 @@ END SetSwig ;
PROCEDURE SetQuadDebugging (value: BOOLEAN) ;
BEGIN
- DisplayQuadruples := value
+ DumpLangQuad := value ;
+ DumpLangQuadFilename := KillString (DumpLangQuadFilename) ;
+ DumpLangQuadFilename := InitString ('-')
END SetQuadDebugging ;
@@ -1670,6 +1675,121 @@ BEGIN
END InitializeLongDoubleFlags ;
+(*
+ GetDumpLangDeclFilename - returns the DumpLangDeclFilename.
+*)
+
+PROCEDURE GetDumpLangDeclFilename () : String ;
+BEGIN
+ RETURN DumpLangDeclFilename
+END GetDumpLangDeclFilename ;
+
+
+(*
+ SetDumpLangDeclFilename -
+*)
+
+PROCEDURE SetDumpLangDeclFilename (value: BOOLEAN; filename: ADDRESS) ;
+BEGIN
+ DumpLangDecl := value ;
+ DumpLangDeclFilename := KillString (DumpLangDeclFilename) ;
+ IF filename # NIL
+ THEN
+ DumpLangDeclFilename := InitStringCharStar (filename)
+ END
+END SetDumpLangDeclFilename ;
+
+
+(*
+ GetDumpLangQuadFilename - returns the DumpLangQuadFilename.
+*)
+
+PROCEDURE GetDumpLangQuadFilename () : String ;
+BEGIN
+ RETURN DumpLangQuadFilename
+END GetDumpLangQuadFilename ;
+
+
+(*
+ SetDumpLangQuadFilename -
+*)
+
+PROCEDURE SetDumpLangQuadFilename (value: BOOLEAN; filename: ADDRESS) ;
+BEGIN
+ DumpLangQuad := value ;
+ DumpLangQuadFilename := KillString (DumpLangQuadFilename) ;
+ IF filename # NIL
+ THEN
+ DumpLangQuadFilename := InitStringCharStar (filename)
+ END
+END SetDumpLangQuadFilename ;
+
+
+(*
+ GetDumpLangGimpleFilename - returns the DumpLangGimpleFilename.
+*)
+
+PROCEDURE GetDumpLangGimpleFilename () : String ;
+BEGIN
+ RETURN DumpLangGimpleFilename
+END GetDumpLangGimpleFilename ;
+
+
+(*
+ SetDumpLangGimpleFilename - set DumpLangGimpleFilename to filename.
+*)
+
+PROCEDURE SetDumpLangGimpleFilename (value: BOOLEAN; filename: ADDRESS) ;
+BEGIN
+ DumpLangGimple := value ;
+ DumpLangGimpleFilename := KillString (DumpLangGimpleFilename) ;
+ IF value AND (filename # NIL)
+ THEN
+ DumpLangGimpleFilename := InitStringCharStar (filename)
+ END
+END SetDumpLangGimpleFilename ;
+
+
+(*
+ SetM2DumpFilter - sets the filter to a comma separated list of procedures
+ and modules.
+*)
+
+PROCEDURE SetM2DumpFilter (value: BOOLEAN; filter: ADDRESS) ;
+BEGIN
+ M2DumpFilter := KillString (M2DumpFilter) ;
+ IF value AND (filter # NIL)
+ THEN
+ M2DumpFilter := InitStringCharStar (filter)
+ END
+END SetM2DumpFilter ;
+
+
+(*
+ GetM2DumpFilter - returns the dump filter.
+*)
+
+PROCEDURE GetM2DumpFilter () : ADDRESS ;
+BEGIN
+ IF M2DumpFilter = NIL
+ THEN
+ RETURN NIL
+ ELSE
+ RETURN string (M2DumpFilter)
+ END
+END GetM2DumpFilter ;
+
+
+(*
+ GetDumpLangGimple - return TRUE if -fdump-lang-gimple is set.
+*)
+
+PROCEDURE GetDumpLangGimple () : BOOLEAN ;
+BEGIN
+ RETURN DumpLangGimple
+END GetDumpLangGimple ;
+
+
BEGIN
cflag := FALSE ; (* -c. *)
RuntimeModuleOverride := InitString
(DefaultRuntimeModuleOverride) ;
@@ -1691,7 +1811,7 @@ BEGIN
Quiet := TRUE ;
CC1Quiet := TRUE ;
Profiling := FALSE ;
- DisplayQuadruples := FALSE ;
+ DumpLangQuad := FALSE ;
OptimizeBasicBlock := FALSE ;
OptimizeUncalledProcedures := FALSE ;
OptimizeCommonSubExpressions := FALSE ;
@@ -1751,5 +1871,12 @@ BEGIN
MQFlag := NIL ;
InitializeLongDoubleFlags ;
M2Prefix := InitString ('') ;
- M2PathName := InitString ('')
+ M2PathName := InitString ('') ;
+ DumpLangQuadFilename := NIL ;
+ DumpLangGimpleFilename := NIL ;
+ DumpLangDeclFilename := NIL ;
+ DumpLangDecl := FALSE ;
+ DumpLangQuad := FALSE ;
+ DumpLangGimple := FALSE ;
+ M2DumpFilter := NIL
END M2Options.
diff --git a/gcc/m2/gm2-compiler/M2Quads.def b/gcc/m2/gm2-compiler/M2Quads.def
index ad2ee869846..a8ca69b7bc6 100644
--- a/gcc/m2/gm2-compiler/M2Quads.def
+++ b/gcc/m2/gm2-compiler/M2Quads.def
@@ -125,7 +125,7 @@ EXPORT QUALIFIED StartBuildDefFile, StartBuildModFile,
EndBuildFile,
IsDefOrModFile,
IsInitialisingConst,
- DisplayQuadList, DisplayQuadRange, DisplayQuad,
+ DumpQuadruples, DisplayQuadRange, DisplayQuad,
WriteOperator, BackPatchSubrangesAndOptParam,
GetQuad, GetFirstQuad, GetNextQuad, PutQuad,
@@ -440,10 +440,12 @@ PROCEDURE IsDefOrModFile (QuadNo: CARDINAL) : BOOLEAN ;
(*
- DisplayQuadList - displays all quads.
+ DumpQuadruples - dump all quadruples providing the -fq, -fdump-lang-quad,
+ -fdump-lang-quad= or -fdump-lang-all were issued to the
+ command line.
*)
-PROCEDURE DisplayQuadList ;
+PROCEDURE DumpQuadruples (title: ARRAY OF CHAR) ;
(*
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 0558c782101..ac654e89c91 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -27,6 +27,7 @@ FROM M2Debug IMPORT Assert, WriteDebug ;
FROM NameKey IMPORT Name, NulName, MakeKey, GetKey, makekey, KeyToCharStar,
WriteKey ;
FROM FormatStrings IMPORT Sprintf0, Sprintf1, Sprintf2, Sprintf3 ;
FROM M2DebugStack IMPORT DebugStack ;
+FROM StrLib IMPORT StrLen ;
FROM M2Scaffold IMPORT DeclareScaffold, mainFunction, initFunction,
finiFunction, linkFunction, PopulateCtorArray,
ForeachModuleCallInit, ForeachModuleCallFinish ;
@@ -160,7 +161,8 @@ FROM M2Error IMPORT Error,
ErrorStringAt, ErrorStringAt2, ErrorStringsAt2,
WarnStringAt, WarnStringAt2, WarnStringsAt2 ;
-FROM M2Printf IMPORT printf0, printf1, printf2, printf3, printf4 ;
+FROM M2Printf IMPORT fprintf0, fprintf1, fprintf2, fprintf3, fprintf4,
+ printf0, printf1, printf2, printf3, printf4 ;
FROM M2Reserved IMPORT PlusTok, MinusTok, TimesTok, DivTok, ModTok,
DivideTok, RemTok,
@@ -218,8 +220,11 @@ FROM M2Options IMPORT NilChecking,
UninitVariableChecking,
ScaffoldDynamic, ScaffoldStatic, cflag,
ScaffoldMain, SharedFlag, WholeProgram,
- GetRuntimeModuleOverride ;
+ GetDumpDir, GetM2DumpFilter,
+ GetRuntimeModuleOverride,
+ DumpLangQuad ;
+FROM M2LangDump IMPORT CreateDumpQuad, CloseDumpQuad, GetDumpFile ;
FROM M2Pass IMPORT IsPassCodeGeneration, IsNoPass ;
FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress,
@@ -263,8 +268,9 @@ FROM M2Range IMPORT InitAssignmentRangeCheck,
FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList,
EndCaseList, ElseCase ;
FROM PCSymBuild IMPORT SkipConst ;
FROM m2builtins IMPORT GetBuiltinTypeInfoType ;
+FROM M2LangDump IMPORT IsDumpRequired ;
-IMPORT M2Error ;
+IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ;
CONST
@@ -5567,9 +5573,9 @@ BEGIN
THEN
IF i<=ParamTotal
THEN
- printf0('; ')
+ printf0 ('; ')
ELSE
- printf0(' ) ; \n')
+ printf0 (' ) ; \n')
END
END
END
@@ -13324,22 +13330,124 @@ END GenQuadOTypetok ;
(*
- DisplayQuadList - displays all quads.
+ DumpUntil - dump all quadruples until we seen the ending quadruple
+ with procsym in the third operand.
+ Return the quad number containing the match.
*)
-PROCEDURE DisplayQuadList ;
+PROCEDURE DumpUntil (ending: QuadOperator;
+ procsym: CARDINAL; quad: CARDINAL) : CARDINAL ;
+VAR
+ op : QuadOperator ;
+ op1, op2, op3: CARDINAL ;
+ f : QuadFrame ;
+BEGIN
+ fprintf0 (GetDumpFile (), '\n...\n\n');
+ REPEAT
+ GetQuad (quad, op, op1, op2, op3) ;
+ DisplayQuad (quad) ;
+ f := GetQF (quad) ;
+ quad := f^.Next
+ UNTIL (op = ending) AND (op3 = procsym) ;
+ RETURN quad
+END DumpUntil ;
+
+
+(*
+ GetCtorInit - return the init procedure for the module.
+*)
+
+PROCEDURE GetCtorInit (sym: CARDINAL) : CARDINAL ;
+VAR
+ ctor, init, fini, dep: CARDINAL ;
+BEGIN
+ GetModuleCtors (sym, ctor, init, fini, dep) ;
+ RETURN init
+END GetCtorInit ;
+
+
+(*
+ GetCtorFini - return the fini procedure for the module.
+*)
+
+PROCEDURE GetCtorFini (sym: CARDINAL) : CARDINAL ;
+VAR
+ ctor, init, fini, dep: CARDINAL ;
+BEGIN
+ GetModuleCtors (sym, ctor, init, fini, dep) ;
+ RETURN fini
+END GetCtorFini ;
+
+
+(*
+ DumpQuadrupleFilter -
+*)
+
+PROCEDURE DumpQuadrupleFilter ;
+VAR
+ f : QuadFrame ;
+ i : CARDINAL ;
+ op : QuadOperator ;
+ op1, op2, op3: CARDINAL ;
+BEGIN
+ i := Head ;
+ WHILE i # 0 DO
+ GetQuad (i, op, op1, op2, op3) ;
+ IF (op = ProcedureScopeOp) AND IsDumpRequired (op3, TRUE)
+ THEN
+ i := DumpUntil (KillLocalVarOp, op3, i)
+ ELSIF (op = InitStartOp) AND IsDumpRequired (GetCtorInit (op3), TRUE)
+ THEN
+ i := DumpUntil (InitEndOp, op3, i)
+ ELSIF (op = FinallyStartOp) AND IsDumpRequired (GetCtorFini (op3), TRUE)
+ THEN
+ i := DumpUntil (FinallyEndOp, op3, i)
+ ELSE
+ f := GetQF (i) ;
+ i := f^.Next
+ END
+ END
+END DumpQuadrupleFilter ;
+
+
+(*
+ DumpQuadrupleAll - dump all quadruples.
+*)
+
+PROCEDURE DumpQuadrupleAll ;
VAR
- i: CARDINAL ;
f: QuadFrame ;
+ i: CARDINAL ;
BEGIN
- printf0('Quadruples:\n') ;
i := Head ;
- WHILE i#0 DO
- DisplayQuad(i) ;
- f := GetQF(i) ;
+ WHILE i # 0 DO
+ DisplayQuad (i) ;
+ f := GetQF (i) ;
i := f^.Next
END
-END DisplayQuadList ;
+END DumpQuadrupleAll ;
+
+
+(*
+ DumpQuadruples - dump all quadruples providing the -fq, -fdump-lang-quad,
+ -fdump-lang-quad= or -fdump-lang-all were issued to the
+ command line.
+*)
+
+PROCEDURE DumpQuadruples (title: ARRAY OF CHAR) ;
+BEGIN
+ IF DumpLangQuad
+ THEN
+ CreateDumpQuad (title) ;
+ IF GetM2DumpFilter () = NIL
+ THEN
+ DumpQuadrupleAll
+ ELSE
+ DumpQuadrupleFilter
+ END ;
+ CloseDumpQuad
+ END
+END DumpQuadruples ;
(*
@@ -13350,7 +13458,7 @@ PROCEDURE DisplayQuadRange (scope: CARDINAL; start,
end: CARDINAL) ;
VAR
f: QuadFrame ;
BEGIN
- printf1 ('Quadruples for scope: %d\n', scope) ;
+ fprintf1 (GetDumpFile (), 'Quadruples for scope: %d\n', scope) ;
WHILE (start <= end) AND (start # 0) DO
DisplayQuad (start) ;
f := GetQF (start) ;
@@ -13482,7 +13590,7 @@ END ds ;
PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
BEGIN
DSdbEnter ;
- printf1('%4d ', QuadNo) ; WriteQuad(QuadNo) ; printf0('\n') ;
+ fprintf1 (GetDumpFile (), '%4d ', QuadNo) ; WriteQuad(QuadNo) ; fprintf0
(GetDumpFile (), '\n') ;
DSdbExit
END DisplayQuad ;
@@ -13495,19 +13603,19 @@ PROCEDURE DisplayProcedureAttributes (proc: CARDINAL)
;
BEGIN
IF IsCtor (proc)
THEN
- printf0 (" (ctor)")
+ fprintf0 (GetDumpFile (), " (ctor)")
END ;
IF IsPublic (proc)
THEN
- printf0 (" (public)")
+ fprintf0 (GetDumpFile (), " (public)")
END ;
IF IsExtern (proc)
THEN
- printf0 (" (extern)")
+ fprintf0 (GetDumpFile (), " (extern)")
END ;
IF IsMonoName (proc)
THEN
- printf0 (" (mononame)")
+ fprintf0 (GetDumpFile (), " (mononame)")
END
END DisplayProcedureAttributes ;
@@ -13526,11 +13634,11 @@ BEGIN
f := GetQF(BufferQuad) ;
WITH f^ DO
WriteOperator(Operator) ;
- printf1(' [%d] ', NoOfTimesReferenced) ;
+ fprintf1 (GetDumpFile (), ' [%d] ', NoOfTimesReferenced) ;
CASE Operator OF
HighOp : WriteOperand(Operand1) ;
- printf1(' %4d ', Operand2) ;
+ fprintf1 (GetDumpFile (), ' %4d ', Operand2) ;
WriteOperand(Operand3) |
InitAddressOp,
SavePriorityOp,
@@ -13548,7 +13656,7 @@ BEGIN
StringConvertCnulOp,
StringConvertM2nulOp,
StringLengthOp : WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand3) |
ElementSizeOp,
IfInOp,
@@ -13559,22 +13667,22 @@ BEGIN
IfGreOp,
IfLessEquOp,
IfGreEquOp : WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand2) ;
- printf1(' %4d', Operand3) |
+ fprintf1 (GetDumpFile (), ' %4d', Operand3) |
InlineOp,
RetryOp,
TryOp,
- GotoOp : printf1('%4d', Operand3) |
+ GotoOp : fprintf1 (GetDumpFile (), '%4d', Operand3) |
StatementNoteOp : l := TokenToLineNo(Operand3, 0) ;
n := GetTokenName (Operand3) ;
- printf4('%a:%d:%a (tokenno %d)', Operand1, l, n,
Operand3) |
- LineNumberOp : printf2('%a:%d', Operand1, Operand3) |
+ fprintf4 (GetDumpFile (), '%a:%d:%a (tokenno %d)',
Operand1, l, n, Operand3) |
+ LineNumberOp : fprintf2 (GetDumpFile (), '%a:%d', Operand1,
Operand3) |
EndFileOp : n1 := GetSymName(Operand3) ;
- printf1('%a', n1) |
+ fprintf1 (GetDumpFile (), '%a', n1) |
ThrowOp,
ReturnOp,
@@ -13583,7 +13691,7 @@ BEGIN
ProcedureScopeOp : n1 := GetSymName(Operand2) ;
n2 := GetSymName(Operand3) ;
- printf3(' %4d %a %a', Operand1, n1, n2) ;
+ fprintf3 (GetDumpFile (), ' %4d %a %a', Operand1,
n1, n2) ;
DisplayProcedureAttributes (Operand3) |
NewLocalVarOp,
FinallyStartOp,
@@ -13591,19 +13699,19 @@ BEGIN
InitEndOp,
InitStartOp : n1 := GetSymName(Operand2) ;
n2 := GetSymName(Operand3) ;
- printf3(' %4d %a %a', Operand1, n1, n2) |
+ fprintf3 (GetDumpFile (), ' %4d %a %a', Operand1,
n1, n2) |
ModuleScopeOp,
StartModFileOp : n1 := GetSymName(Operand3) ;
- printf4('%a:%d %a(%d)', Operand2, Operand1, n1,
Operand3) |
+ fprintf4 (GetDumpFile (), '%a:%d %a(%d)', Operand2,
Operand1, n1, Operand3) |
StartDefFileOp : n1 := GetSymName(Operand3) ;
- printf2(' %4d %a', Operand1, n1) |
+ fprintf2 (GetDumpFile (), ' %4d %a', Operand1, n1)
|
OptParamOp,
- ParamOp : printf1('%4d ', Operand1) ;
+ ParamOp : fprintf1 (GetDumpFile (), '%4d ', Operand1) ;
WriteOperand(Operand2) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand3) |
SizeOp,
RecordFieldOp,
@@ -13631,9 +13739,9 @@ BEGIN
DivFloorOp,
ModTruncOp,
DivTruncOp : WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand2) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand3) |
DummyOp,
CodeOnOp,
@@ -13643,23 +13751,23 @@ BEGIN
OptimizeOnOp,
OptimizeOffOp : |
BuiltinConstOp : WriteOperand(Operand1) ;
- printf1(' %a', Operand3) |
+ fprintf1 (GetDumpFile (), ' %a', Operand3) |
BuiltinTypeInfoOp : WriteOperand(Operand1) ;
- printf1(' %a', Operand2) ;
- printf1(' %a', Operand3) |
+ fprintf1 (GetDumpFile (), ' %a', Operand2) ;
+ fprintf1 (GetDumpFile (), ' %a', Operand3) |
StandardFunctionOp: WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand2) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand3) |
CatchBeginOp,
CatchEndOp : |
RangeCheckOp,
- ErrorOp : WriteRangeCheck(Operand3) |
+ ErrorOp : WriteRangeCheck (Operand3) |
SaveExceptionOp,
RestoreExceptionOp: WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (GetDumpFile (), ' ') ;
WriteOperand(Operand3)
ELSE
@@ -13677,96 +13785,96 @@ PROCEDURE WriteOperator (Operator: QuadOperator) ;
BEGIN
CASE Operator OF
- ArithAddOp : printf0('Arith + ') |
- InitAddressOp : printf0('InitAddress ') |
- LogicalOrOp : printf0('Or ') |
- LogicalAndOp : printf0('And ') |
- LogicalXorOp : printf0('Xor ') |
- LogicalDiffOp : printf0('Ldiff ') |
- LogicalShiftOp : printf0('Shift ') |
- LogicalRotateOp : printf0('Rotate ') |
- BecomesOp : printf0('Becomes ') |
- IndrXOp : printf0('IndrX ') |
- XIndrOp : printf0('XIndr ') |
- ArrayOp : printf0('Array ') |
- ElementSizeOp : printf0('ElementSize ') |
- RecordFieldOp : printf0('RecordField ') |
- AddrOp : printf0('Addr ') |
- SizeOp : printf0('Size ') |
- IfInOp : printf0('If IN ') |
- IfNotInOp : printf0('If NOT IN ') |
- IfNotEquOp : printf0('If <> ') |
- IfEquOp : printf0('If = ') |
- IfLessEquOp : printf0('If <= ') |
- IfGreEquOp : printf0('If >= ') |
- IfGreOp : printf0('If > ') |
- IfLessOp : printf0('If < ') |
- GotoOp : printf0('Goto ') |
- DummyOp : printf0('Dummy ') |
- ModuleScopeOp : printf0('ModuleScopeOp ') |
- StartDefFileOp : printf0('StartDefFile ') |
- StartModFileOp : printf0('StartModFile ') |
- EndFileOp : printf0('EndFileOp ') |
- InitStartOp : printf0('InitStart ') |
- InitEndOp : printf0('InitEnd ') |
- FinallyStartOp : printf0('FinallyStart ') |
- FinallyEndOp : printf0('FinallyEnd ') |
- RetryOp : printf0('Retry ') |
- TryOp : printf0('Try ') |
- ThrowOp : printf0('Throw ') |
- CatchBeginOp : printf0('CatchBegin ') |
- CatchEndOp : printf0('CatchEnd ') |
- AddOp : printf0('+ ') |
- SubOp : printf0('- ') |
- DivM2Op : printf0('DIV M2 ') |
- ModM2Op : printf0('MOD M2 ') |
- DivCeilOp : printf0('DIV ceil ') |
- ModCeilOp : printf0('MOD ceil ') |
- DivFloorOp : printf0('DIV floor ') |
- ModFloorOp : printf0('MOD floor ') |
- DivTruncOp : printf0('DIV trunc ') |
- ModTruncOp : printf0('MOD trunc ') |
- MultOp : printf0('* ') |
- NegateOp : printf0('Negate ') |
- InclOp : printf0('Incl ') |
- ExclOp : printf0('Excl ') |
- ReturnOp : printf0('Return ') |
- ReturnValueOp : printf0('ReturnValue ') |
- FunctValueOp : printf0('FunctValue ') |
- CallOp : printf0('Call ') |
- ParamOp : printf0('Param ') |
- OptParamOp : printf0('OptParam ') |
- NewLocalVarOp : printf0('NewLocalVar ') |
- KillLocalVarOp : printf0('KillLocalVar ') |
- ProcedureScopeOp : printf0('ProcedureScope ') |
- UnboundedOp : printf0('Unbounded ') |
- CoerceOp : printf0('Coerce ') |
- ConvertOp : printf0('Convert ') |
- CastOp : printf0('Cast ') |
- HighOp : printf0('High ') |
- CodeOnOp : printf0('CodeOn ') |
- CodeOffOp : printf0('CodeOff ') |
- ProfileOnOp : printf0('ProfileOn ') |
- ProfileOffOp : printf0('ProfileOff ') |
- OptimizeOnOp : printf0('OptimizeOn ') |
- OptimizeOffOp : printf0('OptimizeOff ') |
- InlineOp : printf0('Inline ') |
- StatementNoteOp : printf0('StatementNote ') |
- LineNumberOp : printf0('LineNumber ') |
- BuiltinConstOp : printf0('BuiltinConst ') |
- BuiltinTypeInfoOp : printf0('BuiltinTypeInfo ') |
- StandardFunctionOp : printf0('StandardFunction ') |
- SavePriorityOp : printf0('SavePriority ') |
- RestorePriorityOp : printf0('RestorePriority ') |
- RangeCheckOp : printf0('RangeCheck ') |
- ErrorOp : printf0('Error ') |
- SaveExceptionOp : printf0('SaveException ') |
- RestoreExceptionOp : printf0('RestoreException ') |
- StringConvertCnulOp : printf0('StringConvertCnul ') |
- StringConvertM2nulOp : printf0('StringConvertM2nul') |
- StringLengthOp : printf0('StringLength ') |
- SubrangeHighOp : printf0('SubrangeHigh ') |
- SubrangeLowOp : printf0('SubrangeLow ')
+ ArithAddOp : fprintf0 (GetDumpFile (), 'Arith + ') |
+ InitAddressOp : fprintf0 (GetDumpFile (), 'InitAddress ') |
+ LogicalOrOp : fprintf0 (GetDumpFile (), 'Or ') |
+ LogicalAndOp : fprintf0 (GetDumpFile (), 'And ') |
+ LogicalXorOp : fprintf0 (GetDumpFile (), 'Xor ') |
+ LogicalDiffOp : fprintf0 (GetDumpFile (), 'Ldiff ') |
+ LogicalShiftOp : fprintf0 (GetDumpFile (), 'Shift ') |
+ LogicalRotateOp : fprintf0 (GetDumpFile (), 'Rotate ') |
+ BecomesOp : fprintf0 (GetDumpFile (), 'Becomes ') |
+ IndrXOp : fprintf0 (GetDumpFile (), 'IndrX ') |
+ XIndrOp : fprintf0 (GetDumpFile (), 'XIndr ') |
+ ArrayOp : fprintf0 (GetDumpFile (), 'Array ') |
+ ElementSizeOp : fprintf0 (GetDumpFile (), 'ElementSize ') |
+ RecordFieldOp : fprintf0 (GetDumpFile (), 'RecordField ') |
+ AddrOp : fprintf0 (GetDumpFile (), 'Addr ') |
+ SizeOp : fprintf0 (GetDumpFile (), 'Size ') |
+ IfInOp : fprintf0 (GetDumpFile (), 'If IN ') |
+ IfNotInOp : fprintf0 (GetDumpFile (), 'If NOT IN ') |
+ IfNotEquOp : fprintf0 (GetDumpFile (), 'If <> ') |
+ IfEquOp : fprintf0 (GetDumpFile (), 'If = ') |
+ IfLessEquOp : fprintf0 (GetDumpFile (), 'If <= ') |
+ IfGreEquOp : fprintf0 (GetDumpFile (), 'If >= ') |
+ IfGreOp : fprintf0 (GetDumpFile (), 'If > ') |
+ IfLessOp : fprintf0 (GetDumpFile (), 'If < ') |
+ GotoOp : fprintf0 (GetDumpFile (), 'Goto ') |
+ DummyOp : fprintf0 (GetDumpFile (), 'Dummy ') |
+ ModuleScopeOp : fprintf0 (GetDumpFile (), 'ModuleScopeOp ') |
+ StartDefFileOp : fprintf0 (GetDumpFile (), 'StartDefFile ') |
+ StartModFileOp : fprintf0 (GetDumpFile (), 'StartModFile ') |
+ EndFileOp : fprintf0 (GetDumpFile (), 'EndFileOp ') |
+ InitStartOp : fprintf0 (GetDumpFile (), 'InitStart ') |
+ InitEndOp : fprintf0 (GetDumpFile (), 'InitEnd ') |
+ FinallyStartOp : fprintf0 (GetDumpFile (), 'FinallyStart ') |
+ FinallyEndOp : fprintf0 (GetDumpFile (), 'FinallyEnd ') |
+ RetryOp : fprintf0 (GetDumpFile (), 'Retry ') |
+ TryOp : fprintf0 (GetDumpFile (), 'Try ') |
+ ThrowOp : fprintf0 (GetDumpFile (), 'Throw ') |
+ CatchBeginOp : fprintf0 (GetDumpFile (), 'CatchBegin ') |
+ CatchEndOp : fprintf0 (GetDumpFile (), 'CatchEnd ') |
+ AddOp : fprintf0 (GetDumpFile (), '+ ') |
+ SubOp : fprintf0 (GetDumpFile (), '- ') |
+ DivM2Op : fprintf0 (GetDumpFile (), 'DIV M2 ') |
+ ModM2Op : fprintf0 (GetDumpFile (), 'MOD M2 ') |
+ DivCeilOp : fprintf0 (GetDumpFile (), 'DIV ceil ') |
+ ModCeilOp : fprintf0 (GetDumpFile (), 'MOD ceil ') |
+ DivFloorOp : fprintf0 (GetDumpFile (), 'DIV floor ') |
+ ModFloorOp : fprintf0 (GetDumpFile (), 'MOD floor ') |
+ DivTruncOp : fprintf0 (GetDumpFile (), 'DIV trunc ') |
+ ModTruncOp : fprintf0 (GetDumpFile (), 'MOD trunc ') |
+ MultOp : fprintf0 (GetDumpFile (), '* ') |
+ NegateOp : fprintf0 (GetDumpFile (), 'Negate ') |
+ InclOp : fprintf0 (GetDumpFile (), 'Incl ') |
+ ExclOp : fprintf0 (GetDumpFile (), 'Excl ') |
+ ReturnOp : fprintf0 (GetDumpFile (), 'Return ') |
+ ReturnValueOp : fprintf0 (GetDumpFile (), 'ReturnValue ') |
+ FunctValueOp : fprintf0 (GetDumpFile (), 'FunctValue ') |
+ CallOp : fprintf0 (GetDumpFile (), 'Call ') |
+ ParamOp : fprintf0 (GetDumpFile (), 'Param ') |
+ OptParamOp : fprintf0 (GetDumpFile (), 'OptParam ') |
+ NewLocalVarOp : fprintf0 (GetDumpFile (), 'NewLocalVar ') |
+ KillLocalVarOp : fprintf0 (GetDumpFile (), 'KillLocalVar ') |
+ ProcedureScopeOp : fprintf0 (GetDumpFile (), 'ProcedureScope ') |
+ UnboundedOp : fprintf0 (GetDumpFile (), 'Unbounded ') |
+ CoerceOp : fprintf0 (GetDumpFile (), 'Coerce ') |
+ ConvertOp : fprintf0 (GetDumpFile (), 'Convert ') |
+ CastOp : fprintf0 (GetDumpFile (), 'Cast ') |
+ HighOp : fprintf0 (GetDumpFile (), 'High ') |
+ CodeOnOp : fprintf0 (GetDumpFile (), 'CodeOn ') |
+ CodeOffOp : fprintf0 (GetDumpFile (), 'CodeOff ') |
+ ProfileOnOp : fprintf0 (GetDumpFile (), 'ProfileOn ') |
+ ProfileOffOp : fprintf0 (GetDumpFile (), 'ProfileOff ') |
+ OptimizeOnOp : fprintf0 (GetDumpFile (), 'OptimizeOn ') |
+ OptimizeOffOp : fprintf0 (GetDumpFile (), 'OptimizeOff ') |
+ InlineOp : fprintf0 (GetDumpFile (), 'Inline ') |
+ StatementNoteOp : fprintf0 (GetDumpFile (), 'StatementNote ') |
+ LineNumberOp : fprintf0 (GetDumpFile (), 'LineNumber ') |
+ BuiltinConstOp : fprintf0 (GetDumpFile (), 'BuiltinConst ') |
+ BuiltinTypeInfoOp : fprintf0 (GetDumpFile (), 'BuiltinTypeInfo ') |
+ StandardFunctionOp : fprintf0 (GetDumpFile (), 'StandardFunction ') |
+ SavePriorityOp : fprintf0 (GetDumpFile (), 'SavePriority ') |
+ RestorePriorityOp : fprintf0 (GetDumpFile (), 'RestorePriority ') |
+ RangeCheckOp : fprintf0 (GetDumpFile (), 'RangeCheck ') |
+ ErrorOp : fprintf0 (GetDumpFile (), 'Error ') |
+ SaveExceptionOp : fprintf0 (GetDumpFile (), 'SaveException ') |
+ RestoreExceptionOp : fprintf0 (GetDumpFile (), 'RestoreException ') |
+ StringConvertCnulOp : fprintf0 (GetDumpFile (), 'StringConvertCnul ') |
+ StringConvertM2nulOp : fprintf0 (GetDumpFile (), 'StringConvertM2nul') |
+ StringLengthOp : fprintf0 (GetDumpFile (), 'StringLength ') |
+ SubrangeHighOp : fprintf0 (GetDumpFile (), 'SubrangeHigh ') |
+ SubrangeLowOp : fprintf0 (GetDumpFile (), 'SubrangeLow ')
ELSE
InternalError ('operator not expected')
@@ -13784,15 +13892,15 @@ VAR
BEGIN
IF Sym = NulSym
THEN
- printf0 ('<nulsym>')
+ fprintf0 (GetDumpFile (), '<nulsym>')
ELSE
n := GetSymName (Sym) ;
- printf1 ('%a', n) ;
+ fprintf1 (GetDumpFile (), '%a', n) ;
IF IsVar (Sym) OR IsConst (Sym)
THEN
- printf0 ('[') ; WriteMode (GetMode (Sym)) ; printf0(']')
+ fprintf0 (GetDumpFile (), '[') ; WriteMode (GetMode (Sym)) ; fprintf0
(GetDumpFile (), ']')
END ;
- printf1 ('(%d)', Sym)
+ fprintf1 (GetDumpFile (), '(%d)', Sym)
END
END WriteOperand ;
@@ -13801,10 +13909,10 @@ PROCEDURE WriteMode (Mode: ModeOfAddr) ;
BEGIN
CASE Mode OF
- ImmediateValue: printf0('i') |
- NoValue : printf0('n') |
- RightValue : printf0('r') |
- LeftValue : printf0('l')
+ ImmediateValue: fprintf0 (GetDumpFile (), 'i') |
+ NoValue : fprintf0 (GetDumpFile (), 'n') |
+ RightValue : fprintf0 (GetDumpFile (), 'r') |
+ LeftValue : fprintf0 (GetDumpFile (), 'l')
ELSE
InternalError ('unrecognised mode')
@@ -15506,7 +15614,7 @@ BEGIN
FreeLineList := NIL ;
InitList(VarientFields) ;
VarientFieldNo := 0 ;
- NoOfQuads := 0
+ NoOfQuads := 0 ;
END Init ;
diff --git a/gcc/m2/gm2-compiler/M2Scope.mod b/gcc/m2/gm2-compiler/M2Scope.mod
index f157ad42ba6..2c2ff459d81 100644
--- a/gcc/m2/gm2-compiler/M2Scope.mod
+++ b/gcc/m2/gm2-compiler/M2Scope.mod
@@ -29,7 +29,6 @@ FROM SymbolTable IMPORT IsProcedure, IsDefImp,
GetProcedureQuads, GetScope,
GetProcedureScope, IsModule, IsModuleWithinProcedure,
GetSymName, GetErrorScope, NulSym ;
-FROM M2Options IMPORT DisplayQuadruples ;
FROM M2Printf IMPORT printf0, printf1 ;
FROM M2Quads IMPORT QuadOperator, GetFirstQuad, GetNextQuad, GetQuad,
DisplayQuadRange ;
FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord,
@@ -38,7 +37,8 @@ IMPORT M2Error ;
CONST
- Debugging = FALSE ;
+ Debugging = FALSE ;
+ TraceQuadruples = FALSE ;
TYPE
scopeKind = (unsetscope, ignorescope, procedurescope, modulescope,
definitionscope, implementationscope, programscope) ;
@@ -381,7 +381,7 @@ BEGIN
ELSE
sb := GetGlobalQuads (sb, scope) ;
END ;
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayScope (sb)
END
@@ -416,13 +416,13 @@ END KillScopeBlock ;
PROCEDURE ForeachScopeBlockDo2 (sb: ScopeBlock; p: ScopeProcedure2) ;
BEGIN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
printf0 ("ForeachScopeBlockDo\n")
END ;
WHILE sb#NIL DO
WITH sb^ DO
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayScope (sb)
END ;
@@ -435,7 +435,7 @@ BEGIN
END ;
sb := sb^.next
END ;
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
printf0 ("end ForeachScopeBlockDo\n\n")
END ;
@@ -449,13 +449,13 @@ END ForeachScopeBlockDo2 ;
PROCEDURE ForeachScopeBlockDo3 (sb: ScopeBlock; p: ScopeProcedure3) ;
BEGIN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
printf0 ("ForeachScopeBlockDo\n")
END ;
WHILE sb#NIL DO
WITH sb^ DO
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayScope (sb)
END ;
@@ -468,7 +468,7 @@ BEGIN
END ;
sb := sb^.next
END ;
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
printf0 ("end ForeachScopeBlockDo\n\n")
END ;
diff --git a/gcc/m2/gm2-compiler/SymbolConversion.def
b/gcc/m2/gm2-compiler/SymbolConversion.def
index 8f8d4650ce2..81a52e4aa1e 100644
--- a/gcc/m2/gm2-compiler/SymbolConversion.def
+++ b/gcc/m2/gm2-compiler/SymbolConversion.def
@@ -31,8 +31,6 @@ DEFINITION MODULE SymbolConversion ;
FROM m2tree IMPORT Tree ;
FROM SYSTEM IMPORT WORD ;
-EXPORT QUALIFIED Mod2Gcc, AddModGcc, GccKnowsAbout, AddTemporaryKnown,
- RemoveTemporaryKnown, Poison, RemoveMod2Gcc ;
(*
@@ -42,6 +40,13 @@ EXPORT QUALIFIED Mod2Gcc, AddModGcc, GccKnowsAbout,
AddTemporaryKnown,
PROCEDURE Mod2Gcc (sym: CARDINAL) : Tree ;
+(*
+ Gcc2Mod - given a gcc tree return the modula-2 symbol.
+*)
+
+PROCEDURE Gcc2Mod (tree: Tree) : CARDINAL ;
+
+
(*
AddModGcc - adds the tuple [ sym, gcc ] into the database.
*)
diff --git a/gcc/m2/gm2-compiler/SymbolConversion.mod
b/gcc/m2/gm2-compiler/SymbolConversion.mod
index b8f0f70b435..738b40d5be5 100644
--- a/gcc/m2/gm2-compiler/SymbolConversion.mod
+++ b/gcc/m2/gm2-compiler/SymbolConversion.mod
@@ -24,10 +24,10 @@ IMPLEMENTATION MODULE SymbolConversion ;
FROM NameKey IMPORT Name ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, InBounds,
- DebugIndex, InitIndexTuned ;
+ DebugIndex, InitIndexTuned, HighIndice ;
FROM SymbolTable IMPORT IsConst, PopValue, IsValueSolved, GetSymName,
- GetType, SkipType ;
+ GetType, SkipType, NulSym ;
FROM M2Error IMPORT InternalError ;
FROM M2ALU IMPORT PushTypeOfTree ;
@@ -87,6 +87,27 @@ BEGIN
END Mod2Gcc ;
+(*
+ Gcc2Mod - given a gcc tree return the modula-2 symbol.
+*)
+
+PROCEDURE Gcc2Mod (tree: Tree) : CARDINAL ;
+VAR
+ high, i: CARDINAL ;
+BEGIN
+ i := 1 ;
+ high := HighIndice (mod2gcc) ;
+ WHILE i <= high DO
+ IF GetIndice (mod2gcc, i) = tree
+ THEN
+ RETURN i
+ END ;
+ INC (i)
+ END ;
+ RETURN NulSym
+END Gcc2Mod ;
+
+
(*
AddModGcc - adds the tuple [ sym, gcc ] into the database.
*)
diff --git a/gcc/m2/gm2-gcc/m2langdump.h b/gcc/m2/gm2-gcc/m2langdump.h
new file mode 100644
index 00000000000..4170d8538d9
--- /dev/null
+++ b/gcc/m2/gm2-gcc/m2langdump.h
@@ -0,0 +1,41 @@
+/* m2langdump.h header file for m2langdump.cc.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusm...@gmail.com>.
+
+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/>. */
+
+#if !defined(m2langdump_h)
+#define m2langdump_h
+#if defined(m2langdump_c)
+#if defined(__GNUG__)
+#define EXTERN extern "C"
+#else /* !__GNUG__. */
+#define EXTERN
+#endif /* !__GNUG__. */
+#else /* !m2langdump_c. */
+#if defined(__GNUG__)
+#define EXTERN extern "C"
+#else /* !__GNUG__. */
+#define EXTERN extern
+#endif /* !__GNUG__. */
+#endif /* !m2langdump_c. */
+
+EXTERN bool M2LangDump_IsDumpRequiredTree (tree fndecl, bool defaultvalue);
+
+#undef EXTERN
+#endif /* m2langdump_h. */
diff --git a/gcc/m2/gm2-gcc/m2misc.cc b/gcc/m2/gm2-gcc/m2misc.cc
index d69f33c003d..451abfe14f9 100644
--- a/gcc/m2/gm2-gcc/m2misc.cc
+++ b/gcc/m2/gm2-gcc/m2misc.cc
@@ -29,7 +29,7 @@ along with GNU Modula-2; see the file COPYING3. If not see
#include "m2misc.h"
#include "m2tree.h"
-/* DebugTree - display the tree, t. */
+/* DebugTree - display the tree t. */
void
m2misc_DebugTree (tree t)
@@ -37,7 +37,7 @@ m2misc_DebugTree (tree t)
debug_tree (t);
}
-/* DebugTree - display the tree, t. */
+/* DebugTree - display the trees chained in t. */
void
m2misc_DebugTreeChain (tree t)
@@ -46,7 +46,7 @@ m2misc_DebugTreeChain (tree t)
debug_tree (t);
}
-/* DebugTree - display the tree, t. */
+/* DebugTree - display the current statement list. */
void
m2misc_printStmt (void)
diff --git a/gcc/m2/gm2-gcc/m2options.h b/gcc/m2/gm2-gcc/m2options.h
index 01256a9fc80..a03fdc5975f 100644
--- a/gcc/m2/gm2-gcc/m2options.h
+++ b/gcc/m2/gm2-gcc/m2options.h
@@ -152,6 +152,15 @@ EXTERN void M2Options_SetIBMLongDouble (bool value);
EXTERN bool M2Options_GetIBMLongDouble (void);
EXTERN void M2Options_SetIEEELongDouble (bool value);
EXTERN bool M2Options_GetIEEELongDouble (void);
+EXTERN bool M2Options_GetDumpLangDeclFilename (void);
+EXTERN void M2Options_SetDumpLangDeclFilename (bool value, const char *arg);
+EXTERN bool M2Options_GetDumpLangQuadFilename (void);
+EXTERN void M2Options_SetDumpLangQuadFilename (bool value, const char *arg);
+EXTERN bool M2Options_GetDumpLangGimpleFilename (void);
+EXTERN void M2Options_SetDumpLangGimpleFilename (bool value, const char *arg);
+EXTERN bool M2Options_GetDumpLangGimple (void);
+EXTERN void M2Options_SetM2DumpFilter (bool value, const char *args);
+EXTERN char *M2Options_GetM2DumpFilter (void);
#undef EXTERN
#endif /* m2options_h. */
diff --git a/gcc/m2/m2pp.cc b/gcc/m2/gm2-gcc/m2pp.cc
similarity index 90%
rename from gcc/m2/m2pp.cc
rename to gcc/m2/gm2-gcc/m2pp.cc
index 2f4c45ced14..de8015864e3 100644
--- a/gcc/m2/m2pp.cc
+++ b/gcc/m2/gm2-gcc/m2pp.cc
@@ -19,28 +19,27 @@ 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/>. */
-#if defined(GM2)
-#include "gm2-gcc/gcc-consolidation.h"
+#include "gcc-consolidation.h"
-#include "m2-tree.h"
-#include "gm2-lang.h"
+#include "../m2-tree.h"
+#include "../gm2-lang.h"
-#include "gm2-gcc/m2tree.h"
-#include "gm2-gcc/m2expr.h"
-#include "gm2-gcc/m2type.h"
-#include "gm2-gcc/m2decl.h"
-#else
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "cp/cp-tree.h"
-#include "stringpool.h"
-#include "gm2-gcc/gcc-consolidation.h"
-#include "../cp/cp-tree.h"
-#endif
+#include "m2tree.h"
+#include "m2expr.h"
+#include "m2type.h"
+#include "m2decl.h"
+#include "m2options.h"
+#include "m2langdump.h"
#define M2PP_C
-#include "m2/m2pp.h"
+#include "m2pp.h"
+
+const char *m2pp_dump_description[M2PP_DUMP_END] =
+{
+ "interactive user invoked output",
+ "modula-2 gimple trees pre genercize",
+ "modula-2 gimple trees post genercize",
+};
namespace modula2 {
@@ -48,13 +47,14 @@ namespace modula2 {
typedef struct pretty_t
{
- int needs_space;
- int needs_indent;
+ m2pp_dump_kind output;
+ bool needs_space;
+ bool needs_indent;
int curpos;
int indent;
- int issued_begin;
- int in_vars;
- int in_types;
+ bool issued_begin;
+ bool in_vars;
+ bool in_types;
tree block;
int bits;
} pretty;
@@ -67,7 +67,7 @@ typedef struct m2stack_t
/* Prototypes. */
-static pretty *initPretty (int bits);
+static pretty *initPretty (m2pp_dump_kind kind, int bits);
static pretty *dupPretty (pretty *s);
static int getindent (pretty *s);
static void setindent (pretty *s, int n);
@@ -153,9 +153,11 @@ static void m2pp_translation (pretty *s, tree t);
static void m2pp_module_block (pretty *s, tree t);
static void push (tree t);
static void pop (void);
-static int begin_printed (tree t);
+static bool begin_printed (tree t);
static void m2pp_decl_list (pretty *s, tree t);
static void m2pp_loc (pretty *s, tree t);
+static FILE *getoutput (pretty *s);
+
void pet (tree t);
void m2pp_integer (pretty *s, tree t);
@@ -163,13 +165,14 @@ void m2pp_integer (pretty *s, tree t);
extern void stop (void);
static stack *stackPtr = NULL;
+static FILE *m2pp_output_file[M2PP_DUMP_END];
/* do_pf helper function for pf. */
void
do_pf (tree t, int bits)
{
- pretty *state = initPretty (bits);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, bits);
if (TREE_CODE (t) == TRANSLATION_UNIT_DECL)
m2pp_translation (state, t);
@@ -188,7 +191,7 @@ do_pf (tree t, int bits)
void
pf (tree t)
{
- do_pf (t, FALSE);
+ do_pf (t, false);
}
/* pe print expression. Expected to be printed interactively from
@@ -197,7 +200,7 @@ pf (tree t)
void
pe (tree t)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_expression (state, t);
m2pp_needspace (state);
@@ -212,7 +215,7 @@ pe (tree t)
void
pet (tree t)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_expression (state, t);
m2pp_needspace (state);
@@ -228,7 +231,7 @@ pet (tree t)
void
pt (tree t)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_type (state, t);
m2pp_needspace (state);
m2pp_print (state, ";\n");
@@ -241,7 +244,7 @@ pt (tree t)
void
ptl (tree t)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_type_lowlevel (state, t);
m2pp_needspace (state);
m2pp_print (state, ";\n");
@@ -253,7 +256,7 @@ ptl (tree t)
void
ptcl (tree t)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_decl_list (state, t);
m2pp_print (state, "\n");
@@ -278,7 +281,7 @@ m2pp_loc (pretty *s, tree t)
m2pp_print (s, "(* ");
m2pp_print (s, l.file);
m2pp_print (s, ":");
- printf ("%d", l.line);
+ fprintf (getoutput (s), "%d", l.line);
m2pp_print (s, " *)");
m2pp_print (s, "\n");
}
@@ -332,7 +335,7 @@ pv (tree t)
if (code == PARM_DECL)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_identifier (state, t);
m2pp_needspace (state);
m2pp_print (state, "<parm_decl context = ");
@@ -350,7 +353,7 @@ pv (tree t)
}
if (code == VAR_DECL)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
m2pp_identifier (state, t);
m2pp_needspace (state);
m2pp_print (state, "(* <var_decl context = ");
@@ -407,9 +410,9 @@ pop (void)
free (s);
}
-/* being_printed returns TRUE if t is held on the stack. */
+/* being_printed returns true if t is held on the stack. */
-static int
+static bool
begin_printed (tree t)
{
stack *s = stackPtr;
@@ -417,11 +420,11 @@ begin_printed (tree t)
while (s != NULL)
{
if (s->value == t)
- return TRUE;
+ return true;
else
s = s->next;
}
- return FALSE;
+ return false;
}
/* dupPretty duplicate and return a copy of state s. */
@@ -429,7 +432,7 @@ begin_printed (tree t)
static pretty *
dupPretty (pretty *s)
{
- pretty *p = initPretty (s->bits);
+ pretty *p = initPretty (s->output, s->bits);
*p = *s;
return p;
}
@@ -437,16 +440,17 @@ dupPretty (pretty *s)
/* initPretty initialise the state of the pretty printer. */
static pretty *
-initPretty (int bits)
+initPretty (m2pp_dump_kind kind, int bits)
{
pretty *state = (pretty *)xmalloc (sizeof (pretty));
- state->needs_space = FALSE;
- state->needs_indent = FALSE;
+ state->output = kind;
+ state->needs_space = false;
+ state->needs_indent = false;
state->curpos = 0;
state->indent = 0;
- state->issued_begin = FALSE;
- state->in_vars = FALSE;
- state->in_types = FALSE;
+ state->issued_begin = false;
+ state->in_vars = false;
+ state->in_types = false;
state->block = NULL_TREE;
state->bits = bits;
return state;
@@ -457,8 +461,8 @@ initPretty (int bits)
static void
killPretty (pretty *s)
{
+ fflush (getoutput (s));
free (s);
- fflush (stdout);
}
/* getindent returns the current indent value. */
@@ -488,6 +492,12 @@ getcurpos (pretty *s)
return s->curpos;
}
+static FILE *
+getoutput (pretty *s)
+{
+ return m2pp_output_file[s->output];
+}
+
/* m2pp_type_lowlevel prints out the low level details of a
fundamental type. */
@@ -509,9 +519,10 @@ m2pp_type_lowlevel (pretty *s, tree t)
m2pp_needspace (s);
m2pp_integer_cst (s, TYPE_SIZE (t));
- printf (", precision %d, mode %d, align %d, user align %d",
- TYPE_PRECISION (t), TYPE_MODE (t), TYPE_ALIGN (t),
- TYPE_USER_ALIGN (t));
+ fprintf (getoutput (s),
+ ", precision %d, mode %d, align %d, user align %d",
+ TYPE_PRECISION (t), TYPE_MODE (t), TYPE_ALIGN (t),
+ TYPE_USER_ALIGN (t));
m2pp_needspace (s);
if (TYPE_UNSIGNED (t))
@@ -528,7 +539,7 @@ m2pp_var (pretty *s)
{
if (!s->in_vars)
{
- s->in_vars = TRUE;
+ s->in_vars = true;
m2pp_print (s, "VAR\n");
setindent (s, getindent (s) + 3);
}
@@ -541,7 +552,7 @@ m2pp_types (pretty *s)
{
if (!s->in_types)
{
- s->in_types = TRUE;
+ s->in_types = true;
m2pp_print (s, "TYPE\n");
setindent (s, getindent (s) + 3);
}
@@ -581,7 +592,7 @@ hextree (tree t)
}
if (VAR_P (t))
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
printf ("(* VAR_DECL %p <", (void *)t);
if (DECL_SEEN_IN_BIND_EXPR_P (t))
@@ -598,7 +609,7 @@ hextree (tree t)
}
if (TREE_CODE (t) == PARM_DECL)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, 0);
printf ("(* PARM_DECL %p <", (void *)t);
printf ("> context = %p*)\n", (void *)decl_function_context (t));
@@ -647,14 +658,14 @@ m2pp_module_block (pretty *s, tree t)
if (!DECL_EXTERNAL (t))
{
pretty *p = dupPretty (s);
- printf ("\n");
- p->in_vars = FALSE;
- p->in_types = FALSE;
+ fprintf (getoutput (s), "\n");
+ p->in_vars = false;
+ p->in_types = false;
m2pp_function (p, t);
killPretty (p);
- printf ("\n");
- s->in_vars = FALSE;
- s->in_types = FALSE;
+ fprintf (getoutput (s), "\n");
+ s->in_vars = false;
+ s->in_types = false;
}
break;
@@ -674,7 +685,7 @@ m2pp_module_block (pretty *s, tree t)
setindent (s, o);
m2pp_needspace (s);
m2pp_print (s, ";\n");
- s->in_vars = FALSE;
+ s->in_vars = false;
}
break;
@@ -687,11 +698,11 @@ m2pp_module_block (pretty *s, tree t)
m2pp_type (s, TREE_TYPE (t));
m2pp_needspace (s);
m2pp_print (s, ";\n");
- s->in_types = FALSE;
+ s->in_types = false;
break;
case DECL_EXPR:
- printf ("is this node legal here? \n");
+ fprintf (getoutput (s), "is this node legal here? \n");
m2pp_decl_expr (s, t);
break;
@@ -719,9 +730,9 @@ m2pp_begin (pretty *s)
m2pp_print (s, "BEGIN\n");
setindent (s, getindent (s) + 3);
}
- s->issued_begin = TRUE;
- s->in_vars = FALSE;
- s->in_types = FALSE;
+ s->issued_begin = true;
+ s->in_vars = false;
+ s->in_types = false;
}
}
@@ -817,18 +828,18 @@ m2pp_var_list (pretty *s, tree t)
if (TREE_CODE (t) == FUNCTION_DECL)
{
pretty *p = dupPretty (s);
- printf ("\n");
- p->in_vars = FALSE;
- p->in_types = FALSE;
+ fprintf (getoutput (s), "\n");
+ p->in_vars = false;
+ p->in_types = false;
m2pp_function (p, t);
killPretty (p);
- printf ("\n");
+ fprintf (getoutput (s), "\n");
}
else if (TREE_CODE (t) == TYPE_DECL)
m2pp_identifier (s, t);
else if (TREE_CODE (t) == DECL_EXPR)
{
- printf ("is this node legal here? \n");
+ fprintf (getoutput (s), "is this node legal here? \n");
// is it legal to have a DECL_EXPR here ?
m2pp_var_type_decl (s, DECL_EXPR_DECL (t));
}
@@ -857,12 +868,12 @@ m2pp_type_list (pretty *s, tree t)
}
#endif
-/* m2pp_needspace sets appropriate flag to TRUE. */
+/* m2pp_needspace sets appropriate flag to true. */
static void
m2pp_needspace (pretty *s)
{
- s->needs_space = TRUE;
+ s->needs_space = true;
}
/* m2pp_identifer prints an identifier. */
@@ -957,7 +968,7 @@ m2pp_procedure_type (pretty *s, tree t)
{
int o = getindent (s);
int p;
- int first = TRUE;
+ bool first = true;
m2pp_print (s, "(");
p = getcurpos (s);
@@ -986,7 +997,7 @@ m2pp_procedure_type (pretty *s, tree t)
m2pp_param_type (s, TREE_VALUE (i));
}
i = TREE_CHAIN (i);
- first = FALSE;
+ first = false;
}
m2pp_print (s, ")");
setindent (s, o);
@@ -1158,8 +1169,8 @@ m2pp_print (pretty *s, const char *p)
if (s->needs_space)
{
- printf (" ");
- s->needs_space = FALSE;
+ fprintf (getoutput (s), " ");
+ s->needs_space = false;
s->curpos++;
}
@@ -1167,21 +1178,21 @@ m2pp_print (pretty *s, const char *p)
{
if (p[i] == '\n')
{
- s->needs_indent = TRUE;
+ s->needs_indent = true;
s->curpos = 0;
- printf ("\n");
+ fprintf (getoutput (s), "\n");
}
else
{
if (s->needs_indent)
{
if (s->indent > 0)
- printf ("%*c", s->indent, ' ');
- s->needs_indent = FALSE;
+ fprintf (getoutput (s), "%*c", s->indent, ' ');
+ s->needs_indent = false;
s->curpos += s->indent;
}
s->curpos++;
- putchar (p[i]);
+ fputc (p[i], getoutput (s));
}
i++;
}
@@ -1196,25 +1207,25 @@ m2pp_print_char (pretty *s, char ch)
{
if (s->needs_space)
{
- printf (" ");
- s->needs_space = FALSE;
+ fprintf (getoutput (s), " ");
+ s->needs_space = false;
s->curpos++;
}
if (s->needs_indent)
{
if (s->indent > 0)
- printf ("%*c", s->indent, ' ');
- s->needs_indent = FALSE;
+ fprintf (getoutput (s), "%*c", s->indent, ' ');
+ s->needs_indent = false;
s->curpos += s->indent;
}
if (ch == '\n')
{
s->curpos++;
- putchar ('\\');
- putchar ('n');
+ fputc ('\\', getoutput (s));
+ fputc ('n', getoutput (s));
}
else
- putchar (ch);
+ fputc (ch, getoutput (s));
s->curpos++;
}
@@ -1531,7 +1542,7 @@ m2pp_recordfield_alignment (pretty *s, tree t)
m2pp_print (s, "<* bytealignment (");
setindent (s, p + 18);
- printf ("%d", aligned / BITS_PER_UNIT);
+ fprintf (getoutput (s), "%d", aligned / BITS_PER_UNIT);
m2pp_print (s, ")");
m2pp_needspace (s);
@@ -2247,13 +2258,13 @@ m2pp_try_finally_expr (pretty *s, tree t)
m2pp_print (s, "(* end try_finally_expr *)\n");
}
-#if !defined(GM2)
-/* m2pp_if_stmt pretty print a C++ if_stmt. */
+/* m2pp_if_stmt pretty print a if_stmt tree. Modula-2 does not use this to
+ generate IF THEN ELSE END statements, instead it uses labels and gotos. */
static void
m2pp_if_stmt (pretty *s, tree t)
{
- m2pp_print (s, "(* only C++ uses if_stmt nodes *)\n");
+ m2pp_print (s, "(* An if_stmt node. *)\n");
m2pp_print (s, "IF ");
m2pp_expression (s, TREE_OPERAND (t, 0));
m2pp_print (s, "\n");
@@ -2267,7 +2278,6 @@ m2pp_if_stmt (pretty *s, tree t)
setindent (s, getindent (s) - 3);
m2pp_print (s, "END\n");
}
-#endif
static void
m2pp_asm_expr (pretty *state, tree node)
@@ -2362,11 +2372,9 @@ m2pp_statement (pretty *s, tree t)
case ASM_EXPR:
m2pp_asm_expr (s, t);
break;
-#if defined(CPP)
case IF_STMT:
m2pp_if_stmt (s, t);
break;
-#endif
case ERROR_MARK:
m2pp_print (s, "<ERROR CODE>\n");
break;
@@ -2396,9 +2404,9 @@ static void
m2pp_cleanup_point_expr (pretty *s, tree t)
{
m2pp_begin (s);
- m2pp_print (s, "(* cleanup point begins *)\n");
+ m2pp_print (s, "(* Cleanup point begins. *)\n");
m2pp_expression (s, TREE_OPERAND (t, 0));
- m2pp_print (s, "(* cleanup point ends *)\n");
+ m2pp_print (s, "(* Cleanup point ends. *)\n");
}
/* m2pp_decl_expr displays a local declaration. */
@@ -2407,7 +2415,7 @@ static void
m2pp_decl_expr (pretty *s, tree t)
{
m2pp_var (s);
- m2pp_print (s, "(* variable in decl_expr *)\n");
+ m2pp_print (s, "(* Variable in decl_expr. *)\n");
m2pp_var_type_decl (s, DECL_EXPR_DECL (t));
}
@@ -2452,11 +2460,11 @@ m2pp_call_expr (pretty *s, tree t)
tree call = CALL_EXPR_FN (t);
tree args = TREE_OPERAND (t, 1);
tree type = TREE_TYPE (t);
- int has_return_type = TRUE;
+ bool has_return_type = true;
tree proc;
if (type && VOID_TYPE_P (type))
- has_return_type = FALSE;
+ has_return_type = false;
if (TREE_CODE (call) == ADDR_EXPR || TREE_CODE (call) == NON_LVALUE_EXPR)
proc = TREE_OPERAND (call, 0);
@@ -2738,3 +2746,102 @@ m2pp_component_ref (pretty *s, tree t)
}
}
+
+/* Code interface to this module. */
+
+/* CreateDumpGimple creates the dump files using the template name. */
+
+void
+m2pp_CreateDumpGimple (char *template_name, int template_len)
+{
+ int kind = M2PP_DUMP_STDOUT;
+ modula2::m2pp_output_file[kind] = stdout;
+ kind++;
+ for (; kind < M2PP_DUMP_END; kind++)
+ {
+ if (kind == M2PP_DUMP_FD)
+ modula2::m2pp_output_file[kind] = NULL;
+ else
+ {
+ char *name = (char *)alloca (template_len);
+
+ snprintf (name, template_len, template_name, kind);
+ modula2::m2pp_output_file[kind] = fopen (name, "w");
+ if (modula2::m2pp_output_file[kind] == NULL)
+ {
+ fprintf (stderr, "unable to create dump file %s: %s\n",
+ name, xstrerror (errno));
+ exit (1);
+ }
+ fprintf (modula2::m2pp_output_file[kind], "%s\n\n",
+ m2pp_dump_description[kind]);
+ }
+ }
+}
+
+/* Close all dump files and fflush stdout. */
+
+void
+m2pp_CloseDumpGimple (void)
+{
+ int kind = M2PP_DUMP_STDOUT;
+ fflush (modula2::m2pp_output_file[kind]);
+ kind++;
+ for (; kind < M2PP_DUMP_END; kind++)
+ if (kind != M2PP_DUMP_FD)
+ fclose (modula2::m2pp_output_file[kind]);
+}
+
+/* m2pp_dump_gimple_pretty create an initPretty object and print
+ fndecl to kind output. */
+
+void
+m2pp_dump_gimple_pretty (m2pp_dump_kind kind, tree fndecl)
+{
+ modula2::pretty *state = modula2::initPretty (kind, 0);
+
+ modula2::m2pp_print (state, "\n");
+ if (TREE_CODE (fndecl) == TRANSLATION_UNIT_DECL)
+ modula2::m2pp_translation (state, fndecl);
+ else if (TREE_CODE (fndecl) == BLOCK)
+ modula2::m2pp_module_block (state, fndecl);
+ else if (TREE_CODE (fndecl) == FUNCTION_DECL)
+ modula2::m2pp_function (state, fndecl);
+ else
+ modula2::m2pp_statement_sequence (state, fndecl);
+ modula2::killPretty (state);
+}
+
+
+/* Generate modula-2 style gimple for fndecl. */
+
+void
+m2pp_dump_gimple (m2pp_dump_kind kind, tree fndecl)
+{
+ if (M2Options_GetDumpLangGimple ()
+ && M2LangDump_IsDumpRequiredTree (fndecl, true))
+ m2pp_dump_gimple_pretty (kind, fndecl);
+}
+
+
+/* Dump fndecl to a file descriptor. */
+
+void
+m2pp_DumpGimpleFd (int fd, tree fndecl)
+{
+ FILE *f = fdopen (fd, "a");
+ if (f != NULL)
+ {
+#if 0
+ modula2::m2pp_output_file[M2PP_DUMP_FD] = f;
+ m2pp_dump_gimple_pretty (M2PP_DUMP_FD, fndecl);
+ fprintf (f, "\n");
+#endif
+ print_node (f, "m2 tree", fndecl, 1);
+ fprintf (f, "\n\n");
+ fflush (f);
+#if 0
+ modula2::m2pp_output_file[M2PP_DUMP_FD] = NULL;
+#endif
+ }
+}
diff --git a/gcc/m2/gm2-gcc/m2pp.def b/gcc/m2/gm2-gcc/m2pp.def
new file mode 100644
index 00000000000..20077176da2
--- /dev/null
+++ b/gcc/m2/gm2-gcc/m2pp.def
@@ -0,0 +1,45 @@
+(* m2pp.def definition module for m2pp.cc.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusm...@gmail.com>.
+
+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/>. *)
+
+DEFINITION MODULE FOR "C" m2pp ;
+
+FROM SYSTEM IMPORT ADDRESS ;
+FROM m2tree IMPORT Tree ;
+
+
+(*
+ CreateDumpGimple - create the gimple dump files.
+*)
+
+PROCEDURE CreateDumpGimple (templatename: ADDRESS; templatelen: CARDINAL) ;
+
+
+(*
+ CloseDumpGimple - close the gimple dump files.
+*)
+
+PROCEDURE CloseDumpGimple ;
+
+
+PROCEDURE DumpGimpleFd (fd: INTEGER; fndecl: Tree) ;
+
+
+END m2pp.
diff --git a/gcc/m2/m2pp.h b/gcc/m2/gm2-gcc/m2pp.h
similarity index 54%
rename from gcc/m2/m2pp.h
rename to gcc/m2/gm2-gcc/m2pp.h
index e901102fab7..6391bda5956 100644
--- a/gcc/m2/m2pp.h
+++ b/gcc/m2/gm2-gcc/m2pp.h
@@ -19,17 +19,39 @@ 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/>. */
-#if !defined(M2PP_H)
-# define M2PP_H
+#if !defined(m2pp_h)
+#define m2pp_h
+#if defined(m2pp_c)
+#if defined(__GNUG__)
+#define EXTERN extern "C"
+#else /* !__GNUG__. */
+#define EXTERN
+#endif /* !__GNUG__. */
+#else /* !m2pp_c. */
+#if defined(__GNUG__)
+#define EXTERN extern "C"
+#else /* !__GNUG__. */
+#define EXTERN extern
+#endif /* !__GNUG__. */
+#endif /* !m2pp_c. */
-# if defined(M2PP_C)
-# define EXTERN
-# else
-# define EXTERN extern
-# endif
+typedef enum
+{
+ M2PP_DUMP_STDOUT, /* This must remain the first field. */
+ M2PP_DUMP_PRE_GENERICIZE,
+ M2PP_DUMP_POST_GENERICIZE,
+ M2PP_DUMP_FD,
+ M2PP_DUMP_END,
+} m2pp_dump_kind;
+
+EXTERN void m2pp_CreateDumpGimple (char *template_name, int template_len);
+EXTERN void m2pp_dump_gimple (m2pp_dump_kind kind, tree fndecl);
+EXTERN void m2pp_CloseDumpGimple (void);
+EXTERN void m2pp_DumpGimpleFd (int fd, tree fndecl);
namespace modula2 {
-/* These functions allow a maintainer to dump the trees in Modula-2. */
+/* GDB Interactive interface to m2pp. Allow a maintainer to dump
+ the trees in Modula-2. */
EXTERN void pf (tree t);
EXTERN void pe (tree t);
diff --git a/gcc/m2/gm2-gcc/m2statement.cc b/gcc/m2/gm2-gcc/m2statement.cc
index 3c048d40a99..dd7f2529f5d 100644
--- a/gcc/m2/gm2-gcc/m2statement.cc
+++ b/gcc/m2/gm2-gcc/m2statement.cc
@@ -36,6 +36,7 @@ along with GNU Modula-2; see the file COPYING3. If not see
#include "m2treelib.h"
#include "m2type.h"
#include "m2convert.h"
+#include "m2pp.h"
static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we
call/define a function. */
@@ -102,11 +103,15 @@ m2statement_BuildEndFunctionCode (location_t location,
tree fndecl, bool nested)
m2block_finishFunctionCode (fndecl);
m2statement_SetEndLocation (location);
+ m2pp_dump_gimple (M2PP_DUMP_PRE_GENERICIZE, fndecl);
gm2_genericize (fndecl);
if (nested)
(void)cgraph_node::get_create (fndecl);
else
- cgraph_node::finalize_function (fndecl, false);
+ {
+ m2pp_dump_gimple (M2PP_DUMP_POST_GENERICIZE, fndecl);
+ cgraph_node::finalize_function (fndecl, false);
+ }
m2block_popFunctionScope ();
diff --git a/gcc/m2/gm2-lang.cc b/gcc/m2/gm2-lang.cc
index 86124df603a..bde68368e1f 100644
--- a/gcc/m2/gm2-lang.cc
+++ b/gcc/m2/gm2-lang.cc
@@ -42,6 +42,8 @@ Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA
#include "convert.h"
#include "rtegraph.h"
+#undef ENABLE_QUAD_DUMP_ALL
+
static void write_globals (void);
static int insideCppArgs = FALSE;
@@ -214,8 +216,7 @@ gm2_langhook_init_options (unsigned int
decoded_options_count,
M2Options_Setc (value);
break;
case OPT_dumpdir:
- if (building_cpp_command)
- M2Options_SetDumpDir (arg);
+ M2Options_SetDumpDir (arg);
break;
case OPT_save_temps:
if (building_cpp_command)
@@ -407,6 +408,9 @@ gm2_langhook_handle_option (
switch (code)
{
+ case OPT_dumpdir:
+ M2Options_SetDumpDir (arg);
+ return 1;
case OPT_I:
push_back_Ipath (arg);
return 1;
@@ -479,6 +483,31 @@ gm2_langhook_handle_option (
case OPT_fdebug_function_line_numbers:
M2Options_SetDebugFunctionLineNumbers (value);
return 1;
+#ifdef ENABLE_QUAD_DUMP_ALL
+ case OPT_fdump_lang_all:
+ M2Options_SetDumpLangDeclFilename (value, NULL);
+ M2Options_SetDumpLangGimpleFilename (value, NULL);
+ M2Options_SetDumpLangQuadFilename (value, NULL);
+ return 1;
+ case OPT_fdump_lang_decl:
+ M2Options_SetDumpLangDeclFilename (value, NULL);
+ return 1;
+ case OPT_fdump_lang_decl_:
+ M2Options_SetDumpLangDeclFilename (value, arg);
+ return 1;
+ case OPT_fdump_lang_gimple:
+ M2Options_SetDumpLangGimpleFilename (value, NULL);
+ return 1;
+ case OPT_fdump_lang_gimple_:
+ M2Options_SetDumpLangGimpleFilename (value, arg);
+ return 1;
+ case OPT_fdump_lang_quad:
+ M2Options_SetDumpLangQuadFilename (value, NULL);
+ return 1;
+ case OPT_fdump_lang_quad_:
+ M2Options_SetDumpLangQuadFilename (value, arg);
+ return 1;
+#endif
case OPT_fauto_init:
M2Options_SetAutoInit (value);
return 1;
@@ -519,6 +548,11 @@ gm2_langhook_handle_option (
case OPT_fm2_strict_type:
M2Options_SetStrictTypeChecking (value);
return 1;
+#ifdef ENABLE_QUAD_DUMP_ALL
+ case OPT_fm2_dump_filter_:
+ M2Options_SetM2DumpFilter (value, arg);
+ return 1;
+#endif
case OPT_Wall:
M2Options_SetWall (value);
return 1;
diff --git a/gcc/m2/gm2-libs/DynamicStrings.def
b/gcc/m2/gm2-libs/DynamicStrings.def
index 29f4989b794..25c27e8a939 100644
--- a/gcc/m2/gm2-libs/DynamicStrings.def
+++ b/gcc/m2/gm2-libs/DynamicStrings.def
@@ -29,7 +29,7 @@ DEFINITION MODULE DynamicStrings ;
FROM SYSTEM IMPORT ADDRESS ;
EXPORT QUALIFIED String,
InitString, KillString, Fin, InitStringCharStar,
- InitStringChar, Index, RIndex,
+ InitStringChar, Index, RIndex, ReverseIndex,
Mark, Length, ConCat, ConCatChar, Assign, Dup, Add,
Equal, EqualCharStar, EqualArray, ToUpper, ToLower,
CopyOut, Mult, Slice, ReplaceChar,
@@ -201,13 +201,27 @@ PROCEDURE Index (s: String; ch: CHAR; o: CARDINAL) :
INTEGER ;
(*
RIndex - returns the indice of the last occurance of, ch,
- in String, s. The search starts at position, o.
- -1 is returned if, ch, is not found.
+ in String, s. The search starts at position, o.
+ -1 is returned if ch is not found. The search
+ is performed left to right.
*)
PROCEDURE RIndex (s: String; ch: CHAR; o: CARDINAL) : INTEGER ;
+(*
+ ReverseIndex - returns the indice of the last occurance of ch
+ in String s. The search starts at position o
+ and searches from right to left. The start position
+ may be indexed negatively from the right (-1 is the
+ last index).
+ The return value if ch is found will always be positive.
+ -1 is returned if ch is not found.
+*)
+
+PROCEDURE ReverseIndex (s: String; ch: CHAR; o: INTEGER) : INTEGER ;
+
+
(*
RemoveComment - assuming that, comment, is a comment delimiter
which indicates anything to its right is a comment
diff --git a/gcc/m2/gm2-libs/DynamicStrings.mod
b/gcc/m2/gm2-libs/DynamicStrings.mod
index c79e21c12be..b53f0f285b5 100644
--- a/gcc/m2/gm2-libs/DynamicStrings.mod
+++ b/gcc/m2/gm2-libs/DynamicStrings.mod
@@ -1466,8 +1466,9 @@ END Index ;
(*
RIndex - returns the indice of the last occurance of, ch,
- in String, s. The search starts at position, o.
- -1 is returned if, ch, is not found.
+ in String, s. The search starts at position, o.
+ -1 is returned if, ch, is not found. The search
+ is performed left to right.
*)
PROCEDURE RIndex (s: String; ch: CHAR; o: CARDINAL) : INTEGER ;
@@ -1509,6 +1510,47 @@ BEGIN
END RIndex ;
+(*
+ ReverseIndex - returns the indice of the last occurance of ch
+ in String s. The search starts at position o
+ and searches from right to left. The start position
+ may be indexed negatively from the right (-1 is the
+ last index).
+ The return value if ch is found will always be positive.
+ -1 is returned if ch is not found.
+*)
+
+PROCEDURE ReverseIndex (s: String; ch: CHAR; o: INTEGER) : INTEGER ;
+VAR
+ c: CARDINAL ;
+BEGIN
+ IF PoisonOn
+ THEN
+ s := CheckPoisoned (s)
+ END ;
+ IF o < 0
+ THEN
+ o := VAL (INTEGER, Length (s)) + o ;
+ IF o < 0
+ THEN
+ RETURN -1
+ END
+ END ;
+ IF VAL (CARDINAL, o) < Length (s)
+ THEN
+ WHILE o >= 0 DO
+ IF char (s, o) = ch
+ THEN
+ RETURN o
+ ELSE
+ DEC (o)
+ END
+ END
+ END ;
+ RETURN -1
+END ReverseIndex ;
+
+
(*
RemoveComment - assuming that, comment, is a comment delimiter
which indicates anything to its right is a comment
