@@ -416,6 +416,25 @@ The default implementation and module filename suffix is @file{.def}.
If this option is used GNU Modula-2 will still fall back to this
default if a requested definition module is not found.
+@item -fdump-lang-all
+turn on all modula-2 language dump file. Currently this enables
+@samp{-fdump-lang-quad} and @samp{-fdump-lang-gimple}.
+This is an internal command line option.
+
+@item -fdump-lang-quad
+generate internal debugging dump files containing the quadruple
+intemediate representation of the source.
+
+@item -fdump-lang-quad=@file{filestem}
+dump quadruple representation to the @file{filestem} specified.
+
+@item -fdump-lang-gimple
+generate internal debugging dump files containing a modula-2 gimple
+representation of the source.
+
+@item -fdump-lang-gimple=@file{filestem}
+dump modula-2 gimple representation to the @file{filestem} specified.
+
@item -fdump-system-exports
display all inbuilt system items.
This is an internal command line option.
@@ -474,6 +493,15 @@ this option forces the use of the static version.
@c Modula-2 Joined
@c set all location values to a specific value (internal switch)
+@item -fm2-dump-filter=@samp{rules}
+filter the language dumps @samp{-fdump-lang-quad} and
+@samp{-fdump-lang-quad} on @samp{rules}. @samp{rules} must be a comma
+separated list which can take three forms: the full decl textual name
+of a procedure, @samp{[libname.]module.ident} or
+@samp{[filename.]module.ident}. This is an internal command line
+option. Currently it only filters on procedure names and regexp
+matching is not implemented.
+
@item -fm2-g
improve the debugging experience for new programmers at the expense
of generating @code{nop} instructions if necessary to ensure single
@@ -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 \
@@ -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 ;
@@ -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,
+ DumpLangGimple ;
+FROM M2LangDump IMPORT 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 ;
@@ -71,12 +74,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 +144,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 ;
@@ -198,11 +199,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
@@ -238,11 +245,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 any optimization\n') ;
(* now is a suitable time to check for student errors as *)
(* we know all the front end symbols must be resolved. *)
@@ -258,20 +261,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 +369,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 +394,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 +428,7 @@ VAR
sb: ScopeBlock ;
n : Name ;
BEGIN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
n := GetSymName (scope) ;
printf1 ('before coding block %a\n', n)
@@ -474,7 +437,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 +447,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 +457,7 @@ BEGIN
ForeachScopeBlockDo2 (sb, ConvertQuadsToTree) ;
ForeachProcedureDo(scope, CodeBlock)
ELSE
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
n := GetSymName(scope) ;
printf1('before coding module %a\n', n) ;
@@ -38,8 +38,7 @@ FROM M2Quads IMPORT DisplayQuadRange ;
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 ;
@@ -209,10 +208,11 @@ TYPE
CONST
- Debugging = FALSE ;
- Progress = FALSE ;
- EnableSSA = FALSE ;
- EnableWatch = FALSE ;
+ Debugging = FALSE ;
+ Progress = FALSE ;
+ EnableSSA = FALSE ;
+ EnableWatch = FALSE ;
+ TraceQuadruples = FALSE ;
TYPE
@@ -2767,7 +2767,7 @@ VAR
copy: Group ;
loop: CARDINAL ;
BEGIN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayQuadRange (scope, start, end)
END ;
@@ -2783,7 +2783,7 @@ BEGIN
END ;
IF loop = DebugLoop
THEN
- IF DisplayQuadruples
+ IF TraceQuadruples
THEN
DisplayQuadRange (scope, start, end)
END ;
@@ -92,7 +92,7 @@ FROM M2Error IMPORT InternalError, WriteFormat0, WriteFormat1, WriteFormat2, War
FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
MetaError1, MetaError2, MetaErrorStringT1 ;
-FROM M2Options IMPORT DisplayQuadruples, UnboundedByReference, PedanticCast,
+FROM M2Options IMPORT UnboundedByReference, PedanticCast,
VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram,
StrictTypeChecking, AutoInit, cflag, ScaffoldMain,
ScaffoldDynamic, ScaffoldStatic,
@@ -256,8 +256,7 @@ FROM m2except IMPORT BuildThrow, BuildTryBegin, BuildTryEnd,
FROM M2Quads IMPORT QuadOperator, GetQuad, IsReferenced, GetNextQuad,
SubQuad, PutQuad, MustCheckOverflow, GetQuadOtok,
QuadToTokenNo, DisplayQuad, GetQuadtok,
- GetM2OperatorDesc, GetQuadOp,
- DisplayQuadList ;
+ GetM2OperatorDesc, GetQuadOp ;
FROM M2Check IMPORT ParameterTypeCompatible, AssignmentTypeCompatible, ExpressionTypeCompatible ;
FROM M2SSA IMPORT EnableSSA ;
@@ -640,11 +639,6 @@ BEGIN
Changed := TRUE
END
UNTIL NoChange ;
- IF Debugging AND DisplayQuadruples AND FALSE
- THEN
- printf0('after resolving expressions with gcc\n') ;
- DisplayQuadList
- END ;
RETURN Changed
END ResolveConstantExpressions ;
new file mode 100644
@@ -0,0 +1,65 @@
+(* M2LangDump.def provides support routines for the -flang-dump.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusmod2@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 ;
+
+
+(*
+ IsDumpRequiredTree - return TRUE if the gcc tree should be dumped.
+*)
+
+PROCEDURE IsDumpRequiredTree (tree: Tree) : BOOLEAN ;
+
+
+(*
+ IsDumpRequired - return TRUE if symbol sym should be dumped
+ according to the rules of the filter.
+ No filter specified will always return TRUE.
+ The filter is a comma separated list of either:
+
+ DECL names for example: m2pim_NumberIO_HexToStr
+ filename:m2symbolname for example: NumberIO.mod:HexToStr
+ fully qualified m2name for example: NumberIO.HexToStr
+*)
+
+PROCEDURE IsDumpRequired (sym: CARDINAL) : 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 ;
+
+
+END M2LangDump.
new file mode 100644
@@ -0,0 +1,457 @@
+(* M2LangDump.mod provides support routines for the -flang-dump.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusmod2@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,
+ IsInnerModule,
+ IsVar,
+ IsProcedure,
+ IsModule,
+ IsDefImp,
+ IsExportQualified, IsExportUnQualified,
+ IsExported, IsPublic, IsExtern, IsMonoName,
+ IsDefinitionForC ;
+
+FROM M2Options IMPORT GetM2DumpFilter, GetDumpDir, GetDumpLangQuadFilename,
+ GetDumpLangGimpleFilename ;
+
+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 printf0, printf1, printf2 ;
+FROM M2Error IMPORT InternalError ;
+FROM libc IMPORT printf ;
+
+
+CONST
+ Debugging = FALSE ;
+
+
+(*
+ IsDumpRequiredTree - return TRUE if the gcc tree should be dumped.
+*)
+
+PROCEDURE IsDumpRequiredTree (tree: Tree) : BOOLEAN ;
+VAR
+ sym: CARDINAL ;
+BEGIN
+ sym := Gcc2Mod (tree) ;
+ IF sym = NulSym
+ THEN
+ RETURN FALSE
+ ELSE
+ RETURN IsDumpRequired (sym)
+ 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 TRUE.
+ 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) : BOOLEAN ;
+VAR
+ filter: String ;
+BEGIN
+ filter := GetM2DumpFilter () ;
+ IF filter = NIL
+ THEN
+ RETURN TRUE
+ 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 ;
+
+
+(*
+ 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 ;
+
+
+END M2LangDump.
@@ -55,7 +55,8 @@ 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. *)
+ DumpLangQuad, (* -fq, -fdump-lang-quad dump quadruples. *)
+ DumpLangGimple, (* -fdump-lang-gimple. *)
UnboundedByReference, (* -funbounded-by-reference *)
VerboseUnbounded, (* -Wverbose-unbounded *)
OptimizeUncalledProcedures, (* -Ouncalled removes uncalled procedures *)
@@ -1002,6 +1003,56 @@ PROCEDURE SetIEEELongDouble (value: BOOLEAN) ;
PROCEDURE GetIEEELongDouble () : BOOLEAN ;
+(*
+ 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.
@@ -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,9 @@ CONST
DefaultRuntimeModuleOverride = "m2iso:RTentity,m2iso:Storage,m2iso:SYSTEM,m2iso:M2RTS,m2iso:RTExceptions,m2iso:IOLink" ;
VAR
+ DumpLangQuadFilename,
+ DumpLangGimpleFilename,
+ M2DumpFilter,
M2Prefix,
M2PathName,
Barg,
@@ -1049,7 +1051,9 @@ END SetSwig ;
PROCEDURE SetQuadDebugging (value: BOOLEAN) ;
BEGIN
- DisplayQuadruples := value
+ DumpLangQuad := value ;
+ DumpLangQuadFilename := KillString (DumpLangQuadFilename) ;
+ DumpLangQuadFilename := InitString ('-')
END SetQuadDebugging ;
@@ -1670,6 +1674,96 @@ BEGIN
END InitializeLongDoubleFlags ;
+(*
+ 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 +1785,7 @@ BEGIN
Quiet := TRUE ;
CC1Quiet := TRUE ;
Profiling := FALSE ;
- DisplayQuadruples := FALSE ;
+ DumpLangQuad := FALSE ;
OptimizeBasicBlock := FALSE ;
OptimizeUncalledProcedures := FALSE ;
OptimizeCommonSubExpressions := FALSE ;
@@ -1751,5 +1845,9 @@ BEGIN
MQFlag := NIL ;
InitializeLongDoubleFlags ;
M2Prefix := InitString ('') ;
- M2PathName := InitString ('')
+ M2PathName := InitString ('') ;
+ DumpLangQuadFilename := NIL ;
+ DumpLangGimpleFilename := NIL ;
+ DumpLangGimple := FALSE ;
+ M2DumpFilter := NIL
END M2Options.
@@ -125,7 +125,7 @@ EXPORT QUALIFIED StartBuildDefFile, StartBuildModFile, EndBuildFile,
IsDefOrModFile,
IsInitialisingConst,
- DisplayQuadList, DisplayQuadRange, DisplayQuad,
+ DumpQuadruples, DisplayQuadRange, DisplayQuad,
WriteOperator, BackPatchSubrangesAndOptParam,
GetQuad, GetFirstQuad, GetNextQuad, PutQuad,
@@ -436,10 +436,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) ;
(*
@@ -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 ;
@@ -159,7 +160,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,
@@ -217,8 +219,11 @@ FROM M2Options IMPORT NilChecking,
UninitVariableChecking,
ScaffoldDynamic, ScaffoldStatic, cflag,
ScaffoldMain, SharedFlag, WholeProgram,
- GetRuntimeModuleOverride ;
+ GetDumpDir, GetM2DumpFilter,
+ GetRuntimeModuleOverride,
+ DumpLangQuad ;
+FROM M2LangDump IMPORT MakeQuadTemplate ;
FROM M2Pass IMPORT IsPassCodeGeneration, IsNoPass ;
FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress,
@@ -260,8 +265,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
@@ -5473,9 +5479,9 @@ BEGIN
THEN
IF i<=ParamTotal
THEN
- printf0('; ')
+ printf0 ('; ')
ELSE
- printf0(' ) ; \n')
+ printf0 (' ) ; \n')
END
END
END
@@ -13182,23 +13188,206 @@ BEGIN
END GenQuadOtok ;
+VAR
+ outputFile: FIO.File ;
+ mustClose : BOOLEAN ;
+ NoOfDumps : CARDINAL ;
+
+
+(*
+ DumpWrite - writes a single ch to the dump output.
+*)
+
+PROCEDURE DumpWrite (ch: CHAR) ;
+BEGIN
+ FIO.WriteChar (outputFile, ch)
+END DumpWrite ;
+
+
(*
- DisplayQuadList - displays all quads.
+ CloseOutput - close the dump output file.
*)
-PROCEDURE DisplayQuadList ;
+PROCEDURE CloseOutput ;
+BEGIN
+ IF mustClose
+ THEN
+ FIO.Close (outputFile) ;
+ mustClose := FALSE
+ ELSE
+ FIO.FlushBuffer (outputFile)
+ END ;
+ StdIO.PopOutput ;
+ outputFile := FIO.StdOut
+END CloseOutput ;
+
+
+(*
+ ConfigureOutput - configure the dump file for a quad dump.
+*)
+
+PROCEDURE ConfigureOutput ;
+VAR
+ filename: String ;
+BEGIN
+ INC (NoOfDumps) ;
+ filename := MakeQuadTemplate () ;
+ IF DynamicStrings.EqualArray (filename, '-')
+ THEN
+ mustClose := FALSE ;
+ outputFile := FIO.StdOut
+ ELSE
+ filename := Sprintf1 (filename, NoOfDumps) ;
+ outputFile := SFIO.OpenToWrite (filename) ;
+ mustClose := FIO.IsNoError (outputFile)
+ END ;
+ filename := KillString (filename) ;
+ StdIO.PushOutput (DumpWrite)
+END ConfigureOutput ;
+
+
+(*
+ DumpUntil - dump all quadruples until we seen the ending quadruple
+ with procsym in the third operand.
+ Return the quad number containing the match.
+*)
+
+PROCEDURE DumpUntil (ending: QuadOperator;
+ procsym: CARDINAL; quad: CARDINAL) : CARDINAL ;
+VAR
+ op : QuadOperator ;
+ op1, op2, op3: CARDINAL ;
+ f : QuadFrame ;
+BEGIN
+ fprintf0 (outputFile, '\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 ;
+ proc,
+ op1, op2, op3: CARDINAL ;
+BEGIN
+ i := Head ;
+ WHILE i # 0 DO
+ GetQuad (i, op, op1, op2, op3) ;
+ IF (op = ProcedureScopeOp) AND IsDumpRequired (op3)
+ THEN
+ i := DumpUntil (KillLocalVarOp, op3, i)
+ ELSIF (op = InitStartOp) AND IsDumpRequired (GetCtorInit (op3))
+ THEN
+ i := DumpUntil (InitEndOp, op3, i)
+ ELSIF (op = FinallyStartOp) AND IsDumpRequired (GetCtorFini (op3))
+ 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) ;
+VAR
+ len,
+ text,
+ i : CARDINAL ;
+ s : String ;
+BEGIN
+ IF DumpLangQuad
+ THEN
+ ConfigureOutput ;
+ s := Sprintf0 (Mark (InitString (title))) ;
+ s := KillString (SFIO.WriteS (outputFile, 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 (outputFile, s)) ;
+ fprintf0 (outputFile, '\n');
+ IF GetM2DumpFilter () = NIL
+ THEN
+ DumpQuadrupleAll
+ ELSE
+ DumpQuadrupleFilter
+ END ;
+ CloseOutput
+ END
+END DumpQuadruples ;
(*
@@ -13209,7 +13398,7 @@ PROCEDURE DisplayQuadRange (scope: CARDINAL; start, end: CARDINAL) ;
VAR
f: QuadFrame ;
BEGIN
- printf1 ('Quadruples for scope: %d\n', scope) ;
+ fprintf1 (outputFile, 'Quadruples for scope: %d\n', scope) ;
WHILE (start <= end) AND (start # 0) DO
DisplayQuad (start) ;
f := GetQF (start) ;
@@ -13341,7 +13530,7 @@ END ds ;
PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
BEGIN
DSdbEnter ;
- printf1('%4d ', QuadNo) ; WriteQuad(QuadNo) ; printf0('\n') ;
+ fprintf1 (outputFile, '%4d ', QuadNo) ; WriteQuad(QuadNo) ; fprintf0 (outputFile, '\n') ;
DSdbExit
END DisplayQuad ;
@@ -13354,19 +13543,19 @@ PROCEDURE DisplayProcedureAttributes (proc: CARDINAL) ;
BEGIN
IF IsCtor (proc)
THEN
- printf0 (" (ctor)")
+ fprintf0 (outputFile, " (ctor)")
END ;
IF IsPublic (proc)
THEN
- printf0 (" (public)")
+ fprintf0 (outputFile, " (public)")
END ;
IF IsExtern (proc)
THEN
- printf0 (" (extern)")
+ fprintf0 (outputFile, " (extern)")
END ;
IF IsMonoName (proc)
THEN
- printf0 (" (mononame)")
+ fprintf0 (outputFile, " (mononame)")
END
END DisplayProcedureAttributes ;
@@ -13385,11 +13574,11 @@ BEGIN
f := GetQF(BufferQuad) ;
WITH f^ DO
WriteOperator(Operator) ;
- printf1(' [%d] ', NoOfTimesReferenced) ;
+ fprintf1 (outputFile, ' [%d] ', NoOfTimesReferenced) ;
CASE Operator OF
HighOp : WriteOperand(Operand1) ;
- printf1(' %4d ', Operand2) ;
+ fprintf1 (outputFile, ' %4d ', Operand2) ;
WriteOperand(Operand3) |
InitAddressOp,
SavePriorityOp,
@@ -13404,7 +13593,7 @@ BEGIN
FunctValueOp,
NegateOp,
AddrOp : WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand3) |
ElementSizeOp,
IfInOp,
@@ -13415,22 +13604,22 @@ BEGIN
IfGreOp,
IfLessEquOp,
IfGreEquOp : WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand2) ;
- printf1(' %4d', Operand3) |
+ fprintf1 (outputFile, ' %4d', Operand3) |
InlineOp,
RetryOp,
TryOp,
- GotoOp : printf1('%4d', Operand3) |
+ GotoOp : fprintf1 (outputFile, '%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 (outputFile, '%a:%d:%a (tokenno %d)', Operand1, l, n, Operand3) |
+ LineNumberOp : fprintf2 (outputFile, '%a:%d', Operand1, Operand3) |
EndFileOp : n1 := GetSymName(Operand3) ;
- printf1('%a', n1) |
+ fprintf1 (outputFile, '%a', n1) |
ThrowOp,
ReturnOp,
@@ -13439,7 +13628,7 @@ BEGIN
ProcedureScopeOp : n1 := GetSymName(Operand2) ;
n2 := GetSymName(Operand3) ;
- printf3(' %4d %a %a', Operand1, n1, n2) ;
+ fprintf3 (outputFile, ' %4d %a %a', Operand1, n1, n2) ;
DisplayProcedureAttributes (Operand3) |
NewLocalVarOp,
FinallyStartOp,
@@ -13447,19 +13636,19 @@ BEGIN
InitEndOp,
InitStartOp : n1 := GetSymName(Operand2) ;
n2 := GetSymName(Operand3) ;
- printf3(' %4d %a %a', Operand1, n1, n2) |
+ fprintf3 (outputFile, ' %4d %a %a', Operand1, n1, n2) |
ModuleScopeOp,
StartModFileOp : n1 := GetSymName(Operand3) ;
- printf4('%a:%d %a(%d)', Operand2, Operand1, n1, Operand3) |
+ fprintf4 (outputFile, '%a:%d %a(%d)', Operand2, Operand1, n1, Operand3) |
StartDefFileOp : n1 := GetSymName(Operand3) ;
- printf2(' %4d %a', Operand1, n1) |
+ fprintf2 (outputFile, ' %4d %a', Operand1, n1) |
OptParamOp,
- ParamOp : printf1('%4d ', Operand1) ;
+ ParamOp : fprintf1 (outputFile, '%4d ', Operand1) ;
WriteOperand(Operand2) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand3) |
SizeOp,
RecordFieldOp,
@@ -13487,9 +13676,9 @@ BEGIN
DivFloorOp,
ModTruncOp,
DivTruncOp : WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand2) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand3) |
DummyOp,
CodeOnOp,
@@ -13499,23 +13688,23 @@ BEGIN
OptimizeOnOp,
OptimizeOffOp : |
BuiltinConstOp : WriteOperand(Operand1) ;
- printf1(' %a', Operand3) |
+ fprintf1 (outputFile, ' %a', Operand3) |
BuiltinTypeInfoOp : WriteOperand(Operand1) ;
- printf1(' %a', Operand2) ;
- printf1(' %a', Operand3) |
+ fprintf1 (outputFile, ' %a', Operand2) ;
+ fprintf1 (outputFile, ' %a', Operand3) |
StandardFunctionOp: WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand2) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand3) |
CatchBeginOp,
CatchEndOp : |
RangeCheckOp,
- ErrorOp : WriteRangeCheck(Operand3) |
+ ErrorOp : WriteRangeCheck (Operand3) |
SaveExceptionOp,
RestoreExceptionOp: WriteOperand(Operand1) ;
- printf0(' ') ;
+ fprintf0 (outputFile, ' ') ;
WriteOperand(Operand3)
ELSE
@@ -13533,91 +13722,91 @@ 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 ')
+ ArithAddOp : fprintf0 (outputFile, 'Arith + ') |
+ InitAddressOp : fprintf0 (outputFile, 'InitAddress ') |
+ LogicalOrOp : fprintf0 (outputFile, 'Or ') |
+ LogicalAndOp : fprintf0 (outputFile, 'And ') |
+ LogicalXorOp : fprintf0 (outputFile, 'Xor ') |
+ LogicalDiffOp : fprintf0 (outputFile, 'Ldiff ') |
+ LogicalShiftOp : fprintf0 (outputFile, 'Shift ') |
+ LogicalRotateOp : fprintf0 (outputFile, 'Rotate ') |
+ BecomesOp : fprintf0 (outputFile, 'Becomes ') |
+ IndrXOp : fprintf0 (outputFile, 'IndrX ') |
+ XIndrOp : fprintf0 (outputFile, 'XIndr ') |
+ ArrayOp : fprintf0 (outputFile, 'Array ') |
+ ElementSizeOp : fprintf0 (outputFile, 'ElementSize ') |
+ RecordFieldOp : fprintf0 (outputFile, 'RecordField ') |
+ AddrOp : fprintf0 (outputFile, 'Addr ') |
+ SizeOp : fprintf0 (outputFile, 'Size ') |
+ IfInOp : fprintf0 (outputFile, 'If IN ') |
+ IfNotInOp : fprintf0 (outputFile, 'If NOT IN ') |
+ IfNotEquOp : fprintf0 (outputFile, 'If <> ') |
+ IfEquOp : fprintf0 (outputFile, 'If = ') |
+ IfLessEquOp : fprintf0 (outputFile, 'If <= ') |
+ IfGreEquOp : fprintf0 (outputFile, 'If >= ') |
+ IfGreOp : fprintf0 (outputFile, 'If > ') |
+ IfLessOp : fprintf0 (outputFile, 'If < ') |
+ GotoOp : fprintf0 (outputFile, 'Goto ') |
+ DummyOp : fprintf0 (outputFile, 'Dummy ') |
+ ModuleScopeOp : fprintf0 (outputFile, 'ModuleScopeOp ') |
+ StartDefFileOp : fprintf0 (outputFile, 'StartDefFile ') |
+ StartModFileOp : fprintf0 (outputFile, 'StartModFile ') |
+ EndFileOp : fprintf0 (outputFile, 'EndFileOp ') |
+ InitStartOp : fprintf0 (outputFile, 'InitStart ') |
+ InitEndOp : fprintf0 (outputFile, 'InitEnd ') |
+ FinallyStartOp : fprintf0 (outputFile, 'FinallyStart ') |
+ FinallyEndOp : fprintf0 (outputFile, 'FinallyEnd ') |
+ RetryOp : fprintf0 (outputFile, 'Retry ') |
+ TryOp : fprintf0 (outputFile, 'Try ') |
+ ThrowOp : fprintf0 (outputFile, 'Throw ') |
+ CatchBeginOp : fprintf0 (outputFile, 'CatchBegin ') |
+ CatchEndOp : fprintf0 (outputFile, 'CatchEnd ') |
+ AddOp : fprintf0 (outputFile, '+ ') |
+ SubOp : fprintf0 (outputFile, '- ') |
+ DivM2Op : fprintf0 (outputFile, 'DIV M2 ') |
+ ModM2Op : fprintf0 (outputFile, 'MOD M2 ') |
+ DivCeilOp : fprintf0 (outputFile, 'DIV ceil ') |
+ ModCeilOp : fprintf0 (outputFile, 'MOD ceil ') |
+ DivFloorOp : fprintf0 (outputFile, 'DIV floor ') |
+ ModFloorOp : fprintf0 (outputFile, 'MOD floor ') |
+ DivTruncOp : fprintf0 (outputFile, 'DIV trunc ') |
+ ModTruncOp : fprintf0 (outputFile, 'MOD trunc ') |
+ MultOp : fprintf0 (outputFile, '* ') |
+ NegateOp : fprintf0 (outputFile, 'Negate ') |
+ InclOp : fprintf0 (outputFile, 'Incl ') |
+ ExclOp : fprintf0 (outputFile, 'Excl ') |
+ ReturnOp : fprintf0 (outputFile, 'Return ') |
+ ReturnValueOp : fprintf0 (outputFile, 'ReturnValue ') |
+ FunctValueOp : fprintf0 (outputFile, 'FunctValue ') |
+ CallOp : fprintf0 (outputFile, 'Call ') |
+ ParamOp : fprintf0 (outputFile, 'Param ') |
+ OptParamOp : fprintf0 (outputFile, 'OptParam ') |
+ NewLocalVarOp : fprintf0 (outputFile, 'NewLocalVar ') |
+ KillLocalVarOp : fprintf0 (outputFile, 'KillLocalVar ') |
+ ProcedureScopeOp : fprintf0 (outputFile, 'ProcedureScope ') |
+ UnboundedOp : fprintf0 (outputFile, 'Unbounded ') |
+ CoerceOp : fprintf0 (outputFile, 'Coerce ') |
+ ConvertOp : fprintf0 (outputFile, 'Convert ') |
+ CastOp : fprintf0 (outputFile, 'Cast ') |
+ HighOp : fprintf0 (outputFile, 'High ') |
+ CodeOnOp : fprintf0 (outputFile, 'CodeOn ') |
+ CodeOffOp : fprintf0 (outputFile, 'CodeOff ') |
+ ProfileOnOp : fprintf0 (outputFile, 'ProfileOn ') |
+ ProfileOffOp : fprintf0 (outputFile, 'ProfileOff ') |
+ OptimizeOnOp : fprintf0 (outputFile, 'OptimizeOn ') |
+ OptimizeOffOp : fprintf0 (outputFile, 'OptimizeOff ') |
+ InlineOp : fprintf0 (outputFile, 'Inline ') |
+ StatementNoteOp : fprintf0 (outputFile, 'StatementNote ') |
+ LineNumberOp : fprintf0 (outputFile, 'LineNumber ') |
+ BuiltinConstOp : fprintf0 (outputFile, 'BuiltinConst ') |
+ BuiltinTypeInfoOp : fprintf0 (outputFile, 'BuiltinTypeInfo ') |
+ StandardFunctionOp : fprintf0 (outputFile, 'StandardFunction ') |
+ SavePriorityOp : fprintf0 (outputFile, 'SavePriority ') |
+ RestorePriorityOp : fprintf0 (outputFile, 'RestorePriority ') |
+ RangeCheckOp : fprintf0 (outputFile, 'RangeCheck ') |
+ ErrorOp : fprintf0 (outputFile, 'Error ') |
+ SaveExceptionOp : fprintf0 (outputFile, 'SaveException ') |
+ RestoreExceptionOp : fprintf0 (outputFile, 'RestoreException ')
ELSE
InternalError ('operator not expected')
@@ -13635,15 +13824,15 @@ VAR
BEGIN
IF Sym = NulSym
THEN
- printf0 ('<nulsym>')
+ fprintf0 (outputFile, '<nulsym>')
ELSE
n := GetSymName (Sym) ;
- printf1 ('%a', n) ;
+ fprintf1 (outputFile, '%a', n) ;
IF IsVar (Sym) OR IsConst (Sym)
THEN
- printf0 ('[') ; WriteMode (GetMode (Sym)) ; printf0(']')
+ fprintf0 (outputFile, '[') ; WriteMode (GetMode (Sym)) ; fprintf0 (outputFile, ']')
END ;
- printf1 ('(%d)', Sym)
+ fprintf1 (outputFile, '(%d)', Sym)
END
END WriteOperand ;
@@ -13652,10 +13841,10 @@ PROCEDURE WriteMode (Mode: ModeOfAddr) ;
BEGIN
CASE Mode OF
- ImmediateValue: printf0('i') |
- NoValue : printf0('n') |
- RightValue : printf0('r') |
- LeftValue : printf0('l')
+ ImmediateValue: fprintf0 (outputFile, 'i') |
+ NoValue : fprintf0 (outputFile, 'n') |
+ RightValue : fprintf0 (outputFile, 'r') |
+ LeftValue : fprintf0 (outputFile, 'l')
ELSE
InternalError ('unrecognised mode')
@@ -15357,7 +15546,9 @@ BEGIN
FreeLineList := NIL ;
InitList(VarientFields) ;
VarientFieldNo := 0 ;
- NoOfQuads := 0
+ NoOfQuads := 0 ;
+ NoOfDumps := 0 ;
+ outputFile := FIO.StdOut
END Init ;
@@ -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 ;
@@ -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.
*)
@@ -24,10 +24,10 @@ IMPLEMENTATION MODULE SymbolConversion ;
FROM NameKey IMPORT Name ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, InBounds,
- DebugIndex ;
+ DebugIndex, 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.
*)
new file mode 100644
@@ -0,0 +1,41 @@
+/* m2langdump.h header file for m2langdump.cc.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusmod2@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 t);
+
+#undef EXTERN
+#endif /* m2langdump_h. */
@@ -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)
@@ -152,6 +152,13 @@ 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_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. */
similarity index 93%
rename from gcc/m2/m2pp.cc
rename to 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,6 +47,7 @@ namespace modula2 {
typedef struct pretty_t
{
+ m2pp_dump_kind output;
int needs_space;
int needs_indent;
int curpos;
@@ -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);
@@ -156,6 +156,8 @@ static void pop (void);
static int 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);
@@ -197,7 +200,7 @@ pf (tree t)
void
pe (tree t)
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, FALSE);
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, FALSE);
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, FALSE);
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, FALSE);
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, FALSE);
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, FALSE);
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, FALSE);
m2pp_identifier (state, t);
m2pp_needspace (state);
m2pp_print (state, "(* <var_decl context = ");
@@ -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,9 +440,10 @@ 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->output = kind;
state->needs_space = FALSE;
state->needs_indent = FALSE;
state->curpos = 0;
@@ -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))
@@ -581,7 +592,7 @@ hextree (tree t)
}
if (VAR_P (t))
{
- pretty *state = initPretty (FALSE);
+ pretty *state = initPretty (M2PP_DUMP_STDOUT, FALSE);
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, FALSE);
printf ("(* PARM_DECL %p <", (void *)t);
printf ("> context = %p*)\n", (void *)decl_function_context (t));
@@ -647,12 +658,12 @@ m2pp_module_block (pretty *s, tree t)
if (!DECL_EXTERNAL (t))
{
pretty *p = dupPretty (s);
- printf ("\n");
+ fprintf (getoutput (s), "\n");
p->in_vars = FALSE;
p->in_types = FALSE;
m2pp_function (p, t);
killPretty (p);
- printf ("\n");
+ fprintf (getoutput (s), "\n");
s->in_vars = FALSE;
s->in_types = FALSE;
}
@@ -691,7 +702,7 @@ m2pp_module_block (pretty *s, tree t)
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;
@@ -817,18 +828,18 @@ m2pp_var_list (pretty *s, tree t)
if (TREE_CODE (t) == FUNCTION_DECL)
{
pretty *p = dupPretty (s);
- printf ("\n");
+ 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));
}
@@ -1158,7 +1169,7 @@ m2pp_print (pretty *s, const char *p)
if (s->needs_space)
{
- printf (" ");
+ fprintf (getoutput (s), " ");
s->needs_space = FALSE;
s->curpos++;
}
@@ -1169,19 +1180,19 @@ m2pp_print (pretty *s, const char *p)
{
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, ' ');
+ 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 (" ");
+ fprintf (getoutput (s), " ");
s->needs_space = FALSE;
s->curpos++;
}
if (s->needs_indent)
{
if (s->indent > 0)
- printf ("%*c", s->indent, ' ');
+ 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);
@@ -2738,3 +2749,63 @@ 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++)
+ {
+ 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++)
+ fclose (modula2::m2pp_output_file[kind]);
+}
+
+
+/* Generate modula-2 style gimple for fndecl. */
+
+void m2pp_dump_gimple (m2pp_dump_kind kind, tree fndecl)
+{
+ if (M2Options_GetDumpLangGimple ()
+ && M2LangDump_IsDumpRequiredTree (fndecl))
+ {
+ modula2::pretty *state = modula2::initPretty (kind, FALSE);
+
+ 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);
+ }
+}
new file mode 100644
@@ -0,0 +1,41 @@
+(* m2pp.def definition module for m2pp.cc.
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaiusmod2@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 ;
+
+
+(*
+ CreateDumpGimple - create the gimple dump files.
+*)
+
+PROCEDURE CreateDumpGimple (templatename: ADDRESS; templatelen: CARDINAL) ;
+
+
+(*
+ CloseDumpGimple - close the gimple dump files.
+*)
+
+PROCEDURE CloseDumpGimple ;
+
+
+END m2pp.
similarity index 57%
rename from gcc/m2/m2pp.h
rename to gcc/m2/gm2-gcc/m2pp.h
@@ -19,17 +19,37 @@ 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_C)
-# define EXTERN
-# else
-# define EXTERN extern
-# endif
+#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. */
+
+typedef enum
+{
+ M2PP_DUMP_STDOUT, /* This must remain the first field. */
+ M2PP_DUMP_PRE_GENERICIZE,
+ M2PP_DUMP_POST_GENERICIZE,
+ 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);
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);
@@ -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 ();
@@ -214,8 +214,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 +406,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 +481,22 @@ gm2_langhook_handle_option (
case OPT_fdebug_function_line_numbers:
M2Options_SetDebugFunctionLineNumbers (value);
return 1;
+ case OPT_fdump_lang_all:
+ M2Options_SetDumpLangQuadFilename (value, NULL);
+ M2Options_SetDumpLangGimpleFilename (value, NULL);
+ 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;
case OPT_fauto_init:
M2Options_SetAutoInit (value);
return 1;
@@ -519,6 +537,9 @@ gm2_langhook_handle_option (
case OPT_fm2_strict_type:
M2Options_SetStrictTypeChecking (value);
return 1;
+ case OPT_fm2_dump_filter_:
+ M2Options_SetM2DumpFilter (value, arg);
+ return 1;
case OPT_Wall:
M2Options_SetWall (value);
return 1;
@@ -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
@@ -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
@@ -106,6 +106,26 @@ fdef=
Modula-2 Joined
recognise the specified suffix as a definition module filename
+fdump-lang-all
+Modula-2
+dump all Modula-2 internal intemediate representation
+
+fdump-lang-gimple
+Modula-2
+dump gimple in Modula-2
+
+fdump-lang-gimple=
+Modula-2 Joined
+dump gimple in Modula-2 to the filename stem specified
+
+fdump-lang-quad
+Modula-2
+dump quadruple representation
+
+fdump-lang-quad=
+Modula-2 Joined
+dump quadruple representation to the filename stem specified
+
fdump-system-exports
Modula-2
display all inbuilt system items
@@ -138,6 +158,10 @@ flocation=
Modula-2 Joined
set all location values to a specific value (internal switch)
+fm2-dump-filter=
+Modula-2 Joined
+filter the language dump using a comma separated list of procedures and modules
+
fm2-g
Modula-2
generate extra nops to improve debugging, producing an instruction for every code related keyword