[gcc r16-3988] PR modula2/121856: New wideset implementation
Gaius Mulley
gaius@gcc.gnu.org
Fri Sep 19 16:29:26 GMT 2025
https://gcc.gnu.org/g:273b53effbf5497e3e08bddeba74e72f1e7e8315
commit r16-3988-g273b53effbf5497e3e08bddeba74e72f1e7e8315
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Fri Sep 19 17:26:18 2025 +0100
PR modula2/121856: New wideset implementation
The new wideset implementation uses an ARRAY OF BYTE (internally) to
represent large sets. This replaces the huge struct of anonymous
fields created by the old implementation and results in quicker
declaration times for large set types.
gcc/ChangeLog:
PR modula2/121856
* doc/gm2.texi (Compiler options): New item -fwideset.
gcc/m2/ChangeLog:
PR modula2/121856
* Make-lang.in (GM2-LIBS-BOOT-DEFS): Add M2Diagnostic.def.
Add Selective.def.
(GM2-LIBS-BOOT-MODS): Add M2Diagnostic.mod.
(GM2-LIBS-BOOT-C): Add Selective.c.
(GM2-LIBS-DEFS): Add Selective.def.
(GM2-LIBS-MODS): Add M2Diagnostic.mod.
(MC-LIB-MODS): Add M2Diagnostic.mod.
(m2/gm2-libs-boot/Selective.o): New rule.
(BUILD-PGE-O): Add m2/pge-boot/GM2Diagnostic.o.
Add m2/pge-boot/GM2Diagnostic.o.
Add m2/pge-boot/GStringConvert.o.
Add m2/pge-boot/Gdtoa.o.
Add m2/pge-boot/Gldtoa.o.
* Make-maintainer.in (PPG-LIB-DEFS): Add M2Diagnostic.def.
Add StringConvert.def.
(PPG-LIB-MODS): Add M2Diagnostic.mod.
Add StringConvert.mod.
(PGE-DEF): Add M2Diagnostic.def.
(PGE-DEPS): Add GM2Diagnostic.cc.
Add GM2Diagnostic.h.
* gm2-compiler/FifoQueue.def (PutSetIntoFifoQueue): New
procedure.
(GetSetFromFifoQueue): New procedure function.
* gm2-compiler/FifoQueue.mod (PutSetIntoFifoQueue): New
procedure.
(GetSetFromFifoQueue): New procedure function.
* gm2-compiler/M2ALU.def (KillValue): New procedure.
(PushSetTree): Rename parameter t to value.
(ConstructSetConstant): Rewrite comment.
* gm2-compiler/M2ALU.mod: Rewrite to use the new set type
and introduce memory diagnostics.
* gm2-compiler/M2Base.mod (InitBaseProcedures): Lookup M2WIDESET.
* gm2-compiler/M2CaseList.mod (CheckCaseBoundsResolved): Change
format specifier to allow the preceeding indefinite article to
have a n concatenated providing the following string substitute
begins with a vowel.
(checkTypes): Ditto.
* gm2-compiler/M2Check.mod (checkGenericUnboundedTyped): New
procedure function.
* gm2-compiler/M2Code.mod (OptimizationAnalysis): Replace with ...
(ResourceAnalysis): ... this.
* gm2-compiler/M2Comp.mod (PopulateResource): New procedure.
(compile): Call PopulateResource.
Call M2Diagnostic.Generate.
* gm2-compiler/M2GCCDeclare.mod: Rewrite for new set type.
* gm2-compiler/M2GenGCC.mod: Rewrite implementation for
becomes, incl, excl, and, or, not, xor for the new set type.
* gm2-compiler/M2MetaError.def: Extend comment documenting
the v format specifier.
* gm2-compiler/M2MetaError.mod (errorBlock): New field vowel.
(initErrorBlock): Initialize field vowel.
Reformat comments.
(pop): Call checkVowel.
(checkVowel): New procedure.
(isVowel): New procedure function.
(symDesc): Remove indefinite article.
(op): Set vowel field in case clause.
* gm2-compiler/M2Options.def (OptimizeSets): New global.
(TimeReport): Ditto.
(MemReport): Ditto.
(SetMemReport): New procedure.
(SetTimeReport): Ditto.
(SetWideset): Ditto.
(GetWideset): New procedure function.
* gm2-compiler/M2Options.mod (SetOptimizing): Assign
OptimizeSets depending upon the optimization level.
(SetMemReport): New procedure.
(SetTimeReport): Ditto.
(SetWideset): Ditto.
(GetWideset): New procedure function.
(OptimizeSets): Initialize to FALSE.
(TimeReport): Ditto.
(MemReport): Ditto.
* gm2-compiler/M2Quads.mod (M2Diagnostic): Import.
(QuadsMemDiag): New global variable.
(NewQuad): Bump QuadsMemDiag whenever a quad is allocated.
(BuildAssignmentBoolean): New procedure.
(doBuildAssignment): Ditto.
Add v to the format specifier.
(CheckCompatibleWithBecomes): Add v to the format specifier.
(CheckProcTypeAndProcedure): Ditto.
(BuildAddAdrFunction): Ditto.
(BuildSubAdrFunction): Ditto.
(BuildDifAdrFunction): Ditto.
(BuildDesignatorArrayStaticDynamic): Ditto.
(BuildDesignatorPointer): Ditto.
(CheckVariableOrConstantOrProcedure): Ditto.
(Init): Initialize QuadsMemDiag.
* gm2-compiler/M2Range.mod (CodeTypeAssign): Add v to the
format specifier.
* gm2-compiler/M2Scaffold.mod (DeclareScaffoldFunctions):
Generate more precise warning note.
* gm2-compiler/M2SymInit.mod (PrintSymInit): Add record
field warning.
* gm2-compiler/M2System.mod
(IsPseudoSystemFunctionConstExpression): Add TBitSize.
* gm2-compiler/NameKey.mod: Add MemDiagnostic code
commented out.
* gm2-compiler/P1SymBuild.mod (StartBuildProcedure):
Add v format specifier.
* gm2-compiler/P2SymBuild.mod (BuildFieldRecord): Ditto.
* gm2-compiler/P3Build.bnf (SetType): Reformat.
* gm2-compiler/PathName.def (Copyright): Added.
* gm2-compiler/PathName.mod: Remove blank line.
* gm2-compiler/SymbolConversion.mod (gdbhook): New procedure.
(BreakWhenSymBooked): Ditto.
(CheckBook): Ditto.
(Init): Rewrite.
* gm2-compiler/SymbolTable.def (GetSetArray): New procedure.
(PutSetArray): Ditto.
(MakeSetArray): New procedure function.
(PutSetInWord): New procedure.
(GetSetInWord): New procedure function.
(IsConstVar): Ditto.
* gm2-compiler/SymbolTable.mod (SymSet): SetInWord new field.
SetArray new field.
Align new field.
(SymMemDiag): New global variable.
(Init): Initialize SymMemDiag.
(IsConstVar): New procedure function.
(IsVariableSSA): Replace InternalError with Return FALSE.
(GetNthParamOrdered): Reimplement.
(GetNthParamAnyClosest): Ditto.
(GetOuterModuleScope): Ditto.
(MakeSet): Ditto.
(PutSetArray): New procedure.
(GetSetArray): New procedure function.
(MakeSetArray): Ditto.
(PutSetInWord): New procedure.
(GetSetInWord): New procedure function.
* gm2-gcc/init.cc (_M2_M2Diagnostic_init): Define
prototype.
(init_FrontEndInit):Call _M2_M2Diagnostic_init.
* gm2-gcc/m2block.cc (m2block_GetTotalConstants): New function.
(m2block_GetGlobalTypes): Ditto.
* gm2-gcc/m2block.def (GetTotalConstants): New procedure function.
(GetGlobalTypes): New procedure function.
* gm2-gcc/m2block.h (m2block_GetTotalConstants): New function
prototype.
(m2block_GetGlobalTypes): Ditto.
* gm2-gcc/m2convert.cc (converting_ISO_generic): Reimplement.
(m2convert_ToPIMByte): New function.
* gm2-gcc/m2convert.def (ToLoc): New procedure function.
(ToPIMByte): Ditto.
* gm2-gcc/m2convert.h (m2convert_ToPIMByte): Ditto.
* gm2-gcc/m2decl.h (m2decl_RememberVariables): Ditto.
* gm2-gcc/m2expr.cc (m2expr_BuildLogicalShift): Reimplement.
(m2expr_BuildLRotate): Ditto.
(m2expr_BuildLRLn): Ditto.
(m2expr_BuildLRRn): Ditto.
(m2expr_BuildLogicalRotate): Ditto.
(buildUnboundedArrayOf): Ditto.
(BuildIfBitInSetLower): New function.
(m2expr_BuildBinarySetDo): Reimplement.
(m2expr_BuildIfInSet): Ditto.
(m2expr_BuildIfNotInSet): New function.
(m2expr_Build4LogicalOr): Reimplement.
(m2expr_BuildSetNegate): Ditto.
(m2expr_BuildLogicalOrAddress): Ditto.
(m2expr_BuildLogicalOr): Ditto.
(m2expr_BuildLogicalAnd): Ditto.
(m2expr_BuildSymmetricDifference): Ditto.
(m2expr_BuildLogicalDifference): Ditto.
(boolean_enum_to_unsigned): Ditto.
(m2expr_BuildIsSuperset): Ditto.
(m2expr_BuildIsNotSuperset): Ditto.
(m2expr_BuildIsSubset): Ditto.
(m2expr_BuildIfBitInSetJump): Ditto.
(m2expr_BuildIfNotConstInVar): Ditto.
(m2expr_BuildIfVarInVar): Ditto.
(m2expr_BuildIfNotVarInVar): Remove.
(m2expr_BuildIfConstInVar): Remove.
(m2expr_BuildForeachWordInSetDoIfExpr): Ditto.
(m2expr_BuildBinaryForeachWordDo): Ditto.
(m2expr_BuildIfInRangeGoto): Reimplement.
(m2expr_BuildIfNotInRangeGoto): Ditto.
(m2expr_SetAndNarrow): Ditto.
(m2expr_GetBitsetZero): New function.
(m2expr_GetRValue): Ditto.
* gm2-gcc/m2expr.def (GetBitsetZero): New function.
(BuildSetNegate): Ditto.
(BuildLogicalOr): Reimplement.
(BuildLogicalAnd): Ditto.
(BuildSymmetricDifference): Ditto.
(BuildLogicalDifference): Ditto.
(BuildIfInSet): New procedure function.
(BuildIfNotInSet): Ditto.
(BuildEqualTo): Reimplement.
(BuildNotEqualTo): Ditto.
(BuildBinaryForeachWordDo): Remove.
(BuildBinarySetDo): Ditto.
(GetRValue): New procedure function.
* gm2-gcc/m2expr.h (m2expr_BuildBinaryForeachWordDo): Remove.
(m2expr_BuildForeachWordInSetDoIfExpr): Ditto.
(m2expr_BuildIfNotVarInVar): Ditto.
(m2expr_BuildIfVarInVar): Ditto.
(m2expr_BuildIfNotConstInVar): Ditto.
(m2expr_BuildIfConstInVar): Ditto.
(m2expr_BuildLogicalDifference): Reimplement.
(m2expr_BuildSymmetricDifference): Ditto.
(m2expr_BuildLogicalAnd): Ditto.
(m2expr_BuildLogicalOr): Ditto.
(m2expr_BuildLogicalOrAddress): Ditto.
(m2expr_BuildSetNegate): Ditto.
(m2expr_GetBitsetZero): New function.
(m2expr_GetRValue): Ditto.
(m2expr_BuildIfInSet): Ditto.
(m2expr_BuildIfNotInSet): Ditto.
* gm2-gcc/m2options.h (M2Options_SetTimeReport): New function.
(M2Options_SetMemReport): Ditto.
(M2Options_SetWideset): Ditto.
(M2Options_GetWideset): Ditto.
* gm2-gcc/m2pp.cc (m2pp_shiftrotate_expr): New function.
(m2pp_simple_expression): Ditto.
* gm2-gcc/m2statement.cc (m2statement_BuildStartFunctionCode):
Tidyup comments.
(m2statement_BuildEndFunctionCode): Ditto.
(m2statement_BuildPushFunctionContext): Ditto.
(copy_array): Ditto.
(CopyByField_Lower): Ditto.
(m2statement_BuildGoto): Ditto.
(m2statement_DeclareLabel): Ditto.
(m2statement_BuildParam): Ditto.
(nCount): Ditto.
(m2statement_BuildProcedureCallTree): Ditto.
(m2statement_BuildBuiltinCallTree): Ditto.
(m2statement_BuildFunctValue): Ditto.
(m2statement_BuildCall2): Ditto.
(m2statement_BuildCall3): Ditto.
(m2statement_BuildFunctionCallTree): Ditto.
(m2statement_SetLastFunction): Ditto.
(m2statement_SetParamList): Ditto.
(m2statement_GetLastFunction): Ditto.
(m2statement_GetParamList): Ditto.
(m2statement_GetCurrentFunction): Ditto.
(m2statement_GetParamTree): Ditto.
(m2statement_BuildTryFinally): Ditto.
(m2statement_BuildCleanUp): Ditto.
(m2statement_BuildUnaryForeachWordDo): Remove.
(m2statement_BuildExcludeVarConst): Ditto.
(m2statement_BuildExcludeVarVar): Ditto.
(m2statement_BuildIncludeVarConst): Ditto.
(m2statement_BuildIncludeVarVar): Ditto.
(m2statement_DoJump): Remove.
(m2statement_IfExprJump): New function.
(m2statement_IfBitInSetJump): Ditto.
* gm2-gcc/m2statement.def (DoJump): Remove.
(IfExprJump): New procedure function.
(BuildUnaryForeachWordDo): Remove.
(IfBitInSetJump): New procedure function.
* gm2-gcc/m2statement.h (m2statement_BuildForeachWordDo): Remove.
(m2statement_DoJump): Ditto.
(m2statement_IfExprJump): New function.
(m2statement_IfBitInSetJump): Ditto.
* gm2-gcc/m2treelib.cc (m2treelib_do_jump_if_bit): Reimplement.
(nCount): Replace with ...
(m2treelib_nCount): ... this.
(m2treelib_DoCall): Reimplement.
(m2treelib_get_rvalue): Remove.
* gm2-gcc/m2treelib.def (get_rvalue): Remove.
(nCount): New procedure function.
* gm2-gcc/m2treelib.h (m2treelib_get_rvalue): Remove.
(m2treelib_nCount): New function.
* gm2-gcc/m2type.cc (constructor_elements): Change type to vec.
(m2type_BuildEndArrayType): Reformat.
(build_m2_type_node_by_array): Ditto.
(m2type_GetBooleanEnumList): New procedure function.
(m2type_BuildEnumerator): Add const to char *.
(m2type_BuildSetConstructorElement): Reimplement.
(m2type_BuildEndSetConstructor): Ditto.
(build_record_constructor): New function.
(m2type_BuildEndRecordConstructor): Reimplement.
(m2type_BuildRecordConstructorElement): Ditto.
(m2type_BuildStartArrayConstructor): Reimplement.
(m2type_BuildEndArrayConstructor): Remove blank lines.
* gm2-gcc/m2type.def (BuildSetConstructorElement): Reimplement.
(BuildEndArrayType): Reformat.
(GetBooleanEnumList): New function.
* gm2-gcc/m2type.h (m2type_BuildEnumerator): Add const to char *.
(m2type_BuildSetConstructorElement): Reimplement.
(m2type_GetBooleanEnumList): New procedure function.
* gm2-lang.cc (OPT_fmem_report): New option.
(OPT_ftime_report): Ditto.
(OPT_fwideset): Ditto.
* gm2-libs-coroutines/SYSTEM.def (ShiftVal): Remove.
(ShiftLeft): Ditto.
(ShiftRight): Ditto.
(RotateVal): Ditto.
(RotateLeft): Ditto.
(RotateRight): Ditto.
* gm2-libs-coroutines/SYSTEM.mod: Reimplement.
* gm2-libs-iso/SYSTEM.def (ShiftVal): Remove.
(ShiftLeft): Ditto.
(ShiftRight): Ditto.
(RotateVal): Ditto.
(RotateLeft): Ditto.
(RotateRight): Ditto.
* gm2-libs-iso/SYSTEM.mod: Reimplement.
* gm2-libs/SYSTEM.def (ShiftVal): Remove.
(ShiftLeft): Ditto.
(ShiftRight): Ditto.
(RotateVal): Ditto.
(RotateLeft): Ditto.
(RotateRight): Ditto.
* gm2-libs/SYSTEM.mod: Reimplement.
* gm2-libs/SysStorage.def (DEALLOCATE): Improve comment.
* gm2-libs/SysStorage.mod: Improve comment.
* init/ppginit (M2Diagnostic): Add.
(StringConvert): Add.
* lang.opt (fmem-report): Add access to c.opt.
(ftime-report): Ditto.
(fwideset): New option.
* pge-boot/main.cc (_M2_M2Diagnostic_init): New function.
(_M2_M2Diagnostic_fini): Ditto.
(_M2_StringConvert_init): Ditto.
(_M2_StringConvert_fini): Ditto.
(main): Call _M2_M2Diagnostic_init.
Call _M2_StringConvert_init.
Call _M2_M2Diagnostic_fini.
Call _M2_StringConvert_fini.
* tools-src/makeSystem: Add -gdb option.
* gm2-libs/M2Diagnostic.def: New file.
* gm2-libs/M2Diagnostic.mod: New file.
* gm2-libs/M2WIDESET.def: New file.
* gm2-libs/M2WIDESET.mod: New file.
* mc-boot/GM2Diagnostic.cc: New file.
* mc-boot/GM2Diagnostic.h: New file.
* pge-boot/GM2Diagnostic.cc: New file.
* pge-boot/GM2Diagnostic.h: New file.
* pge-boot/GSelective.h: New file.
* pge-boot/GStringConvert.cc: New file.
libgm2/ChangeLog:
* libm2pim/Makefile.am (M2MODS): Add M2Diagnostic.mod.
Add M2WIDESET.mod.
(M2DEFS): Add M2Diagnostic.def.
Add M2WIDESET.def.
* libm2pim/Makefile.in: Regenerate.
gcc/testsuite/ChangeLog:
* gm2/errors/fail/testbit2.mod: Rewrite.
* gm2/iso/run/pass/shift4.mod: Rewrite adding more internal
tests.
* gm2/iso/run/pass/testsystem.mod (FindFirstElement): Add
bounds check.
* gm2/sets/run/pass/multisetrotate4.mod: Add more runtime
error messages.
* gm2/sets/run/pass/simplepacked.mod (testpset): Correct
setname.
* lib/gm2.exp (gm2_init_minx): Add -fno-wideset.
* gm2/iso/run/pass/assigncons.mod: New test.
* gm2/iso/run/pass/constructor3.mod: New test.
* gm2/iso/run/pass/proc_test.mod: New test.
* gm2/iso/run/pass/simplelarge2.mod: New test.
* gm2/iso/run/pass/simplelarge3.mod: New test.
* gm2/iso/run/pass/simplelarge4.mod: New test.
* gm2/pimlib/wideset/run/pass/bitset.mod: New test.
* gm2/pimlib/wideset/run/pass/bitset2.mod: New test.
* gm2/pimlib/wideset/run/pass/colorset.mod: New test.
* gm2/pimlib/wideset/run/pass/colorset2.mod: New test.
* gm2/pimlib/wideset/run/pass/colorset3.mod: New test.
* gm2/pimlib/wideset/run/pass/highbit.mod: New test.
* gm2/pimlib/wideset/run/pass/highbit2.mod: New test.
* gm2/sets/run/pass/multisetrotate5.mod: New test.
* gm2/sets/run/pass/setcard.mod: New test.
* gm2/sets/run/pass/setincl.mod: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/doc/gm2.texi | 6 +
gcc/m2/Make-lang.in | 20 +
gcc/m2/Make-maintainer.in | 8 +-
gcc/m2/gm2-compiler/FifoQueue.def | 24 +-
gcc/m2/gm2-compiler/FifoQueue.mod | 24 +
gcc/m2/gm2-compiler/M2ALU.def | 60 +-
gcc/m2/gm2-compiler/M2ALU.mod | 299 ++-
gcc/m2/gm2-compiler/M2Base.mod | 13 +-
gcc/m2/gm2-compiler/M2CaseList.mod | 8 +-
gcc/m2/gm2-compiler/M2Check.mod | 25 +-
gcc/m2/gm2-compiler/M2Code.mod | 10 +-
gcc/m2/gm2-compiler/M2Comp.mod | 41 +-
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 971 ++++----
gcc/m2/gm2-compiler/M2GenGCC.mod | 2350 +++++++++++++-------
gcc/m2/gm2-compiler/M2MetaError.def | 3 +-
gcc/m2/gm2-compiler/M2MetaError.mod | 51 +-
gcc/m2/gm2-compiler/M2Options.def | 36 +-
gcc/m2/gm2-compiler/M2Options.mod | 51 +-
gcc/m2/gm2-compiler/M2Quads.mod | 123 +-
gcc/m2/gm2-compiler/M2Range.mod | 4 +-
gcc/m2/gm2-compiler/M2Scaffold.mod | 2 +-
gcc/m2/gm2-compiler/M2SymInit.mod | 15 +-
gcc/m2/gm2-compiler/M2System.mod | 4 +-
gcc/m2/gm2-compiler/NameKey.mod | 44 +-
gcc/m2/gm2-compiler/P1SymBuild.mod | 2 +-
gcc/m2/gm2-compiler/P2SymBuild.mod | 2 +-
gcc/m2/gm2-compiler/P3Build.bnf | 3 +-
gcc/m2/gm2-compiler/PathName.def | 30 +-
gcc/m2/gm2-compiler/PathName.mod | 1 -
gcc/m2/gm2-compiler/SymbolConversion.mod | 47 +-
gcc/m2/gm2-compiler/SymbolTable.def | 51 +
gcc/m2/gm2-compiler/SymbolTable.mod | 218 +-
gcc/m2/gm2-gcc/init.cc | 2 +
gcc/m2/gm2-gcc/m2block.cc | 16 +
gcc/m2/gm2-gcc/m2block.def | 14 +
gcc/m2/gm2-gcc/m2block.h | 2 +
gcc/m2/gm2-gcc/m2convert.cc | 32 +-
gcc/m2/gm2-gcc/m2convert.def | 14 +
gcc/m2/gm2-gcc/m2convert.h | 2 +
gcc/m2/gm2-gcc/m2decl.h | 1 -
gcc/m2/gm2-gcc/m2expr.cc | 562 +----
gcc/m2/gm2-gcc/m2expr.def | 76 +-
gcc/m2/gm2-gcc/m2expr.h | 47 +-
gcc/m2/gm2-gcc/m2options.h | 4 +
gcc/m2/gm2-gcc/m2pp.cc | 22 +
gcc/m2/gm2-gcc/m2statement.cc | 411 +---
gcc/m2/gm2-gcc/m2statement.def | 27 +-
gcc/m2/gm2-gcc/m2statement.h | 9 +-
gcc/m2/gm2-gcc/m2treelib.cc | 22 +-
gcc/m2/gm2-gcc/m2treelib.def | 15 +-
gcc/m2/gm2-gcc/m2treelib.h | 3 +-
gcc/m2/gm2-gcc/m2type.cc | 138 +-
gcc/m2/gm2-gcc/m2type.def | 14 +-
gcc/m2/gm2-gcc/m2type.h | 5 +-
gcc/m2/gm2-lang.cc | 11 +
gcc/m2/gm2-libs-coroutines/SYSTEM.def | 88 +-
gcc/m2/gm2-libs-coroutines/SYSTEM.mod | 251 +--
gcc/m2/gm2-libs-iso/SYSTEM.def | 80 -
gcc/m2/gm2-libs-iso/SYSTEM.mod | 244 --
gcc/m2/gm2-libs/M2Diagnostic.def | 182 ++
gcc/m2/gm2-libs/M2Diagnostic.mod | 1049 +++++++++
gcc/m2/gm2-libs/M2WIDESET.def | 210 ++
gcc/m2/gm2-libs/M2WIDESET.mod | 1259 +++++++++++
gcc/m2/gm2-libs/SYSTEM.def | 83 -
gcc/m2/gm2-libs/SYSTEM.mod | 244 --
gcc/m2/gm2-libs/SysStorage.def | 9 +-
gcc/m2/gm2-libs/SysStorage.mod | 11 +-
gcc/m2/init/ppginit | 2 +
gcc/m2/lang.opt | 12 +
gcc/m2/mc-boot/GM2Diagnostic.cc | 1484 ++++++++++++
gcc/m2/mc-boot/GM2Diagnostic.h | 186 ++
gcc/m2/pge-boot/GM2Diagnostic.cc | 1485 +++++++++++++
gcc/m2/pge-boot/GM2Diagnostic.h | 186 ++
gcc/m2/pge-boot/GSelective.h | 83 +
gcc/m2/pge-boot/GStringConvert.cc | 2006 +++++++++++++++++
gcc/m2/pge-boot/main.cc | 8 +
gcc/m2/tools-src/makeSystem | 16 +-
gcc/testsuite/gm2/errors/fail/testbit2.mod | 7 +-
gcc/testsuite/gm2/iso/run/pass/assigncons.mod | 23 +
gcc/testsuite/gm2/iso/run/pass/constructor3.mod | 42 +
gcc/testsuite/gm2/iso/run/pass/proc_test.mod | 10 +
gcc/testsuite/gm2/iso/run/pass/shift4.mod | 123 +-
gcc/testsuite/gm2/iso/run/pass/simplelarge2.mod | 99 +
gcc/testsuite/gm2/iso/run/pass/simplelarge3.mod | 88 +
gcc/testsuite/gm2/iso/run/pass/simplelarge4.mod | 88 +
gcc/testsuite/gm2/iso/run/pass/testsystem.mod | 2 +-
.../gm2/pimlib/wideset/run/pass/bitset.mod | 46 +
.../gm2/pimlib/wideset/run/pass/bitset2.mod | 43 +
.../gm2/pimlib/wideset/run/pass/colorset.mod | 47 +
.../gm2/pimlib/wideset/run/pass/colorset2.mod | 72 +
.../gm2/pimlib/wideset/run/pass/colorset3.mod | 46 +
.../gm2/pimlib/wideset/run/pass/highbit.mod | 13 +
.../gm2/pimlib/wideset/run/pass/highbit2.mod | 13 +
.../gm2/sets/run/pass/multisetrotate4.mod | 11 +-
.../gm2/sets/run/pass/multisetrotate5.mod | 70 +
gcc/testsuite/gm2/sets/run/pass/setcard.mod | 18 +
gcc/testsuite/gm2/sets/run/pass/setincl.mod | 51 +
gcc/testsuite/gm2/sets/run/pass/simplepacked.mod | 2 +-
gcc/testsuite/lib/gm2.exp | 1 +
libgm2/libm2pim/Makefile.am | 4 +
libgm2/libm2pim/Makefile.in | 15 +-
101 files changed, 12564 insertions(+), 3543 deletions(-)
diff --git a/gcc/doc/gm2.texi b/gcc/doc/gm2.texi
index d908aeaaa058..1aa647d58786 100644
--- a/gcc/doc/gm2.texi
+++ b/gcc/doc/gm2.texi
@@ -723,6 +723,12 @@ The option @samp{-Wall} will turn on this flag with
@samp{-Wuninit-variable-checking=known}.
The @samp{-Wuninit-variable-checking=all} will increase compile time.
+@item -fwideset
+turn on access to the runtime support library module @samp{M2WIDESET}.
+By default this option is on.
+Wideset provision can be disabled by @samp{-fno-wideset}
+and no reference will be made to the run time @samp{M2WIDESET} library.
+
@c the following warning options are complete but need to be
@c regression tested against all other front ends
@c to ensure the options do not conflict.
diff --git a/gcc/m2/Make-lang.in b/gcc/m2/Make-lang.in
index 470825ca2ccf..fd5193fea1da 100644
--- a/gcc/m2/Make-lang.in
+++ b/gcc/m2/Make-lang.in
@@ -681,6 +681,7 @@ GM2-LIBS-BOOT-DEFS = \
IO.def \
Indexing.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
NumberIO.def \
@@ -690,6 +691,7 @@ GM2-LIBS-BOOT-DEFS = \
SEnvironment.def \
SFIO.def \
SYSTEM.def \
+ Selective.def \
Scan.def \
StdIO.def \
Storage.def \
@@ -726,6 +728,7 @@ GM2-LIBS-BOOT-MODS = \
IO.mod \
Indexing.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
NumberIO.mod \
@@ -747,6 +750,7 @@ GM2-LIBS-BOOT-MODS = \
# found in gm2-libs-ch.
GM2-LIBS-BOOT-C = \
+ Selective.c \
StdIO.c \
SysExceptions.c \
choosetemp.c \
@@ -954,6 +958,7 @@ GM2-LIBS-DEFS = \
LMathLib0.def \
LegacyReal.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
MathLib0.def \
@@ -968,6 +973,7 @@ GM2-LIBS-DEFS = \
SMathLib0.def \
SYSTEM.def \
Scan.def \
+ Selective.def \
StdIO.def \
Storage.def \
StrCase.def \
@@ -1006,6 +1012,7 @@ GM2-LIBS-MODS = \
LMathLib0.mod \
LegacyReal.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
MathLib0.mod \
@@ -1246,6 +1253,7 @@ MC-LIB-DEFS = \
FpuIO.def \
IO.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
MemUtils.def \
@@ -1293,6 +1301,7 @@ MC-LIB-MODS = \
FpuIO.mod \
IO.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
MemUtils.mod \
@@ -1558,6 +1567,12 @@ m2/gm2-libs-boot/SysStorage.o: $(srcdir)/m2/gm2-libs/SysStorage.mod $(MCDEPS) $(
m2/gm2-libs-boot/SysStorage.c -o m2/gm2-libs-boot/SysStorage.o
$(POSTCOMPILE)
+m2/gm2-libs-boot/Selective.o: $(srcdir)/m2/gm2-libs-ch/Selective.c \
+ m2/gm2-libs-boot/$(SRC_PREFIX)Selective.h m2/gm2-libs/gm2-libs-host.h
+ -test -d $(@D)/$(DEPDIR) || $(mkinstalldirs) $(@D)/$(DEPDIR)
+ $(CXX) $(CM2DEP) -c $(CFLAGS) $(GM2_PICFLAGS) -Im2/gm2-libs -I$(srcdir)/m2 -Im2 -I. -Im2/gm2-libs-boot $(INCLUDES) $< -o $@
+ $(POSTCOMPILE)
+
m2/gm2-compiler-boot/M2GCCDeclare.o: $(srcdir)/m2/gm2-compiler/M2GCCDeclare.mod $(MCDEPS) $(BUILD-BOOT-H)
-test -d $(@D)/$(DEPDIR) || $(mkinstalldirs) $(@D)/$(DEPDIR)
$(MC) $(MC_EXTENDED_OPAQUE) -o=m2/gm2-compiler-boot/M2GCCDeclare.c $<
@@ -1873,6 +1888,7 @@ BUILD-PGE-O = \
m2/pge-boot/GIO.o \
m2/pge-boot/GLists.o \
m2/pge-boot/GM2Dependent.o \
+ m2/pge-boot/GM2Diagnostic.o \
m2/pge-boot/GM2EXCEPTION.o \
m2/pge-boot/GM2RTS.o \
m2/pge-boot/GNameKey.o \
@@ -1882,9 +1898,11 @@ BUILD-PGE-O = \
m2/pge-boot/GPushBackInput.o \
m2/pge-boot/GRTExceptions.o \
m2/pge-boot/GSFIO.o \
+ m2/pge-boot/GSelective.o \
m2/pge-boot/GStdIO.o \
m2/pge-boot/GStorage.o \
m2/pge-boot/GStrCase.o \
+ m2/pge-boot/GStringConvert.o \
m2/pge-boot/GStrIO.o \
m2/pge-boot/GStrLib.o \
m2/pge-boot/GSymbolKey.o \
@@ -1896,6 +1914,8 @@ BUILD-PGE-O = \
m2/pge-boot/Gtermios.o \
m2/pge-boot/GSysExceptions.o \
m2/pge-boot/Gabort.o \
+ m2/pge-boot/Gdtoa.o \
+ m2/pge-boot/Gldtoa.o \
m2/pge-boot/Gmcrts.o \
m2/pge-boot/main.o
diff --git a/gcc/m2/Make-maintainer.in b/gcc/m2/Make-maintainer.in
index ad89474f3754..cf05e0f3d71a 100644
--- a/gcc/m2/Make-maintainer.in
+++ b/gcc/m2/Make-maintainer.in
@@ -41,10 +41,11 @@ PPG-DEFS = SymbolKey.def NameKey.def Lists.def bnflex.def Output.de
PPG-LIB-DEFS = Args.def Assertion.def ASCII.def Debug.def \
DynamicStrings.def FIO.def Indexing.def IO.def \
NumberIO.def PushBackInput.def \
- M2Dependent.def \
+ M2Dependent.def M2Diagnostic.def \
M2EXCEPTION.def M2RTS.def \
RTExceptions.def \
StdIO.def SFIO.def StrIO.def StrLib.def \
+ StringConvert.def \
Storage.def StrCase.def SysStorage.def
# Core library implementation modules used by ppg found in the gm2-libs directory.
@@ -58,6 +59,7 @@ PPG-LIB-MODS = ASCII.mod \
IO.mod \
Indexing.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
NumberIO.mod \
@@ -69,6 +71,7 @@ PPG-LIB-MODS = ASCII.mod \
StrCase.mod \
StrIO.mod \
StrLib.mod \
+ StringConvert.mod \
SysStorage.mod
# Program module ppg.mod from which pge.mod is created. ppg.mod is
@@ -96,6 +99,7 @@ PGE-DEF = ASCII.def \
FpuIO.def \
IO.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
MemUtils.def \
@@ -169,6 +173,8 @@ PGE-DEPS = Gabort.cc \
GLists.h \
GM2Dependent.cc \
GM2Dependent.h \
+ GM2Diagnostic.cc \
+ GM2Diagnostic.h \
GM2EXCEPTION.cc \
GM2EXCEPTION.h \
GM2RTS.cc \
diff --git a/gcc/m2/gm2-compiler/FifoQueue.def b/gcc/m2/gm2-compiler/FifoQueue.def
index a6a454a9da62..26e985c478c5 100644
--- a/gcc/m2/gm2-compiler/FifoQueue.def
+++ b/gcc/m2/gm2-compiler/FifoQueue.def
@@ -25,15 +25,25 @@ DEFINITION MODULE FifoQueue ;
Author : Gaius Mulley
Title : FifoQueue
Date : Tue Dec 12 16:23:22 GMT 1989
- Description: FifoQueue provides a mechanism to and from which CARDINAL
- numbers can be stored and retrieved from a FIFO queue.
- Last update: Tue Dec 12 16:24:24 GMT 1989
+ Description: FifoQueue provides a fifo mechanism to allow symbols to be
+ stored and retrieved between passes in the same order.
*)
-EXPORT QUALIFIED PutEnumerationIntoFifoQueue, GetEnumerationFromFifoQueue,
- PutSubrangeIntoFifoQueue, GetSubrangeFromFifoQueue,
- PutConstIntoFifoQueue, GetConstFromFifoQueue,
- PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue ;
+
+(*
+ PutSetIntoFifoQueue - places a set symbol
+ into a fifo queue.
+*)
+
+PROCEDURE PutSetIntoFifoQueue (c: CARDINAL) ;
+
+
+(*
+ GetSetFromFifoQueue - retrieves a set symbol
+ from a fifo queue.
+*)
+
+PROCEDURE GetSetFromFifoQueue (VAR c: CARDINAL) ;
(*
diff --git a/gcc/m2/gm2-compiler/FifoQueue.mod b/gcc/m2/gm2-compiler/FifoQueue.mod
index 9d309557286b..8d9accf0d9c7 100644
--- a/gcc/m2/gm2-compiler/FifoQueue.mod
+++ b/gcc/m2/gm2-compiler/FifoQueue.mod
@@ -31,6 +31,7 @@ TYPE
VAR
const,
+ set,
subrange,
enumeration,
constructor: Fifo ;
@@ -149,6 +150,28 @@ BEGIN
END GetConstFromFifoQueue ;
+(*
+ PutSetIntoFifoQueue - places a set symbol
+ into a fifo queue.
+*)
+
+PROCEDURE PutSetIntoFifoQueue (c: CARDINAL) ;
+BEGIN
+ PutInto (set, c)
+END PutSetIntoFifoQueue ;
+
+
+(*
+ GetSetFromFifoQueue - retrieves a set symbol
+ from a fifo queue.
+*)
+
+PROCEDURE GetSetFromFifoQueue (VAR c: CARDINAL) ;
+BEGIN
+ GetFrom (set, c)
+END GetSetFromFifoQueue ;
+
+
(*
Init - initialize the fifo queue.
*)
@@ -164,6 +187,7 @@ END Init ;
BEGIN
Init(const) ;
+ Init(set) ;
Init(enumeration) ;
Init(subrange) ;
Init(constructor)
diff --git a/gcc/m2/gm2-compiler/M2ALU.def b/gcc/m2/gm2-compiler/M2ALU.def
index 1e4fdb8e8930..fbf3245ef912 100644
--- a/gcc/m2/gm2-compiler/M2ALU.def
+++ b/gcc/m2/gm2-compiler/M2ALU.def
@@ -35,52 +35,6 @@ FROM NameKey IMPORT Name ;
FROM M2GCCDeclare IMPORT WalkAction, IsAction ;
FROM gcctypes IMPORT tree ;
-EXPORT QUALIFIED PtrToValue,
- InitValue,
- IsValueTypeNone,
- IsValueTypeInteger,
- IsValueTypeReal,
- IsValueTypeComplex,
- IsValueTypeSet,
- IsValueTypeConstructor,
- IsValueTypeArray,
- IsValueTypeRecord,
- PopInto, PushFrom,
- PushIntegerTree, PopIntegerTree,
- PushSetTree, PopSetTree,
- PushRealTree, PopRealTree,
- PushComplexTree, PopComplexTree,
- PopConstructorTree,
- PopChar,
- PushCard,
- PushInt,
- PushChar,
- PushString,
- PushTypeOfTree,
- CoerseLongRealToCard,
- ConvertRealToInt,
- ConvertToInt,
- ConvertToType,
- GetSetValueType,
- IsSolved, IsValueConst,
- PutConstructorSolved, EvaluateValue, TryEvaluateValue,
-
- IsNulSet, IsGenericNulSet, PushNulSet, AddBitRange, AddBit, SubBit,
- SetOr, SetAnd, SetIn,
- SetDifference, SetSymmetricDifference,
- SetNegate, SetShift, SetRotate,
-
- Addn, Multn, Sub,
- DivFloor, ModFloor, DivTrunc, ModTrunc,
- Equ, NotEqu, Less, Gre, LessEqu, GreEqu,
- GetValue, GetRange, ConstructSetConstant, BuildRange,
- IsConstructorDependants, WalkConstructorDependants,
- AddField, AddElements,
-
- PushEmptyConstructor, PushEmptyArray, PushEmptyRecord,
- ChangeToConstructor,
-
- IsValueAndTreeKnown, CheckOrResetOverflow ;
TYPE
PtrToValue ;
@@ -93,6 +47,13 @@ TYPE
PROCEDURE InitValue () : PtrToValue ;
+(*
+ KillValue - deconstructor for value. value is set to NIL upon return.
+*)
+
+PROCEDURE KillValue (VAR value: PtrToValue) ;
+
+
(*
IsValueTypeNone - returns TRUE if the value on the top stack has no value.
*)
@@ -208,8 +169,7 @@ PROCEDURE PopComplexTree () : tree ;
type (sym). Bit 0 maps onto MIN(sym).
*)
-PROCEDURE PushSetTree (tokenno: CARDINAL;
- t: tree; sym: CARDINAL) ;
+PROCEDURE PushSetTree (tokenno: CARDINAL; value: tree; sym: CARDINAL) ;
(*
@@ -828,8 +788,8 @@ PROCEDURE GetRange (v: PtrToValue; n: CARDINAL; VAR low, high: CARDINAL) : BOOLE
(*
- ConstructSetConstant - builds a struct of integers which represents the
- set const, sym.
+ ConstructSetConstant - builds an array of BYTE which represents the
+ set const symbol.
*)
PROCEDURE ConstructSetConstant (tokenno: CARDINAL; v: PtrToValue) : tree ;
diff --git a/gcc/m2/gm2-compiler/M2ALU.mod b/gcc/m2/gm2-compiler/M2ALU.mod
index e53f2edf478d..6809bcb2fb88 100644
--- a/gcc/m2/gm2-compiler/M2ALU.mod
+++ b/gcc/m2/gm2-compiler/M2ALU.mod
@@ -52,7 +52,7 @@ FROM M2MetaError IMPORT MetaError0, MetaError1, MetaError2, MetaErrorStringT0,
FROM SymbolTable IMPORT NulSym, IsEnumeration, IsSubrange, IsValueSolved, PushValue,
ForeachFieldEnumerationDo, MakeTemporary, PutVar, PopValue, GetType,
- MakeConstLit, GetArraySubscript,
+ MakeConstLit, GetArraySubscript, GetSetInWord,
IsSet, SkipType, IsRecord, IsArray, IsConst, IsConstructor,
IsConstString, SkipTypeAndSubrange, GetDeclaredMod,
GetSubrange, GetSymName, GetNth, GetString, GetStringLength,
@@ -70,7 +70,7 @@ FROM m2expr IMPORT BuildAdd, BuildSub, BuildMult,
GetWordOne, GetCardinalZero, TreeOverflow, RemoveOverflow,
GetCstInteger ;
-FROM m2decl IMPORT GetBitsPerBitset, BuildIntegerConstant, BuildConstLiteralNumber ;
+FROM m2decl IMPORT GetBitsPerUnit, GetBitsPerBitset, BuildIntegerConstant, BuildConstLiteralNumber ;
FROM m2misc IMPORT DebugTree ;
FROM m2type IMPORT RealToTree, Constructor, GetIntegerType, GetLongRealType,
@@ -80,12 +80,17 @@ FROM m2type IMPORT RealToTree, Constructor, GetIntegerType, GetLongRealType,
BuildArrayConstructorElement, BuildStartArrayConstructor, BuildEndArrayConstructor,
GetM2CharType ;
-FROM m2convert IMPORT ConvertConstantAndCheck, ToWord, ToInteger, ToCardinal, ToBitset ;
+FROM m2convert IMPORT ConvertConstantAndCheck, ToWord, ToInteger, ToCardinal,
+ ToBitset, ToLoc, ToPIMByte, BuildConvert ;
+
FROM m2block IMPORT RememberConstant ;
FROM m2expr IMPORT GetPointerZero, GetIntegerZero, GetIntegerOne,
CompareTrees, FoldAndStrip, AreRealOrComplexConstantsEqual, AreConstantsEqual ;
+FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemSet ;
+
+
TYPE
cellType = (none, integer, real, complex, set, constructor, array, record) ;
@@ -150,6 +155,9 @@ VAR
EnumerationField: CARDINAL ;
CurrentTokenNo : CARDINAL ;
(* WatchedValue : PtrToValue ; *)
+ StackMemDiag : Diagnostic ; (* Contains memory related statistics *)
+ RangeMemDiag : Diagnostic ; (* Contains memory related statistics *)
+
(*
@@ -162,7 +170,9 @@ VAR
BEGIN
IF FreeList=NIL
THEN
- NEW (v)
+ NEW (v) ;
+ MemIncr (StackMemDiag, 1, 1) ;
+ MemIncr (StackMemDiag, 2, SIZE (v^))
ELSE
v := FreeList ;
FreeList := FreeList^.next
@@ -203,7 +213,9 @@ BEGIN
IF v=NIL
THEN
InternalError ('out of memory error')
- END
+ END ;
+ MemIncr (RangeMemDiag, 1, 1) ;
+ MemIncr (RangeMemDiag, 2, SIZE (v^))
ELSE
v := RangeFreeList ;
RangeFreeList := RangeFreeList^.next
@@ -490,6 +502,17 @@ BEGIN
END InitValue ;
+(*
+ KillValue - deconstructor for value. value is set to NIL upon return.
+*)
+
+PROCEDURE KillValue (VAR value: PtrToValue) ;
+BEGIN
+ Dispose (value) ;
+ value := NIL
+END KillValue ;
+
+
(*
IsValueTypeNone - returns TRUE if the value on the top stack has no value.
*)
@@ -818,49 +841,48 @@ END PopComplexTree ;
(*
PushSetTree - pushes a gcc tree onto the ALU stack.
- The tree, t, is expected to contain a
- word value. It is converted into a set
- type (sym). Bit 0 maps onto MIN(sym).
+ The tree value is expected to contain a
+ word sized or less value. It is converted into a set
+ type (sym). Bit 0 maps onto MIN (sym).
*)
PROCEDURE PushSetTree (tokenno: CARDINAL;
- t: tree; sym: CARDINAL) ;
+ value: tree; sym: CARDINAL) ;
VAR
- v: PtrToValue ;
- c,
- i: INTEGER ;
- r: listOfRange ;
- l: location_t ;
+ newVal: PtrToValue ;
+ c, i : INTEGER ;
+ range : listOfRange ;
+ loc : location_t ;
BEGIN
- l := TokenToLocation(tokenno) ;
- r := NIL ;
+ loc := TokenToLocation (tokenno) ;
+ range := NIL ;
i := 0 ;
- WHILE (i<GetBitsPerBitset()) AND
- (CompareTrees(GetIntegerZero(l), t)#0) DO
- IF CompareTrees(GetIntegerOne(l),
- BuildLogicalAnd(l, t, GetIntegerOne(l), FALSE))=0
+ WHILE (i < GetBitsPerBitset ()) AND
+ (CompareTrees (GetIntegerZero (loc), value) # 0) DO
+ IF CompareTrees (GetIntegerOne (loc),
+ BuildLogicalAnd (loc, value, GetIntegerOne (loc))) = 0
THEN
- PushCard(i) ;
- c := Val(tokenno, SkipType(sym), PopIntegerTree()) ;
- DeclareConstant(tokenno, c) ;
- r := AddRange(r, c, c)
+ PushCard (i) ;
+ c := Val (tokenno, SkipType (sym), PopIntegerTree ()) ;
+ DeclareConstant (tokenno, c) ;
+ range := AddRange (range, c, c)
END ;
- t := BuildLSR(l, t, GetIntegerOne(l), FALSE) ;
- INC(i)
+ value := BuildLSR (loc, value, GetIntegerOne (loc), FALSE) ;
+ INC (i)
END ;
- SortElements(tokenno, r) ;
- CombineElements(tokenno, r) ;
- v := New() ;
- WITH v^ DO
- location := l ;
+ SortElements (tokenno, range) ;
+ CombineElements (tokenno, range) ;
+ newVal := New () ;
+ WITH newVal^ DO
+ location := loc ;
type := set ;
constructorType := sym ;
areAllConstants := FALSE ;
solved := FALSE ;
- setValue := r
+ setValue := range
END ;
- Eval(tokenno, v) ;
- Push(v)
+ Eval (tokenno, newVal) ;
+ Push (newVal)
END PushSetTree ;
@@ -1393,7 +1415,6 @@ BEGIN
END ConvertToType ;
-
(*
IsSolved - returns true if the memory cell indicated by v
has a known value.
@@ -4397,107 +4418,106 @@ END GetRange ;
(*
- BuildStructBitset - v is the PtrToValue.
+ ConstructLargeOrSmallSet - generates a constant representing the set value of the symbol, sym.
+ We manufacture the constant by using a initialization
+ structure of cardinals.
+
+ { (cardinal), (cardinal) etc }
+*)
+
+PROCEDURE ConstructLargeOrSmallSet (tokenno: CARDINAL; v: PtrToValue; low, high: CARDINAL) : tree ;
+VAR
+ settype: CARDINAL ;
+BEGIN
+ Assert (v^.constructorType # NulSym) ;
+ settype := SkipType (v^.constructorType) ;
+ Assert (IsSet (settype)) ;
+ IF GetSetInWord (settype)
+ THEN
+ (* Narrow set. *)
+ RETURN BuildConvert (TokenToLocation (tokenno),
+ Mod2Gcc (settype),
+ BuildBitset (tokenno, v, Mod2Gcc (low), Mod2Gcc (high)),
+ FALSE)
+ ELSE
+ (* Wide set. *)
+ RETURN BuildArrayByteset (tokenno, v, Mod2Gcc (low), Mod2Gcc (high))
+ END
+END ConstructLargeOrSmallSet ;
+
+
+(*
+ BuildArrayByteset - v is the PtrToValue.
low and high are the limits of the subrange.
*)
-PROCEDURE BuildStructBitset (tokenno: CARDINAL; v: PtrToValue; low, high: tree) : tree ;
+PROCEDURE BuildArrayByteset (tokenno: CARDINAL; v: PtrToValue; low, high: tree) : tree ;
VAR
- BitsInSet : tree ;
- bpw : CARDINAL ;
- cons : Constructor ;
+ location : location_t ;
+ BitsInSet : tree ;
+ BitsPerByte: CARDINAL ;
+ cons : Constructor ;
BEGIN
- PushIntegerTree(low) ;
+ location := TokenToLocation (tokenno) ;
+ PushIntegerTree (low) ;
ConvertToInt ;
- low := PopIntegerTree() ;
- PushIntegerTree(high) ;
+ low := PopIntegerTree () ;
+ PushIntegerTree (high) ;
ConvertToInt ;
- high := PopIntegerTree() ;
- bpw := GetBitsPerBitset() ;
+ high := PopIntegerTree () ;
+ BitsPerByte := GetBitsPerUnit () ;
- PushIntegerTree(high) ;
- PushIntegerTree(low) ;
+ PushIntegerTree (high) ;
+ PushIntegerTree (low) ;
Sub ;
- PushCard(1) ;
+ PushCard (1) ;
Addn ;
- BitsInSet := PopIntegerTree() ;
+ BitsInSet := PopIntegerTree () ;
- cons := BuildStartSetConstructor(Mod2Gcc(v^.constructorType)) ;
+ cons := BuildStartSetConstructor (Mod2Gcc (v^.constructorType)) ;
- PushIntegerTree(BitsInSet) ;
- PushCard(0) ;
- WHILE Gre(tokenno) DO
- PushIntegerTree(BitsInSet) ;
- PushCard(bpw-1) ;
- IF GreEqu(tokenno)
+ PushIntegerTree (BitsInSet) ;
+ PushCard (0) ;
+ WHILE Gre (tokenno) DO
+ PushIntegerTree (BitsInSet) ;
+ PushCard (BitsPerByte - 1) ;
+ IF GreEqu (tokenno)
THEN
- PushIntegerTree(low) ;
- PushCard(bpw-1) ;
+ PushIntegerTree (low) ;
+ PushCard (BitsPerByte - 1) ;
Addn ;
-
- BuildSetConstructorElement(cons, BuildBitset(tokenno, v, low, PopIntegerTree())) ;
-
- PushIntegerTree(low) ;
- PushCard(bpw) ;
+ BuildSetConstructorElement (location,
+ cons, BuildByte (tokenno, v, low, PopIntegerTree ())) ;
+ PushIntegerTree (low) ;
+ PushCard (BitsPerByte) ;
Addn ;
- low := PopIntegerTree() ;
- PushIntegerTree(BitsInSet) ;
- PushCard(bpw) ;
+ low := PopIntegerTree () ;
+ PushIntegerTree (BitsInSet) ;
+ PushCard (BitsPerByte) ;
Sub ;
- BitsInSet := PopIntegerTree()
+ BitsInSet := PopIntegerTree ()
ELSE
- (* printf2('range is %a..%a\n', GetSymName(low), GetSymName(high)) ; *)
-
- BuildSetConstructorElement(cons, BuildBitset(tokenno, v, low, high)) ;
-
- PushCard(0) ;
- BitsInSet := PopIntegerTree()
+ BuildSetConstructorElement (location,
+ cons, BuildByte (tokenno, v, low, high)) ;
+ PushCard (0) ;
+ BitsInSet := PopIntegerTree ()
END ;
- PushIntegerTree(BitsInSet) ;
- PushCard(0)
+ PushIntegerTree (BitsInSet) ;
+ PushCard (0)
END ;
- RETURN( BuildEndSetConstructor(cons) )
-END BuildStructBitset ;
+ RETURN BuildEndSetConstructor (cons)
+END BuildArrayByteset ;
(*
- ConstructLargeOrSmallSet - generates a constant representing the set value of the symbol, sym.
- We manufacture the constant by using a initialization
- structure of cardinals.
-
- { (cardinal), (cardinal) etc }
-*)
-
-PROCEDURE ConstructLargeOrSmallSet (tokenno: CARDINAL; v: PtrToValue; low, high: CARDINAL) : tree ;
-BEGIN
- PushValue(high) ;
- ConvertToInt ;
- PushValue(low) ;
- ConvertToInt ;
- Sub ;
- PushCard(GetBitsPerBitset()) ;
- IF Less(tokenno)
- THEN
- (* small set *)
- RETURN( BuildBitset(tokenno, v, Mod2Gcc(low), Mod2Gcc(high)) )
- ELSE
- (* large set *)
- RETURN( BuildStructBitset(tokenno, v, Mod2Gcc(low), Mod2Gcc(high)) )
- END
-END ConstructLargeOrSmallSet ;
-
-
-(*
- ConstructSetConstant - builds a struct of integers which represents the
- set const as defined by, v.
+ ConstructSetConstant - builds an array of bytes which represents the
+ set const as defined by v.
*)
PROCEDURE ConstructSetConstant (tokenno: CARDINAL; v: PtrToValue) : tree ;
VAR
n1, n2 : Name ;
- gccsym : tree ;
- baseType,
- high, low: CARDINAL ;
+ baseType: CARDINAL ;
BEGIN
WITH v^ DO
IF constructorType=NulSym
@@ -4511,14 +4531,7 @@ BEGIN
n2 := GetSymName(baseType) ;
printf2('ConstructSetConstant of type %a and baseType %a\n', n1, n2)
END ;
- IF IsSubrange(baseType)
- THEN
- GetSubrange(baseType, high, low) ;
- gccsym := ConstructLargeOrSmallSet(tokenno, v, low, high)
- ELSE
- gccsym := ConstructLargeOrSmallSet(tokenno, v, GetTypeMin(baseType), GetTypeMax(baseType))
- END ;
- RETURN( gccsym )
+ RETURN ConstructLargeOrSmallSet (tokenno, v, GetTypeMin (baseType), GetTypeMax (baseType))
END
END
END ConstructSetConstant ;
@@ -5074,7 +5087,7 @@ BEGIN
THEN
t := BuildLSL(location, GetWordOne(location), ToWord(location, i), FALSE)
ELSE
- t := BuildLogicalOr(location, t, BuildLSL(location, GetWordOne(location), ToWord(location, i), FALSE), FALSE)
+ t := BuildLogicalOr (location, t, BuildLSL(location, GetWordOne(location), ToWord(location, i), FALSE))
END ;
PushIntegerTree(i) ;
PushIntegerTree(GetIntegerOne(location)) ;
@@ -5083,7 +5096,7 @@ BEGIN
PushIntegerTree(i) ;
PushIntegerTree(e2) ;
UNTIL Gre(tokenno) ;
- RETURN( t )
+ RETURN t
END BuildRange ;
@@ -5115,7 +5128,7 @@ BEGIN
THEN
tl := ToCardinal(location, SubTree(MaxTree(tokenno, tl, low), low)) ;
th := ToCardinal(location, SubTree(MinTree(tokenno, th, high), low)) ;
- t := BuildLogicalOr(location, t, BuildRange(tokenno, tl, th), FALSE)
+ t := BuildLogicalOr(location, t, BuildRange(tokenno, tl, th))
END ;
INC(n)
END ;
@@ -5123,6 +5136,42 @@ BEGIN
END BuildBitset ;
+(*
+ BuildByte - given a set v construct the bitmask for its
+ constant value which lie in the range low..high.
+*)
+
+PROCEDURE BuildByte (tokenno: CARDINAL;
+ v: PtrToValue; low, high: tree) : tree ;
+VAR
+ tl, th,
+ t : tree ;
+ n : CARDINAL ;
+ r1, r2 : CARDINAL ;
+ location: location_t ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ low := ToInteger (location, low) ;
+ high := ToInteger (location, high) ;
+ n := 1 ;
+ t := GetCardinalZero (location) ;
+ WHILE GetRange (v, n, r1, r2) DO
+ PushValue (r1) ;
+ tl := ToInteger (location, PopIntegerTree ()) ;
+ PushValue (r2) ;
+ th := ToInteger (location, PopIntegerTree ()) ;
+ IF IsIntersectionTree (tokenno, tl, th, low, high)
+ THEN
+ tl := ToCardinal (location, SubTree (MaxTree (tokenno, tl, low), low)) ;
+ th := ToCardinal (location, SubTree (MinTree (tokenno, th, high), low)) ;
+ t := BuildLogicalOr (location, t, BuildRange (tokenno, tl, th))
+ END ;
+ INC(n)
+ END ;
+ RETURN ToPIMByte (location, t)
+END BuildByte ;
+
+
(*
IsValueAndTreeKnown - returns TRUE if the value is known and the gcc tree
is defined.
@@ -5309,7 +5358,15 @@ BEGIN
TopOfStack := NIL ;
RangeFreeList := NIL ;
FieldFreeList := NIL ;
- ElementFreeList := NIL
+ ElementFreeList := NIL ;
+ StackMemDiag
+ := InitMemDiagnostic
+ ('M2ALU:Stack',
+ '{0N} total symbols {1d} consuming {2M} ram {0M} ({2P})') ;
+ RangeMemDiag
+ := InitMemDiagnostic
+ ('M2ALU:Range',
+ '{0N} total symbols {1d} consuming {2M} ram {0M} ({2P})')
END Init ;
diff --git a/gcc/m2/gm2-compiler/M2Base.mod b/gcc/m2/gm2-compiler/M2Base.mod
index 5e373cf398a2..14fea6996492 100644
--- a/gcc/m2/gm2-compiler/M2Base.mod
+++ b/gcc/m2/gm2-compiler/M2Base.mod
@@ -96,7 +96,7 @@ FROM M2Options IMPORT NilChecking,
IndexChecking, RangeChecking,
ReturnChecking, CaseElseChecking, Exceptions,
WholeValueChecking,
- DebugBuiltins,
+ DebugBuiltins, GetWideset,
Iso, Pim, Pim2, Pim3 ;
FROM m2type IMPORT GetIntegerType,
@@ -150,6 +150,7 @@ VAR
Comp,
Expr,
Ass : CompatibilityArray ;
+ m2wideset,
Ord,
OrdS, OrdL,
Float,
@@ -222,7 +223,7 @@ BEGIN
InitSystem ;
MakeBitset ; (* We do this after SYSTEM has been created as BITSET
- is dependant upon WORD. *)
+ is dependant upon WORD and BOOLEAN. *)
InitBaseConstants ;
InitBaseFunctions ;
@@ -635,6 +636,14 @@ BEGIN
(* PIM-2 Modula-2 *)
END ;
+ IF GetWideset ()
+ THEN
+ (* Ensure that M2WIDESET is available if needed by M2GenGCC.mod.
+ By default -fwideset is TRUE however the user may override using
+ -fno-wideset. *)
+ m2wideset := MakeDefinitionSource (BuiltinTokenNo, MakeKey('M2WIDESET'))
+ END ;
+
(*
The procedure HALT is a real procedure which
is defined in M2RTS. However to remain compatible
diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod
index 2810b024e7a9..8788d4e4b7ef 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -326,9 +326,9 @@ BEGIN
ELSE
IF r^.high=NulSym
THEN
- MetaError1('the CASE statement variant must be defined by a constant {%1Da:is a {%1d}}', r^.low)
+ MetaError1('the CASE statement variant must be defined by a constant {%1Da:is a {%1dv}}', r^.low)
ELSE
- MetaError1('the CASE statement variant low value in a range must be defined by a constant {%1Da:is a {%1d}}',
+ MetaError1('the CASE statement variant low value in a range must be defined by a constant {%1Da:is a {%1dv}}',
r^.low)
END
END
@@ -343,7 +343,7 @@ BEGIN
RETURN( FALSE )
END
ELSE
- MetaError1('the CASE statement variant high value in a range must be defined by a constant {%1Da:is a {%1d}}',
+ MetaError1('the CASE statement variant high value in a range must be defined by a constant {%1Da:is a {%1dv}}',
r^.high)
END
END ;
@@ -1306,7 +1306,7 @@ BEGIN
consttype := GetType (constant) ;
IF NOT IsExpressionCompatible (consttype, type)
THEN
- MetaError2 ('the case statement variant tag {%1ad} must be type compatible with the constant {%2Da:is a {%2d}}',
+ MetaError2 ('the case statement variant tag {%1ad} must be type compatible with the constant {%2Da:is a {%2dv}}',
type, constant) ;
RETURN FALSE
END
diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index 614526c0dc06..a717147039bf 100644
--- a/gcc/m2/gm2-compiler/M2Check.mod
+++ b/gcc/m2/gm2-compiler/M2Check.mod
@@ -34,6 +34,7 @@ IMPLEMENTATION MODULE M2Check ;
FROM M2System IMPORT IsSystemType, IsGenericSystemType, IsSameSize, IsComplexN ;
FROM M2Base IMPORT IsParameterCompatible, IsAssignmentCompatible, IsExpressionCompatible, IsComparisonCompatible, IsBaseType, IsMathType, ZType, CType, RType, IsComplexType, Char ;
+FROM M2Bitset IMPORT Bitset ;
FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, KillIndex, HighIndice, LowIndice, IncludeIndiceIntoIndex, ForeachIndiceInIndexDo ;
FROM M2Error IMPORT Error, InternalError, NewError, ErrorString, ChainError ;
@@ -456,7 +457,23 @@ END checkUnbounded ;
(*
- checkArrayTypeEquivalence - check array and unbounded array type equivalence.
+ checkGenericUnboundedTyped - return TRUE if we have a match for
+ an unbounded generic type and a typed object
+ which is not a Z, R or C type.
+*)
+
+PROCEDURE checkGenericUnboundedTyped (unbounded, typed: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN (IsUnbounded (unbounded) AND
+ IsGenericSystemType (GetDType (unbounded)) AND
+ ((NOT IsZRCType (typed)) OR
+ IsTyped (typed) AND (NOT IsZRCType (GetDType (typed)))))
+END checkGenericUnboundedTyped ;
+
+
+(*
+ checkArrayTypeEquivalence - check array and unbounded array type
+ equivalence.
*)
PROCEDURE checkArrayTypeEquivalence (result: status; tinfo: tInfo;
@@ -476,6 +493,12 @@ BEGIN
THEN
result := checkSubrange (result, tinfo, getSType (lSub), getSType (rSub))
END
+ ELSIF checkGenericUnboundedTyped (left, right) OR
+ checkGenericUnboundedTyped (right, left)
+ THEN
+ (* ARRAY OF BYTE (or WORD or LOC etc will be compatible with any typed
+ non ZRC type. *)
+ RETURN true
ELSIF IsUnbounded (left) AND (IsArray (right) OR IsUnbounded (right))
THEN
IF IsGenericSystemType (getSType (left)) OR IsGenericSystemType (getSType (right))
diff --git a/gcc/m2/gm2-compiler/M2Code.mod b/gcc/m2/gm2-compiler/M2Code.mod
index 02526a07b4f4..22771fac74fc 100644
--- a/gcc/m2/gm2-compiler/M2Code.mod
+++ b/gcc/m2/gm2-compiler/M2Code.mod
@@ -78,6 +78,8 @@ FROM M2SSA IMPORT DiscoverSSA ;
FROM m2pp IMPORT CreateDumpGimple, CloseDumpGimple ;
FROM DynamicStrings IMPORT String, KillString ;
+IMPORT M2Diagnostic ;
+
CONST
MaxOptimTimes = 10 ; (* upper limit of no of times we run through all optimization *)
@@ -119,10 +121,10 @@ END Percent ;
(*
- OptimizationAnalysis - displays some simple front end optimization statistics.
+ ResourceAnalysis - displays resource analysis relating to the front end.
*)
-PROCEDURE OptimizationAnalysis ;
+PROCEDURE ResourceAnalysis ;
VAR
value: CARDINAL ;
BEGIN
@@ -146,7 +148,7 @@ BEGIN
FlushBuffer (StdOut)
END ;
DumpQuadruples ('after all front end optimization\n')
-END OptimizationAnalysis ;
+END ResourceAnalysis ;
(*
@@ -293,7 +295,7 @@ BEGIN
qprintf0 (' gcc trees given to the gcc backend\n') ;
EndGlobalContext ;
- OptimizationAnalysis
+ ResourceAnalysis
END Code ;
diff --git a/gcc/m2/gm2-compiler/M2Comp.mod b/gcc/m2/gm2-compiler/M2Comp.mod
index 8aef9ce923dc..741daeb036d0 100644
--- a/gcc/m2/gm2-compiler/M2Comp.mod
+++ b/gcc/m2/gm2-compiler/M2Comp.mod
@@ -48,6 +48,7 @@ FROM P0SymBuild IMPORT P0Init, P1Init ;
FROM M2Debug IMPORT Assert ;
IMPORT m2flex ;
+IMPORT m2block ;
IMPORT P0SyntaxCheck ;
IMPORT P1Build ;
IMPORT P2Build ;
@@ -56,6 +57,7 @@ IMPORT P3Build ;
IMPORT PHBuild ;
IMPORT PCSymBuild ;
IMPORT DynamicStrings ;
+IMPORT M2Diagnostic ;
FROM M2Batch IMPORT GetSource, GetModuleNo, GetDefinitionModuleFile, GetModuleFile,
AssociateModule, AssociateDefinition, MakeImplementationSource,
@@ -70,6 +72,7 @@ FROM SymbolTable IMPORT GetSymName, IsDefImp, NulSym,
GetImportStatementList ;
FROM M2Search IMPORT FindSourceDefFile ;
+FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemSet ;
FROM FIO IMPORT File, StdErr, StdOut, Close, EOF, IsNoError, WriteLine,
WriteChar, FlushOutErr ;
@@ -80,8 +83,8 @@ FROM M2Printf IMPORT fprintf0, fprintf1 ;
FROM M2Quiet IMPORT qprintf0, qprintf1, qprintf2 ;
FROM M2Options IMPORT Verbose, GetM2Prefix, GetM, GetMM, GetDepTarget, GetMF, GetMP,
- GetObj, PPonly, Statistics, Quiet, WholeProgram, GetMD, GetMMD,
- ExtendedOpaque, GenModuleList ;
+ GetObj, PPonly, Quiet, WholeProgram, GetMD, GetMMD,
+ ExtendedOpaque, GenModuleList, TimeReport, MemReport ;
FROM PathName IMPORT DumpPathName ;
FROM Lists IMPORT List, NoOfItemsInList, GetItemFromList ;
@@ -92,6 +95,7 @@ FROM DynamicStrings IMPORT String, InitString, KillString, InitStringCharStar,
InitStringChar, RIndex, Slice, Equal, RemoveWhitePrefix ;
+
CONST
Debugging = FALSE ;
@@ -281,14 +285,43 @@ END Compile ;
PROCEDURE compile (filename: ADDRESS) ;
VAR
- f: String ;
+ f, s: String ;
BEGIN
+ M2Diagnostic.Configure (TimeReport, MemReport) ;
f := InitStringCharStar (filename) ;
Compile (f) ;
- f := KillString (f)
+ f := KillString (f) ;
+ PopulateResource ;
+ IF TimeReport OR MemReport
+ THEN
+ s := WriteS (StdOut, M2Diagnostic.Generate (FALSE)) ;
+ FlushOutErr ;
+ s := KillString (s)
+ END
END compile ;
+(*
+ PopulateResource -
+*)
+
+PROCEDURE PopulateResource ;
+VAR
+ StatsMemDiag: Diagnostic ;
+BEGIN
+ IF MemReport
+ THEN
+ StatsMemDiag
+ := InitMemDiagnostic
+ ('M2Comp:statistics',
+ 'total source lines {1d} total constants {2d} total types {3d}') ;
+ MemSet (StatsMemDiag, 1, m2flex.GetTotalLines ()) ;
+ MemSet (StatsMemDiag, 2, m2block.GetTotalConstants ()) ;
+ MemSet (StatsMemDiag, 3, m2block.GetGlobalTypes ())
+ END
+END PopulateResource ;
+
+
(*
ExamineHeader - examines up until the ';', '[' or eof and determines if the source file
is a program, implementation/definition module.
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 860a89ac8b0c..710976e449eb 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -43,6 +43,7 @@ FROM M2Options IMPORT GenerateDebugging, GenerateLineDebug, Iso, Optimizing, Who
ScaffoldStatic, GetRuntimeModuleOverride ;
FROM M2AsmUtil IMPORT GetFullSymName, GetFullScopeAsmName ;
+FROM FormatStrings IMPORT Sprintf1 ;
FROM M2Batch IMPORT MakeDefinitionSource ;
FROM NameKey IMPORT Name, MakeKey, NulName, KeyToCharStar, makekey ;
@@ -52,6 +53,7 @@ FROM M2LexBuf IMPORT TokenToLineNo, FindFileNameFromToken, TokenToLocation, Unkn
FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3 ;
FROM M2Error IMPORT FlushErrors, InternalError ;
FROM M2LangDump IMPORT GetDumpFile ;
+FROM M2Diagnostic IMPORT Diagnostic, InitTimeDiagnostic, EnterDiagnostic, ExitDiagnostic ;
FROM M2Printf IMPORT printf0, printf1, printf2, printf3,
fprintf0, fprintf1, fprintf2, fprintf3 ;
@@ -84,6 +86,7 @@ FROM SymbolTable IMPORT NulSym,
GetSubrange, PutSubrange, GetArraySubscript,
NoOfParamAny, GetNthParamAny,
PushValue, PopValue, PopSize,
+ IsProcedureAnyNoReturn,
IsTemporary, IsUnbounded, IsPartialUnbounded,
IsEnumeration, IsVar,
IsSubrange, IsPointer, IsRecord, IsArray,
@@ -121,10 +124,11 @@ FROM SymbolTable IMPORT NulSym,
GetAlignment, IsDeclaredPacked, PutDeclaredPacked,
GetDefaultRecordFieldAlignment, IsDeclaredPackedResolved,
GetPackedEquivalent,
+ GetSetArray, PutSetInWord,
GetParameterShadowVar,
GetUnboundedRecordType,
GetModuleCtors, GetProcedureProcType,
- MakeSubrange, MakeConstVar, MakeConstLit,
+ MakeSubrange, MakeConstVar, MakeConstLit, MakeSetArray, PutSetArray,
PutConst,
ForeachOAFamily, GetOAFamily,
IsModuleWithinProcedure, IsVariableSSA,
@@ -194,7 +198,7 @@ FROM m2type IMPORT MarkFunctionReferenced, BuildStartRecord, BuildStartVarient,
BuildSetType, BuildEndVarient, BuildEndArrayType, InitFunctionTypeParameters,
BuildProcTypeParameterDeclaration, DeclareKnownType,
ValueOutOfTypeRange, ExceedsTypeRange,
- GetMaxFrom, GetMinFrom ;
+ GetMaxFrom, GetMinFrom, GetBooleanEnumList ;
FROM m2convert IMPORT BuildConvert ;
@@ -260,6 +264,8 @@ VAR
action : IsAction ;
ConstantResolved,
enumDeps : BOOLEAN ;
+ tempset : CARDINAL ; (* Count of the number of set *)
+ (* arrays created. *)
(* *************************************************** *)
@@ -666,7 +672,7 @@ END GetEnumList ;
PROCEDURE PutEnumList (sym: CARDINAL; enumlist: tree) ;
BEGIN
- PutIndice(EnumerationIndex, sym, enumlist)
+ PutIndice (EnumerationIndex, sym, enumlist)
END PutEnumList ;
@@ -729,17 +735,17 @@ END DoStartDeclaration ;
PROCEDURE ArrayComponentsDeclared (sym: CARDINAL) : BOOLEAN ;
VAR
- Subscript : CARDINAL ;
+ Subscript ,
Type, High, Low: CARDINAL ;
BEGIN
- Subscript := GetArraySubscript(sym) ;
- Assert(IsSubscript(Subscript)) ;
- Type := GetDType(Subscript) ;
- Low := GetTypeMin(Type) ;
- High := GetTypeMax(Type) ;
- RETURN( IsFullyDeclared(Type) AND
- IsFullyDeclared(Low) AND
- IsFullyDeclared(High) )
+ Subscript := GetArraySubscript (sym) ;
+ Assert (IsSubscript (Subscript)) ;
+ Type := GetDType (Subscript) ;
+ Low := GetTypeMin (Type) ;
+ High := GetTypeMax (Type) ;
+ RETURN( IsFullyDeclared (Type) AND
+ IsFullyDeclared (Low) AND
+ IsFullyDeclared (High) )
END ArrayComponentsDeclared ;
@@ -815,11 +821,11 @@ END CanDeclareRecord ;
PROCEDURE FinishDeclareRecord (sym: CARDINAL) ;
BEGIN
- DeclareTypeConstFully(sym) ;
- WatchRemoveList(sym, heldbyalignment) ;
- WatchRemoveList(sym, finishedalignment) ;
- WatchRemoveList(sym, todolist) ;
- WatchIncludeList(sym, fullydeclared)
+ DeclareTypeConstFully (sym) ;
+ WatchRemoveList (sym, heldbyalignment) ;
+ WatchRemoveList (sym, finishedalignment) ;
+ WatchRemoveList (sym, todolist) ;
+ WatchIncludeList (sym, fullydeclared)
END FinishDeclareRecord ;
@@ -912,8 +918,14 @@ END CanDeclareArrayAsNil ;
*)
PROCEDURE DeclareArrayAsNil (sym: CARDINAL) ;
+VAR
+ tokenno : CARDINAL ;
+ typeOfArray: CARDINAL ;
BEGIN
- PreAddModGcc(sym, BuildStartArrayType(BuildIndex(GetDeclaredMod(sym), sym), NIL, GetDType(sym))) ;
+ typeOfArray := GetDType(sym) ;
+ tokenno := GetDeclaredMod (sym) ;
+ PreAddModGcc(sym, BuildStartArrayType (BuildIndex (tokenno, sym, FALSE),
+ NIL, typeOfArray)) ;
WatchIncludeList(sym, niltypedarrays)
END DeclareArrayAsNil ;
@@ -1040,9 +1052,9 @@ BEGIN
ELSIF IsArray(sym)
THEN
RETURN( IsArrayDependants(sym, q) )
- ELSIF IsProcType(sym)
+ ELSIF IsProcType (sym)
THEN
- RETURN( IsProcTypeDependants(sym, q) )
+ RETURN( IsProcTypeDependants (sym, q) )
ELSIF IsUnbounded(sym)
THEN
RETURN( IsUnboundedDependants(sym, q) )
@@ -1100,7 +1112,7 @@ END IsFullyDeclared ;
PROCEDURE AllDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsTypeQ(sym, IsFullyDeclared) )
+ RETURN( IsTypeQ (sym, IsFullyDeclared) )
END AllDependantsFullyDeclared ;
@@ -1111,7 +1123,7 @@ END AllDependantsFullyDeclared ;
PROCEDURE NotAllDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( NOT IsTypeQ(sym, IsFullyDeclared) )
+ RETURN( NOT IsTypeQ (sym, IsFullyDeclared) )
END NotAllDependantsFullyDeclared ;
@@ -1132,7 +1144,7 @@ END IsPartiallyDeclared ;
PROCEDURE AllDependantsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsTypeQ(sym, IsPartiallyDeclared) )
+ RETURN( IsTypeQ (sym, IsPartiallyDeclared) )
END AllDependantsPartiallyDeclared ;
@@ -1143,7 +1155,7 @@ END AllDependantsPartiallyDeclared ;
PROCEDURE NotAllDependantsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( NOT IsTypeQ(sym, IsPartiallyDeclared) )
+ RETURN( NOT IsTypeQ (sym, IsPartiallyDeclared) )
END NotAllDependantsPartiallyDeclared ;
@@ -1165,7 +1177,7 @@ END IsPartiallyOrFullyDeclared ;
PROCEDURE AllDependantsPartiallyOrFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsTypeQ(sym, IsPartiallyOrFullyDeclared) )
+ RETURN( IsTypeQ (sym, IsPartiallyOrFullyDeclared) )
END AllDependantsPartiallyOrFullyDeclared ;
@@ -1208,8 +1220,8 @@ END TypeConstDependantsFullyDeclared ;
PROCEDURE CanBeDeclaredViaPartialDependants (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( (IsPointer(sym) OR IsProcType(sym)) AND
- AllDependantsPartiallyOrFullyDeclared(sym) )
+ RETURN( (IsPointer (sym) OR IsProcType (sym)) AND
+ AllDependantsPartiallyOrFullyDeclared (sym) )
END CanBeDeclaredViaPartialDependants ;
@@ -1262,7 +1274,8 @@ BEGIN
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, todolist)
- ELSE
+ ELSIF NOT IsFullyDeclared (sym)
+ THEN
t := TypeConstFullyDeclared(sym) ;
IF t#NIL
THEN
@@ -1300,6 +1313,105 @@ BEGIN
END DeclareTypeFromPartial ;
+(*
+ CanCreateSetArray - return true if we need to create a set array.
+ All sets will have a set array created even
+ if it is not required.
+*)
+
+PROCEDURE CanCreateSetArray (sym: CARDINAL) : BOOLEAN ;
+VAR
+ setarray: CARDINAL ;
+BEGIN
+ IF IsSet (sym) AND CanCreateSet (sym)
+ THEN
+ setarray := GetSetArray (sym) ;
+ IF setarray = NulSym
+ THEN
+ RETURN TRUE
+ ELSE
+ (* Set array already exists, this can occur if the set is a base type
+ (bitset for example).
+ So we just move the symbol to the correct state. *)
+ WatchRemoveList (sym, todolist) ;
+ WatchIncludeList (sym, finishedsetarray) ;
+ (* WatchIncludeList (setarray, todolist) *)
+ END
+ END ;
+ RETURN FALSE
+END CanCreateSetArray ;
+
+
+(*
+ CreateSetArray - declare the set array for a set type.
+*)
+
+PROCEDURE CreateSetArray (set: CARDINAL) ;
+VAR
+ type, array,
+ high, low : CARDINAL ;
+BEGIN
+ type := GetSType (set) ;
+ low := GetTypeMin (type) ;
+ high := GetTypeMax (type) ;
+ DeclareConstant (GetDeclaredMod (set), high) ;
+ DeclareConstant (GetDeclaredMod (set), low) ;
+ array := DeclareSetArray (set, low, high) ;
+ PutSetArray (set, array) ;
+ WatchRemoveList (set, todolist) ;
+ WatchIncludeList (set, finishedsetarray) ;
+ (* WatchIncludeList (array, todolist) *)
+END CreateSetArray ;
+
+
+(*
+ CanCreateSet - returns TRUE if the set can be created.
+ All dependents of sym have been declared to GCC.
+*)
+
+PROCEDURE CanCreateSet (set: CARDINAL) : BOOLEAN ;
+VAR
+ type, low, high: CARDINAL ;
+BEGIN
+ type := GetSType (set) ;
+ IF NOT GccKnowsAbout (type)
+ THEN
+ RETURN FALSE
+ END ;
+ low := GetTypeMin (type) ;
+ high := GetTypeMax (type) ;
+ IF NOT GccKnowsAbout (low)
+ THEN
+ RETURN FALSE
+ END ;
+ IF NOT GccKnowsAbout (high)
+ THEN
+ RETURN FALSE
+ END ;
+ RETURN TRUE
+END CanCreateSet ;
+
+
+(*
+ CreateSet -
+*)
+
+PROCEDURE CreateSet (set: CARDINAL) ;
+VAR
+ gccset: tree ;
+BEGIN
+ gccset := DeclareSet (set) ;
+ IF gccset = NIL
+ THEN
+ InternalError ('expecting to be able to create a gcc type')
+ ELSE
+ AddModGcc (set, gccset) ;
+ WatchIncludeList (set, fullydeclared) ;
+ WatchRemoveList (set, finishedsetarray)
+ END
+END CreateSet ;
+
+
(*
CanBeDeclaredPartiallyViaPartialDependants - returns TRUE if, sym,
can be partially declared via
@@ -1308,7 +1420,7 @@ END DeclareTypeFromPartial ;
PROCEDURE CanBeDeclaredPartiallyViaPartialDependants (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsType(sym) AND AllDependantsPartiallyDeclared(sym) )
+ RETURN( IsType (sym) AND AllDependantsPartiallyDeclared (sym) )
END CanBeDeclaredPartiallyViaPartialDependants ;
@@ -1339,7 +1451,8 @@ TYPE
Rule = (norule, partialtype, arraynil, pointernilarray, arraypartial,
pointerfully, recordkind, recordfully, typeconstfully,
pointerfrompartial, typefrompartial, partialfrompartial,
- partialtofully, circulartodo, circularpartial, circularniltyped) ;
+ partialtofully, circulartodo, circularpartial, circularniltyped,
+ setarraynul, setfully) ;
VAR
bodyp : WalkAction ;
@@ -1361,22 +1474,24 @@ BEGIN
THEN
CASE bodyr OF
- norule : printf0('norule') |
- partialtype : printf0('partialtype') |
- arraynil : printf0('arraynil') |
- pointernilarray : printf0('pointernilarray') |
- arraypartial : printf0('arraypartial') |
- pointerfully : printf0('pointerfully') |
- recordkind : printf0('recordkind') |
- recordfully : printf0('recordfully') |
- typeconstfully : printf0('typeconstfully') |
- pointerfrompartial: printf0('pointerfrompartial') |
- typefrompartial : printf0('typefrompartial') |
- partialfrompartial: printf0('partialfrompartial') |
- partialtofully : printf0('partialtofully') |
- circulartodo : printf0('circulartodo') |
- circularpartial : printf0('circularpartial') |
- circularniltyped : printf0('circularniltyped')
+ norule : printf0 ('norule') |
+ partialtype : printf0 ('partialtype') |
+ arraynil : printf0 ('arraynil') |
+ pointernilarray : printf0 ('pointernilarray') |
+ arraypartial : printf0 ('arraypartial') |
+ pointerfully : printf0 ('pointerfully') |
+ recordkind : printf0 ('recordkind') |
+ recordfully : printf0 ('recordfully') |
+ typeconstfully : printf0 ('typeconstfully') |
+ pointerfrompartial: printf0 ('pointerfrompartial') |
+ typefrompartial : printf0 ('typefrompartial') |
+ partialfrompartial: printf0 ('partialfrompartial') |
+ partialtofully : printf0 ('partialtofully') |
+ circulartodo : printf0 ('circulartodo') |
+ circularpartial : printf0 ('circularpartial') |
+ circularniltyped : printf0 ('circularniltyped') |
+ setarraynul : printf0 ('setarraynul') |
+ setfully : printf0 ('setfully')
ELSE
InternalError ('unknown rule')
@@ -1450,6 +1565,7 @@ VAR
finished: BOOLEAN ;
copy : Group ;
BEGIN
+ EnterDiagnostic (DeclaredOutstandingTypesDiag) ;
copy := NIL ;
finished := FALSE ;
REPEAT
@@ -1468,6 +1584,20 @@ BEGIN
DeclareTypePartially)
THEN
(* continue looping *)
+ ELSIF ForeachTryDeclare (todolist,
+ setarraynul,
+ CanCreateSetArray,
+ CreateSetArray)
+ THEN
+ (* Populates the finishedsetarray list with each set seen. *)
+ (* Continue looping. *)
+ ELSIF ForeachTryDeclare (finishedsetarray,
+ setfully,
+ CanCreateSet,
+ CreateSet)
+ THEN
+ (* Populates the fullydeclared list with each set. *)
+ (* Continue looping. *)
ELSIF ForeachTryDeclare (todolist,
arraynil,
CanDeclareArrayAsNil,
@@ -1553,6 +1683,7 @@ BEGIN
THEN
END
END ;
+ ExitDiagnostic (DeclaredOutstandingTypesDiag) ;
RETURN NoOfElementsInSet (GlobalGroup^.ToDoList) = 0
END DeclaredOutstandingTypes ;
@@ -1565,18 +1696,18 @@ END DeclaredOutstandingTypes ;
PROCEDURE CompleteDeclarationOf (sym: CARDINAL) : tree ;
BEGIN
- IF IsArray(sym)
+ IF IsArray (sym)
THEN
- RETURN( DeclareArray(sym) )
- ELSIF IsProcType(sym)
+ RETURN( DeclareArray (sym) )
+ ELSIF IsProcType (sym)
THEN
- RETURN( DeclareProcType(sym) )
- ELSIF IsRecordField(sym)
+ RETURN( DeclareProcType (sym) )
+ ELSIF IsRecordField (sym)
THEN
- RETURN( DeclareRecordField(sym) )
- ELSIF IsPointer(sym)
+ RETURN( DeclareRecordField (sym) )
+ ELSIF IsPointer (sym)
THEN
- RETURN( DeclarePointer(sym) )
+ RETURN( DeclarePointer (sym) )
ELSE
RETURN( NIL )
END
@@ -1593,26 +1724,27 @@ VAR
t : tree ;
location: location_t ;
BEGIN
- IF GetSType(sym)=NulSym
+ IF GetSType (sym) = NulSym
THEN
- MetaError1('base type {%1Ua} not understood', sym) ;
+ MetaError1 ('base type {%1Ua} not understood', sym) ;
InternalError ('base type should have been declared')
ELSE
- IF GetSymName(sym)=NulName
+ IF GetSymName (sym) = NulName
THEN
- RETURN( tree(Mod2Gcc(GetSType(sym))) )
+ RETURN( tree (Mod2Gcc (GetSType (sym))) )
ELSE
- location := TokenToLocation(GetDeclaredMod(sym)) ;
- IF GccKnowsAbout(sym)
+ location := TokenToLocation (GetDeclaredMod (sym)) ;
+ IF GccKnowsAbout (sym)
THEN
- t := Mod2Gcc(sym)
+ t := Mod2Gcc (sym)
ELSE
- (* not partially declared therefore start it *)
- t := BuildStartType(location,
- KeyToCharStar(GetFullSymName(sym)), Mod2Gcc(GetSType(sym)))
+ (* Not partially declared therefore start it. *)
+ t := BuildStartType (location,
+ KeyToCharStar (GetFullSymName (sym)),
+ Mod2Gcc (GetSType (sym)))
END ;
- t := BuildEndType(location, t) ; (* now finish it *)
- RETURN( t )
+ t := BuildEndType (location, t) ; (* Now finish it. *)
+ RETURN t
END
END
END DeclareType ;
@@ -2183,9 +2315,9 @@ BEGIN
ELSIF IsArray(sym)
THEN
WalkArrayDependants(sym, p)
- ELSIF IsProcType(sym)
+ ELSIF IsProcType (sym)
THEN
- WalkProcTypeDependants(sym, p)
+ WalkProcTypeDependants (sym, p)
ELSIF IsUnbounded(sym)
THEN
WalkUnboundedDependants(sym, p)
@@ -2235,11 +2367,11 @@ END TraverseDependantsInner ;
PROCEDURE TraverseDependants (sym: WORD) ;
BEGIN
- IF VisitedList=NIL
+ IF VisitedList = NIL
THEN
- VisitedList := InitSet(1) ;
- TraverseDependantsInner(sym) ;
- VisitedList := KillSet(VisitedList)
+ VisitedList := InitSet (1) ;
+ TraverseDependantsInner (sym) ;
+ VisitedList := KillSet (VisitedList)
ELSE
InternalError ('recursive call to TraverseDependants caught')
END
@@ -2247,7 +2379,20 @@ END TraverseDependants ;
(*
- WalkTypeInfo - walks type, sym, and its dependants.
+ WalkUnbounded -
+*)
+
+PROCEDURE WalkUnbounded (sym: WORD) ;
+BEGIN
+ Assert (IsUnbounded (sym)) ;
+ TraverseDependants (sym) ;
+ WalkTypeInfo (GetUnboundedRecordType (sym)) ;
+ WalkTypeInfo (GetSType (sym))
+END WalkUnbounded ;
+
+
+(*
+ WalkTypeInfo - walks type sym and its dependants.
*)
PROCEDURE WalkTypeInfo (sym: WORD) ;
@@ -2255,16 +2400,25 @@ BEGIN
IF IsVarient(sym)
THEN
InternalError ('why have we reached here?')
- ELSIF IsVar(sym)
+ ELSIF IsVar (sym)
THEN
- WalkTypeInfo(GetSType(sym)) ;
- IF GetVarBackEndType(sym)#NulSym
+ WalkTypeInfo (GetSType (sym)) ;
+ IF GetVarBackEndType (sym) # NulSym
THEN
- WalkTypeInfo(GetVarBackEndType(sym))
+ WalkTypeInfo (GetVarBackEndType (sym))
END
- ELSIF IsAModula2Type(sym)
+ ELSIF IsUnbounded (sym)
THEN
- TraverseDependants(sym)
+ WalkUnbounded (sym)
+ ELSIF IsAModula2Type (sym)
+ THEN
+ TraverseDependants (sym)
+ ELSIF IsProcedure (sym)
+ THEN
+ WalkProcedureDependants (sym, WalkTypeInfo)
+ ELSIF IsProcType (sym)
+ THEN
+ WalkProcTypeDependants (sym, WalkTypeInfo)
END
END WalkTypeInfo ;
@@ -2341,7 +2495,7 @@ END WalkUnboundedProcedureParameters ;
PROCEDURE WalkTypesInProcedure (sym: WORD) ;
BEGIN
- ForeachLocalSymDo(sym, TraverseDependants)
+ ForeachLocalSymDo (sym, TraverseDependants)
END WalkTypesInProcedure ;
@@ -2358,9 +2512,9 @@ BEGIN
n := GetSymName(sym) ;
printf1('Declaring types in MODULE %a\n', n)
END ;
- ForeachLocalSymDo(sym, WalkTypeInfo) ;
- ForeachLocalSymDo(sym, WalkUnboundedProcedureParameters) ;
- ForeachInnerModuleDo(sym, WalkTypesInModule)
+ ForeachLocalSymDo (sym, WalkTypeInfo) ;
+ ForeachLocalSymDo (sym, WalkUnboundedProcedureParameters) ;
+ ForeachInnerModuleDo (sym, WalkTypesInModule)
END WalkTypesInModule ;
@@ -2375,12 +2529,12 @@ VAR
final: BOOLEAN ;
BEGIN
final := TRUE ;
- IF NOT q(GetSType(sym))
+ IF NOT q (GetSType (sym))
THEN
final := FALSE
END ;
- align := GetAlignment(sym) ;
- IF (align#NulSym) AND (NOT q(align))
+ align := GetAlignment (sym) ;
+ IF (align # NulSym) AND (NOT q (align))
THEN
final := FALSE
END ;
@@ -2494,7 +2648,7 @@ END IsExternalToWholeProgram ;
DeclareProcedureToGccWholeProgram -
*)
-PROCEDURE DeclareProcedureToGccWholeProgram (Sym: CARDINAL) ;
+PROCEDURE DeclareProcedureToGccWholeProgram (ProcedureSym: CARDINAL) ;
VAR
returnType,
GccParam : tree ;
@@ -2505,19 +2659,20 @@ VAR
begin, end,
location : location_t ;
BEGIN
- IF (NOT GccKnowsAbout(Sym)) AND (NOT IsPseudoProcFunc(Sym))
+ Assert (IsProcedure (ProcedureSym)) ;
+ IF (NOT GccKnowsAbout(ProcedureSym)) AND (NOT IsPseudoProcFunc(ProcedureSym))
THEN
- BuildStartFunctionDeclaration(UsesVarArgs(Sym)) ;
- p := NoOfParamAny (Sym) ;
+ BuildStartFunctionDeclaration(UsesVarArgs(ProcedureSym)) ;
+ p := NoOfParamAny (ProcedureSym) ;
i := p ;
WHILE i>0 DO
(* note we dont use GetNthParamAny as we want the parameter that is seen by the procedure block
remember that this is treated exactly the same as a variable, just its position on
the activation record is special (ie a parameter)
*)
- Variable := GetNth(Sym, i) ;
- location := TokenToLocation(GetDeclaredMod(Variable)) ;
- IF IsUnboundedParamAny (Sym, i)
+ Variable := GetNth (ProcedureSym, i) ;
+ location := TokenToLocation (GetDeclaredMod (Variable)) ;
+ IF IsUnboundedParamAny (ProcedureSym, i)
THEN
GccParam := BuildParameterDeclaration(location,
KeyToCharStar(GetSymName(Variable)),
@@ -2527,34 +2682,34 @@ BEGIN
GccParam := BuildParameterDeclaration(location,
KeyToCharStar(GetSymName(Variable)),
Mod2Gcc(GetLType(Variable)),
- IsVarParamAny (Sym, i))
+ IsVarParamAny (ProcedureSym, i))
END ;
PreAddModGcc(Variable, GccParam) ;
WatchRemoveList(Variable, todolist) ;
WatchIncludeList(Variable, fullydeclared) ;
DEC(i)
END ;
- GetProcedureBeginEnd(Sym, b, e) ;
+ GetProcedureBeginEnd(ProcedureSym, b, e) ;
begin := TokenToLocation(b) ;
end := TokenToLocation(e) ;
- scope := GetScope(Sym) ;
+ scope := GetScope(ProcedureSym) ;
PushBinding(scope) ;
- IF GetSType(Sym)=NulSym
+ IF GetSType(ProcedureSym)=NulSym
THEN
returnType := NIL
ELSE
- returnType := Mod2Gcc(GetSType(Sym))
+ returnType := Mod2Gcc(GetSType(ProcedureSym))
END ;
- PreAddModGcc(Sym, BuildEndFunctionDeclaration(begin, end,
- KeyToCharStar(GetFullSymName(Sym)),
- returnType,
- IsExternalToWholeProgram(Sym),
- IsProcedureGccNested(Sym),
- IsExported(GetModuleWhereDeclared(Sym), Sym),
- IsProcedureAnyNoReturn(Sym))) ;
+ PreAddModGcc(ProcedureSym, BuildEndFunctionDeclaration(begin, end,
+ KeyToCharStar(GetFullSymName(ProcedureSym)),
+ returnType,
+ IsExternalToWholeProgram(ProcedureSym),
+ IsProcedureGccNested(ProcedureSym),
+ IsExported(GetModuleWhereDeclared(ProcedureSym), ProcedureSym),
+ IsProcedureAnyNoReturn(ProcedureSym))) ;
PopBinding(scope) ;
- WatchRemoveList(Sym, todolist) ;
- WatchIncludeList(Sym, fullydeclared)
+ WatchRemoveList(ProcedureSym, todolist) ;
+ WatchIncludeList(ProcedureSym, fullydeclared)
END
END DeclareProcedureToGccWholeProgram ;
@@ -2563,7 +2718,7 @@ END DeclareProcedureToGccWholeProgram ;
DeclareProcedureToGccSeparateProgram -
*)
-PROCEDURE DeclareProcedureToGccSeparateProgram (Sym: CARDINAL) ;
+PROCEDURE DeclareProcedureToGccSeparateProgram (ProcedureSym: CARDINAL) ;
VAR
returnType,
GccParam : tree ;
@@ -2575,64 +2730,76 @@ VAR
location : location_t ;
tok : CARDINAL ;
BEGIN
- tok := GetDeclaredMod(Sym) ;
- IF (NOT GccKnowsAbout(Sym)) AND (NOT IsPseudoProcFunc(Sym)) AND
- (IsEffectivelyImported(GetMainModule(), Sym) OR
- (GetModuleWhereDeclared (Sym) = GetMainModule()) OR
- IsNeededAtRunTime (tok, Sym) OR
- IsImported (GetBaseModule (), Sym) OR
- IsExported(GetModuleWhereDeclared (Sym), Sym) OR
- IsExtern (Sym))
- THEN
- BuildStartFunctionDeclaration(UsesVarArgs(Sym)) ;
- p := NoOfParamAny (Sym) ;
+ Assert (IsProcedure (ProcedureSym)) ;
+ tok := GetDeclaredMod (ProcedureSym) ;
+ IF (NOT GccKnowsAbout (ProcedureSym)) AND (NOT IsPseudoProcFunc (ProcedureSym)) AND
+ (IsEffectivelyImported (GetMainModule (), ProcedureSym) OR
+ (GetModuleWhereDeclared (ProcedureSym) = GetMainModule ()) OR
+ IsNeededAtRunTime (tok, ProcedureSym) OR
+ IsImported (GetBaseModule (), ProcedureSym) OR
+ IsExported(GetModuleWhereDeclared (ProcedureSym), ProcedureSym) OR
+ IsExtern (ProcedureSym))
+ THEN
+ BuildStartFunctionDeclaration (UsesVarArgs (ProcedureSym)) ;
+ p := NoOfParamAny (ProcedureSym) ;
i := p ;
- WHILE i>0 DO
+ WHILE i > 0 DO
(* Note we dont use GetNthParamAny as we want the parameter that is seen by
the procedure block remember that this is treated exactly the same as
a variable, just its position on the activation record is special (ie
a parameter). *)
- Variable := GetNth(Sym, i) ;
- location := TokenToLocation(GetDeclaredMod(Variable)) ;
- IF IsUnboundedParamAny (Sym, i)
+ Variable := GetNth (ProcedureSym, i) ;
+ location := TokenToLocation (GetDeclaredMod (Variable)) ;
+ IF GetSType (Variable) = NulSym
THEN
- GccParam := BuildParameterDeclaration(location,
- KeyToCharStar(GetSymName(Variable)),
- Mod2Gcc(GetLType(Variable)),
- FALSE)
+ MetaError1 ('internal error: the type of parameter {%1Ead} is nulsym', Variable) ;
+ FlushErrors
+ END ;
+ IF Mod2Gcc (GetSType (Variable)) = NIL
+ THEN
+ MetaError2 ('internal error: the type of parameter {%1Ead} in procedure {%2ad} has not been declared to GCC', Variable, ProcedureSym) ;
+ FlushErrors ;
+ Assert (AllDependantsFullyDeclared (ProcedureSym))
+ END ;
+ IF IsUnboundedParamAny (ProcedureSym, i)
+ THEN
+ GccParam := BuildParameterDeclaration (location,
+ KeyToCharStar (GetSymName (Variable)),
+ Mod2Gcc (GetLType (Variable)),
+ FALSE)
ELSE
- GccParam := BuildParameterDeclaration(location,
- KeyToCharStar(GetSymName(Variable)),
- Mod2Gcc(GetLType(Variable)),
- IsVarParamAny (Sym, i))
+ GccParam := BuildParameterDeclaration (location,
+ KeyToCharStar (GetSymName (Variable)),
+ Mod2Gcc (GetLType (Variable)),
+ IsVarParamAny (ProcedureSym, i))
END ;
- PreAddModGcc(Variable, GccParam) ;
- WatchRemoveList(Variable, todolist) ;
- WatchIncludeList(Variable, fullydeclared) ;
- DEC(i)
+ PreAddModGcc (Variable, GccParam) ;
+ WatchRemoveList (Variable, todolist) ;
+ WatchIncludeList (Variable, fullydeclared) ;
+ DEC (i)
END ;
- GetProcedureBeginEnd(Sym, b, e) ;
- begin := TokenToLocation(b) ;
- end := TokenToLocation(e) ;
- scope := GetScope(Sym) ;
- PushBinding(scope) ;
- IF GetSType(Sym)=NulSym
+ GetProcedureBeginEnd (ProcedureSym, b, e) ;
+ begin := TokenToLocation (b) ;
+ end := TokenToLocation (e) ;
+ scope := GetScope (ProcedureSym) ;
+ PushBinding (scope) ;
+ IF GetSType (ProcedureSym) = NulSym
THEN
returnType := NIL
ELSE
- returnType := Mod2Gcc(GetSType(Sym))
+ returnType := Mod2Gcc (GetSType (ProcedureSym))
END ;
- PreAddModGcc (Sym, BuildEndFunctionDeclaration (begin, end,
- KeyToCharStar (GetFullSymName (Sym)),
- returnType,
- IsExternal (Sym), (* Extern relative to the main module. *)
- IsProcedureGccNested (Sym),
- (* Exported from the module where it was declared. *)
- IsExported (GetModuleWhereDeclared (Sym), Sym) OR IsExtern (Sym),
- IsProcedureAnyNoReturn(Sym))) ;
- PopBinding(scope) ;
- WatchRemoveList(Sym, todolist) ;
- WatchIncludeList(Sym, fullydeclared)
+ PreAddModGcc (ProcedureSym, BuildEndFunctionDeclaration (begin, end,
+ KeyToCharStar (GetFullSymName (ProcedureSym)),
+ returnType,
+ IsExternal (ProcedureSym), (* Extern relative to the main module. *)
+ IsProcedureGccNested (ProcedureSym),
+ (* Exported from the module where it was declared. *)
+ IsExported (GetModuleWhereDeclared (ProcedureSym), ProcedureSym) OR IsExtern (ProcedureSym),
+ IsProcedureAnyNoReturn (ProcedureSym))) ;
+ PopBinding (scope) ;
+ WatchRemoveList (ProcedureSym, todolist) ;
+ WatchIncludeList (ProcedureSym, fullydeclared)
END
END DeclareProcedureToGccSeparateProgram ;
@@ -2741,6 +2908,7 @@ BEGIN
THEN
DisplayQuadRange (scope, start, end)
END ;
+ EnterDiagnostic (DeclareTypesConstantsProceduresInRangeDiag) ;
loop := 0 ;
copy := NIL ;
sb := InitScopeBlock (scope) ;
@@ -2772,7 +2940,8 @@ BEGIN
KillGroup (copy) ;
bb := InitBasicBlocks (sb) ;
KillBasicBlocks (bb) ;
- KillScopeBlock (sb)
+ KillScopeBlock (sb) ;
+ ExitDiagnostic (DeclareTypesConstantsProceduresInRangeDiag)
END DeclareTypesConstantsProceduresInRange ;
@@ -2839,6 +3008,7 @@ BEGIN
THEN
printf0 ("declaring types constants in: ") ; PrintTerse (scope)
END ;
+ EnterDiagnostic (DeclareTypesConstantsProceduresDiag) ;
copy := NIL ;
sb := InitScopeBlock (scope) ;
PushBinding (scope) ;
@@ -2848,7 +3018,8 @@ BEGIN
UNTIL EqualGroup (copy, GlobalGroup) ;
KillGroup (copy) ;
PopBinding (scope) ;
- KillScopeBlock (sb)
+ KillScopeBlock (sb) ;
+ ExitDiagnostic (DeclareTypesConstantsProceduresDiag)
END DeclareTypesConstantsProcedures ;
@@ -2902,16 +3073,16 @@ END DeclareModuleInit ;
PROCEDURE StartDeclareProcedureScope (scope: CARDINAL) ;
BEGIN
- WalkTypesInProcedure(scope) ;
- DeclareProcedure(scope) ;
- ForeachInnerModuleDo(scope, WalkTypesInModule) ;
+ WalkTypesInProcedure (scope) ;
+ DeclareProcedure (scope) ;
+ ForeachInnerModuleDo (scope, WalkTypesInModule) ;
DeclareTypesConstantsProcedures (scope) ;
- ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ;
- DeclareLocalVariables(scope) ;
- ForeachInnerModuleDo(scope, DeclareModuleVariables) ;
- AssertAllTypesDeclared(scope) ;
- ForeachProcedureDo(scope, DeclareProcedure) ;
- ForeachInnerModuleDo(scope, StartDeclareScope)
+ ForeachInnerModuleDo (scope, DeclareTypesConstantsProcedures) ;
+ DeclareLocalVariables (scope) ;
+ ForeachInnerModuleDo (scope, DeclareModuleVariables) ;
+ AssertAllTypesDeclared (scope) ;
+ ForeachProcedureDo (scope, DeclareProcedure) ;
+ ForeachInnerModuleDo (scope, StartDeclareScope)
END StartDeclareProcedureScope ;
@@ -3122,20 +3293,20 @@ END PreAddModGcc ;
PROCEDURE DeclareDefaultType (sym: CARDINAL; name: ARRAY OF CHAR; gcctype: tree) ;
VAR
t : tree ;
+ array,
high, low: CARDINAL ;
location : location_t ;
BEGIN
- (* DeclareDefaultType will declare a new identifier as a type of, gcctype, if it has not already been
- declared by gccgm2.c *)
+ (* DeclareDefaultType will declare a new identifier as a type of gcctype
+ if it has not already been declared. *)
location := BuiltinsLocation () ;
t := GetDefaultType(location, KeyToCharStar(MakeKey(name)), gcctype) ;
- AddModGcc(sym, t) ;
- IncludeElementIntoSet(GlobalGroup^.FullyDeclared, sym) ;
- WalkAssociatedUnbounded(sym, TraverseDependants) ;
- (*
- this is very simplistic and assumes that the caller only uses Subranges, Sets and GCC types.
- We need to declare any constants with the types so that AllDependantsFullyDeclared works.
- *)
+ AddModGcc (sym, t) ;
+ IncludeElementIntoSet (GlobalGroup^.FullyDeclared, sym) ;
+ WalkAssociatedUnbounded (sym, TraverseDependants) ;
+ (* This is very simplistic and assumes that the caller only uses Subranges,
+ Sets and GCC types. We need to declare any constants with the types so
+ that AllDependantsFullyDeclared works. *)
IF IsSubrange(sym)
THEN
GetSubrange(sym, high, low) ;
@@ -3147,17 +3318,20 @@ BEGIN
THEN
IF NOT GccKnowsAbout(GetSType(sym))
THEN
- (* only true for internal types of course *)
+ (* Only true for internal types of course. *)
InternalError ('subrange type within the set type must be declared before the set type')
END ;
GetSubrange(GetSType(sym), high, low) ;
DeclareConstant(GetDeclaredMod(sym), high) ;
- DeclareConstant(GetDeclaredMod(sym), low)
+ DeclareConstant(GetDeclaredMod(sym), low) ;
+ array := DeclareSetArray (sym, low, high) ;
+ (* IncludeElementIntoSet (FullyDeclared, array) ; *)
+ PutSetArray (sym, array)
ELSIF IsEnumeration(GetSType(sym))
THEN
IF NOT GccKnowsAbout(GetSType(sym))
THEN
- (* only true for internal types of course *)
+ (* Only true for internal types of course. *)
InternalError ('enumeration type within the set type must be declared before the set type')
END
END
@@ -3473,7 +3647,7 @@ BEGIN
We do not add an extra pointer if this is the case.
*)
varType := SkipType (GetVarBackEndType (var)) ;
- IF varType=NulSym
+ IF varType = NulSym
THEN
(* We have not explicity told back end the type, so build it. *)
varType := GetSType (var) ;
@@ -3590,7 +3764,7 @@ BEGIN
INC (n) ;
Variable := GetNth (ModSym, n)
END ;
- ForeachInnerModuleDo(ModSym, DeclareGlobalVariablesWholeProgram)
+ ForeachInnerModuleDo (ModSym, DeclareGlobalVariablesWholeProgram)
END DeclareGlobalVariablesWholeProgram ;
@@ -4002,7 +4176,8 @@ PROCEDURE PrintAlignment (sym: CARDINAL) ;
VAR
align: CARDINAL ;
BEGIN
- IF IsRecord(sym) OR IsType(sym) OR IsRecordField(sym) OR IsPointer(sym) OR IsArray(sym)
+ IF IsRecord(sym) OR IsType(sym) OR IsRecordField(sym) OR
+ IsPointer(sym) OR IsArray(sym)
THEN
align := GetAlignment(sym) ;
IF align#NulSym
@@ -4164,7 +4339,7 @@ BEGIN
PrintDeclared (sym) ;
fprintf0 (GetDumpFile (), '\n') ;
FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO
- fprintf0 (GetDumpFile (), 'parameters ') ;
+ fprintf0 (GetDumpFile (), ' parameters ') ;
PrintKind (kind) ;
IF GetProcedureParametersDefined (sym, kind)
THEN
@@ -4271,6 +4446,19 @@ BEGIN
END PrintString ;
+(*
+ PrintKnown -
+*)
+
+PROCEDURE PrintKnown (sym: CARDINAL) ;
+BEGIN
+ IF GccKnowsAbout (sym)
+ THEN
+ printf0 ("[gcc]")
+ END
+END PrintKnown ;
+
+
(*
PrintVerboseFromList - prints the, i, th element in the list, l.
*)
@@ -4870,9 +5058,9 @@ VAR
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
Assert(IsSet(sym)) ;
- type := GetDType(sym) ;
- low := GetTypeMin(type) ;
- high := GetTypeMax(type) ;
+ type := GetDType(sym) ; (* Was GetSType. *)
+ low := GetTypeMin (type) ;
+ high := GetTypeMax (type) ;
highLimit := BuildSub(location, Mod2Gcc(high), Mod2Gcc(low), FALSE) ;
(* --fixme-- we need to check that low <= WORDLENGTH. *)
highLimit := BuildLSL(location, GetIntegerOne(location), highLimit, FALSE) ;
@@ -4918,7 +5106,7 @@ BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
gccenum := BuildStartEnumeration(location, KeyToCharStar(GetFullSymName(sym)), TRUE) ;
ForeachLocalSymDo(sym, DeclarePackedFieldEnumeration) ;
- enumlist := GetEnumList(equiv) ;
+ enumlist := GetEnumList (equiv) ;
gccenum := BuildEndEnumeration(location, gccenum, enumlist) ;
AddModGcc(equiv, gccenum)
END DeclarePackedEnumeration ;
@@ -5247,11 +5435,12 @@ END DeclareUnbounded ;
BuildIndex -
*)
-PROCEDURE BuildIndex (tokenno: CARDINAL; array: CARDINAL) : tree ;
+PROCEDURE BuildIndex (tokenno: CARDINAL; array: CARDINAL; isset: BOOLEAN) : tree ;
VAR
Subscript: CARDINAL ;
Type,
High, Low: CARDINAL ;
+ indexType,
n,
low, high: tree ;
location : location_t ;
@@ -5272,18 +5461,25 @@ BEGIN
n := BuildConvert (location, GetIntegerType (), BuildSub (location, high, low, FALSE), FALSE) ;
IF TreeOverflow(n) OR ValueOutOfTypeRange (GetIntegerType (), n)
THEN
- MetaError3('implementation restriction, array is too large {%1EDM}, the range {%2ad}..{%3ad} exceeds the integer range',
- array, Low, High) ;
- RETURN BuildArrayIndexType (GetIntegerZero (location), GetIntegerZero (location))
+ IF isset
+ THEN
+ MetaError3('implementation restriction, set is too large {%1EDM}, the range {%2ad}..{%3ad} exceeds the integer range',
+ array, Low, High)
+ ELSE
+ MetaError3('implementation restriction, array is too large {%1EDM}, the range {%2ad}..{%3ad} exceeds the integer range',
+ array, Low, High)
+ END ;
+ indexType := BuildArrayIndexType (GetIntegerZero (location), GetIntegerZero (location))
ELSE
PutArrayLarge (array) ;
- RETURN BuildArrayIndexType (GetIntegerZero (location), n)
+ indexType := BuildArrayIndexType (GetIntegerZero (location), n)
END
ELSE
low := BuildConvert (location, GetIntegerType (), low, FALSE) ;
high := BuildConvert (location, GetIntegerType (), high, FALSE) ;
- RETURN BuildArrayIndexType (low, high)
- END
+ indexType := BuildArrayIndexType (low, high)
+ END ;
+ RETURN indexType
END BuildIndex ;
@@ -5307,24 +5503,24 @@ BEGIN
location := TokenToLocation(tokenno) ;
Subscript := GetArraySubscript(Sym) ;
- typeOfArray := GetDType(Sym) ;
+ typeOfArray := GetDType (Sym) ;
GccArray := Mod2Gcc(typeOfArray) ;
- GccIndex := BuildIndex(tokenno, Sym) ;
+ GccIndex := BuildIndex (tokenno, Sym, FALSE) ;
- IF GccKnowsAbout(Sym)
+ IF GccKnowsAbout (Sym)
THEN
- ArrayType := Mod2Gcc(Sym)
+ ArrayType := Mod2Gcc (Sym)
ELSE
- ArrayType := BuildStartArrayType(GccIndex, GccArray, typeOfArray) ;
- PreAddModGcc(Sym, ArrayType)
+ ArrayType := BuildStartArrayType (GccIndex, GccArray, typeOfArray) ;
+ PreAddModGcc (Sym, ArrayType)
END ;
- PreAddModGcc(Subscript, GccArray) ; (* we save the type of this array as the subscript *)
- PushIntegerTree(BuildSize(location, GccArray, FALSE)) ; (* and the size of this array so far *)
- PopSize(Subscript) ;
+ PreAddModGcc (Subscript, GccArray) ; (* we save the type of this array as the subscript *)
+ PushIntegerTree (BuildSize (location, GccArray, FALSE)) ; (* and the size of this array so far *)
+ PopSize (Subscript) ;
- GccArray := BuildEndArrayType(ArrayType, GccArray, GccIndex, typeOfArray) ;
- Assert(GccArray=ArrayType) ;
+ GccArray := BuildEndArrayType (ArrayType, GccArray, GccIndex, typeOfArray) ;
+ Assert (GccArray = ArrayType) ;
RETURN( GccArray )
END DeclareArray ;
@@ -5408,13 +5604,13 @@ PROCEDURE GetTypeMin (type: CARDINAL) : CARDINAL ;
VAR
min, max: CARDINAL ;
BEGIN
- IF IsSubrange(type)
+ IF IsSubrange (type)
THEN
- GetSubrange(type, max, min) ;
+ GetSubrange (type, max, min) ;
RETURN( min )
ELSIF IsSet(type)
THEN
- RETURN( GetTypeMin(GetSType(type)) )
+ RETURN( GetTypeMin (GetSType (type)) )
ELSIF IsEnumeration(type)
THEN
MinEnumerationField := NulSym ;
@@ -5423,18 +5619,18 @@ BEGIN
RETURN( MinEnumerationField )
ELSIF IsBaseType(type)
THEN
- GetBaseTypeMinMax(type, min, max) ;
+ GetBaseTypeMinMax (type, min, max) ;
RETURN( min )
- ELSIF IsSystemType(type)
+ ELSIF IsSystemType (type)
THEN
- GetSystemTypeMinMax(type, min, max) ;
+ GetSystemTypeMinMax (type, min, max) ;
RETURN( min )
- ELSIF GetSType(type)=NulSym
+ ELSIF GetSType (type) = NulSym
THEN
- MetaError1('unable to obtain the MIN value for type {%1as}', type) ;
+ MetaError1 ('unable to obtain the MIN value for type {%1as}', type) ;
RETURN NulSym
ELSE
- RETURN( GetTypeMin(GetSType(type)) )
+ RETURN( GetTypeMin (GetSType (type)) )
END
END GetTypeMin ;
@@ -5447,33 +5643,33 @@ PROCEDURE GetTypeMax (type: CARDINAL) : CARDINAL ;
VAR
min, max: CARDINAL ;
BEGIN
- IF IsSubrange(type)
+ IF IsSubrange (type)
THEN
- GetSubrange(type, max, min) ;
+ GetSubrange (type, max, min) ;
RETURN( max )
- ELSIF IsSet(type)
+ ELSIF IsSet (type)
THEN
- RETURN( GetTypeMax(GetSType(type)) )
- ELSIF IsEnumeration(type)
+ RETURN( GetTypeMax (GetSType (type)) )
+ ELSIF IsEnumeration (type)
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MaxEnumerationField )
- ELSIF IsBaseType(type)
+ ELSIF IsBaseType (type)
THEN
- GetBaseTypeMinMax(type, min, max) ;
+ GetBaseTypeMinMax (type, min, max) ;
RETURN( max )
- ELSIF IsSystemType(type)
+ ELSIF IsSystemType (type)
THEN
- GetSystemTypeMinMax(type, min, max) ;
+ GetSystemTypeMinMax (type, min, max) ;
RETURN( max )
- ELSIF GetSType(type)=NulSym
+ ELSIF GetSType (type) = NulSym
THEN
- MetaError1('unable to obtain the MAX value for type {%1as}', type) ;
+ MetaError1 ('unable to obtain the MAX value for type {%1as}', type) ;
RETURN NulSym
ELSE
- RETURN( GetTypeMax(GetSType(type)) )
+ RETURN( GetTypeMax (GetSType (type)) )
END
END GetTypeMax ;
@@ -5495,101 +5691,33 @@ END PushNoOfBits ;
(*
- DeclareLargeSet - n is the name of the set.
- type is the subrange type (or simple type)
- low and high are the limits of the subrange.
-*)
+ DeclareSetArrayOrBitSet - works out whether the set will exceed SIZE (BITSET).
+ If it does we manufacture a set using:
-PROCEDURE DeclareLargeSet (n: Name; type: CARDINAL; low, high: CARDINAL) : tree ;
-VAR
- lowtree,
- hightree,
- BitsInSet,
- RecordType,
- GccField,
- FieldList : tree ;
- bpw : CARDINAL ;
- location : location_t ;
-BEGIN
- location := TokenToLocation(GetDeclaredMod(type)) ;
- bpw := GetBitsPerBitset() ;
- PushValue(low) ;
- lowtree := PopIntegerTree() ;
- PushValue(high) ;
- hightree := PopIntegerTree() ;
- FieldList := tree(NIL) ;
- RecordType := BuildStartRecord(location, KeyToCharStar(n)) ; (* no problem with recursive types here *)
- PushNoOfBits(type, low, high) ;
- PushCard(1) ;
- Addn ;
- BitsInSet := PopIntegerTree() ;
- PushIntegerTree(BitsInSet) ;
- PushCard(0) ;
- WHILE Gre(GetDeclaredMod(type)) DO
- PushIntegerTree(BitsInSet) ;
- PushCard(bpw-1) ;
- IF GreEqu(GetDeclaredMod(type))
- THEN
- PushIntegerTree(lowtree) ;
- PushCard(bpw-1) ;
- Addn ;
- GccField := BuildFieldRecord(location, NIL, BuildSetType(location, NIL, Mod2Gcc(type), lowtree, PopIntegerTree(), FALSE)) ;
- PushIntegerTree(lowtree) ;
- PushCard(bpw) ;
- Addn ;
- lowtree := PopIntegerTree() ;
- PushIntegerTree(BitsInSet) ;
- PushCard(bpw) ;
- Sub ;
- BitsInSet := PopIntegerTree()
- ELSE
- (* printf2('range is %a..%a\n', GetSymName(low), GetSymName(high)) ; *)
- GccField := BuildFieldRecord(location, NIL, BuildSetType(location, NIL, Mod2Gcc(type), lowtree, hightree, FALSE)) ;
- PushCard(0) ;
- BitsInSet := PopIntegerTree()
- END ;
- FieldList := ChainOn(FieldList, GccField) ;
- PushIntegerTree(BitsInSet) ;
- PushCard(0)
- END ;
- RETURN( BuildEndRecord(location, RecordType, FieldList, FALSE) )
-END DeclareLargeSet ;
-
-
-(*
- DeclareLargeOrSmallSet - works out whether the set will exceed TSIZE(WORD). If it does
- we manufacture a set using:
+ settype = ARRAY [0..totalBits DIV SIZE (BITSET)] OF BITSET ;
- settype = RECORD
- w1: SET OF [...]
- w2: SET OF [...]
- END
-
- We do this as GCC and GDB (stabs) only knows about WORD sized sets.
- If the set will fit into a WORD then we call gccgm2 directly.
+ When GCC supports dwarf5 set types this code should be revised.
+ If the set will fit into a WORD then we call gccgm2 directly.
*)
-PROCEDURE DeclareLargeOrSmallSet (sym: CARDINAL;
- n: Name; type: CARDINAL; low, high: CARDINAL) : tree ;
+PROCEDURE DeclareSetArrayOrBitSet (sym: CARDINAL;
+ n: Name; type: CARDINAL; low, high: CARDINAL) : tree ;
VAR
location: location_t ;
- packed : BOOLEAN ;
-BEGIN
- PushNoOfBits(type, low, high) ;
- PushCard(GetBitsPerBitset()) ;
- packed := IsSetPacked (sym) ;
- IF Less(GetDeclaredMod(type))
- THEN
- location := TokenToLocation(GetDeclaredMod(sym)) ;
- (* small set *)
- (* PutSetSmall(sym) ; *)
- RETURN BuildSetType (location, KeyToCharStar(n),
- Mod2Gcc(type), Mod2Gcc(low), Mod2Gcc(high), packed)
+BEGIN
+ PushNoOfBits (type, low, high) ;
+ PushCard (GetBitsPerBitset()) ;
+ location := TokenToLocation (GetDeclaredMod (sym)) ;
+ IF Less (GetDeclaredMod (type))
+ THEN
+ PutSetInWord (sym, TRUE) ;
+ RETURN BuildSetType (location, KeyToCharStar (n),
+ Mod2Gcc (type), Mod2Gcc (low), Mod2Gcc (high), TRUE)
ELSE
- (* PutSetLarge(sym) ; *)
- RETURN DeclareLargeSet (n, type, low, high) (* --fixme-- finish packed here as well. *)
+ PutSetInWord (sym, FALSE) ;
+ RETURN DeclareArray (GetSetArray (sym))
END
-END DeclareLargeOrSmallSet ;
+END DeclareSetArrayOrBitSet ;
(*
@@ -5602,15 +5730,17 @@ VAR
type,
high, low: CARDINAL ;
BEGIN
- type := GetDType(sym) ;
- IF IsSubrange(type)
+ type := GetSType (sym) ;
+ IF IsSubrange (type)
THEN
- GetSubrange(type, high, low) ;
- gccsym := DeclareLargeOrSmallSet(sym, GetFullSymName(sym), GetSType(type), low, high)
+ GetSubrange (type, high, low) ;
+ gccsym := DeclareSetArrayOrBitSet (sym, GetFullSymName (sym),
+ GetSType (type), low, high)
ELSE
- gccsym := DeclareLargeOrSmallSet(sym, GetFullSymName(sym), type, GetTypeMin(type), GetTypeMax(type))
+ gccsym := DeclareSetArrayOrBitSet (sym, GetFullSymName (sym),
+ type, GetTypeMin (type), GetTypeMax (type))
END ;
- RETURN( gccsym )
+ RETURN gccsym
END DeclareSet ;
@@ -5696,19 +5826,19 @@ BEGIN
t := DeclareVarient(sym)
ELSIF IsPointer(sym)
THEN
- t := CheckAlignment(DeclarePointer(sym), sym)
+ t := CheckAlignment (DeclarePointer (sym), sym)
ELSIF IsUnbounded(sym)
THEN
t := DeclareUnbounded(sym)
ELSIF IsArray(sym)
THEN
- t := CheckAlignment(DeclareArray(sym), sym)
+ t := CheckAlignment (DeclareArray (sym), sym)
ELSIF IsProcType(sym)
THEN
t := DeclareProcType(sym)
ELSIF IsSet(sym)
THEN
- t := DeclareSet(sym)
+ t := CheckAlignment (DeclareSet (sym), sym)
ELSIF IsConst(sym)
THEN
IF IsConstructor(sym)
@@ -5981,11 +6111,17 @@ PROCEDURE WalkPointerDependants (sym: CARDINAL; p: WalkAction) ;
VAR
align: CARDINAL ;
BEGIN
- p(GetSType(sym)) ;
- align := GetAlignment(sym) ;
- IF align#NulSym
+ IF GetSType (sym) = NulSym
THEN
- p(align)
+ MetaError1 ('pointer type {%1Ua} is unresolved', sym) ;
+ InternalError ('pointer type should have been declared')
+ ELSE
+ p (GetSType (sym)) ;
+ align := GetAlignment (sym) ;
+ IF align # NulSym
+ THEN
+ p (align)
+ END
END
END WalkPointerDependants ;
@@ -6321,7 +6457,7 @@ END WalkVarientFieldDependants ;
PROCEDURE IsArrayDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result : BOOLEAN ;
- align : CARDINAL ;
+ align,
subscript: CARDINAL ;
high, low: CARDINAL ;
type : CARDINAL ;
@@ -6329,7 +6465,6 @@ BEGIN
result := TRUE ;
Assert(IsArray(sym)) ;
type := GetSType(sym) ;
-
IF NOT q(type)
THEN
result := FALSE
@@ -6339,11 +6474,11 @@ BEGIN
THEN
Assert(IsSubscript(subscript)) ;
type := GetSType(subscript) ;
- IF NOT q(type)
+ IF NOT q (type)
THEN
result := FALSE
END ;
- type := SkipType(type) ;
+ type := SkipType (type) ;
(* the array might be declared as ARRAY type OF foo *)
low := GetTypeMin(type) ;
high := GetTypeMax(type) ;
@@ -6355,8 +6490,8 @@ BEGIN
THEN
result := FALSE
END ;
- align := GetAlignment(sym) ;
- IF (align#NulSym) AND (NOT q(align))
+ align := GetAlignment (sym) ;
+ IF (align#NulSym) AND (NOT q (align))
THEN
result := FALSE
END
@@ -6371,7 +6506,7 @@ END IsArrayDependants ;
PROCEDURE WalkArrayDependants (sym: CARDINAL; p: WalkAction) ;
VAR
- align : CARDINAL ;
+ align,
subscript: CARDINAL ;
high, low: CARDINAL ;
type : CARDINAL ;
@@ -6385,21 +6520,62 @@ BEGIN
Assert(IsSubscript(subscript)) ;
type := GetSType(subscript) ;
p(type) ;
+ align := GetAlignment (sym) ;
+ IF align#NulSym
+ THEN
+ p(align)
+ END ;
type := SkipType(type) ;
(* the array might be declared as ARRAY type OF foo *)
low := GetTypeMin(type) ;
high := GetTypeMax(type) ;
p(low) ;
- p(high) ;
- align := GetAlignment (sym) ;
- IF align#NulSym
- THEN
- p(align)
- END
+ p(high)
END
END WalkArrayDependants ;
+(*
+ DeclareSetArray -
+*)
+
+PROCEDURE DeclareSetArray (sym, low, high: CARDINAL) : CARDINAL ;
+VAR
+ tok : CARDINAL ;
+ subrange,
+ highbyte: CARDINAL ;
+ bytes : tree ;
+ name : Name ;
+BEGIN
+ tok := GetDeclaredMod (sym) ;
+ PushValue (high) ;
+ ConvertToInt ;
+ PushValue (low) ;
+ ConvertToInt ;
+ Sub ;
+ PushCard (8) ;
+ DivTrunc ;
+ bytes := PopIntegerTree () ;
+ subrange := MakeSubrange (tok, NulName) ;
+ INC (tempset) ;
+ name := makekey (string (Sprintf1 (Mark (InitString('_Tset%d')), tempset))) ;
+ highbyte := MakeConstVar (tok, name) ;
+ PutConst (highbyte, Cardinal) ;
+ AddModGcc (highbyte, bytes) ;
+ PushValue (high) ;
+ ConvertToInt ;
+ PushValue (low) ;
+ ConvertToInt ;
+ Sub ;
+ PushCard (GetBitsPerBitset ()) ;
+ PutSetInWord (sym, Less (tok)) ;
+ DeclareConstFully (highbyte) ;
+ PutSubrange (subrange,
+ MakeConstLit (tok, MakeKey ('0'), Cardinal), highbyte, Cardinal) ;
+ RETURN MakeSetArray (tok, subrange)
+END DeclareSetArray ;
+
+
(*
IsSetDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
@@ -6407,27 +6583,32 @@ END WalkArrayDependants ;
PROCEDURE IsSetDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
- result : BOOLEAN ;
- type, low, high: CARDINAL ;
+ result : BOOLEAN ;
+ type, low, high, array: CARDINAL ;
BEGIN
result := TRUE ;
- Assert(IsSet(sym)) ;
+ Assert (IsSet (sym)) ;
- type := GetDType(sym) ;
- IF NOT q(type)
+ type := GetDType (sym) ;
+ IF NOT q (type)
THEN
result := FALSE
END ;
- low := GetTypeMin(type) ;
- high := GetTypeMax(type) ;
- IF NOT q(low)
+ low := GetTypeMin (type) ;
+ high := GetTypeMax (type) ;
+ IF NOT q (low)
THEN
result := FALSE
END ;
- IF NOT q(high)
+ IF NOT q (high)
THEN
result := FALSE
END ;
+ array := GetSetArray (sym) ;
+ IF array = NulSym
+ THEN
+ result := FALSE ;
+ END ;
RETURN( result )
END IsSetDependants ;
@@ -6438,7 +6619,7 @@ END IsSetDependants ;
PROCEDURE WalkSetDependants (sym: CARDINAL; p: WalkAction) ;
VAR
- type, low, high: CARDINAL ;
+ type, low, high, array: CARDINAL ;
BEGIN
Assert(IsSet(sym)) ;
@@ -6447,7 +6628,12 @@ BEGIN
low := GetTypeMin(type) ;
p(low) ;
high := GetTypeMax(type) ;
- p(high)
+ p(high) ;
+ array := GetSetArray (sym) ;
+ IF array # NulSym
+ THEN
+ p (array)
+ END
END WalkSetDependants ;
@@ -6524,19 +6710,19 @@ VAR
result : BOOLEAN ;
BEGIN
result := TRUE ;
- Assert(IsProcedure(sym)) ;
+ Assert (IsProcedure (sym)) ;
i := 1 ;
- ReturnType := GetSType(sym) ;
- WHILE GetNth(sym, i)#NulSym DO
- son := GetNth(sym, i) ;
- type := GetSType(son) ;
- IF NOT q(type)
+ ReturnType := GetSType (sym) ;
+ WHILE GetNth (sym, i) # NulSym DO
+ son := GetNth (sym, i) ;
+ type := GetSType (son) ;
+ IF NOT q (type)
THEN
result := FALSE
END ;
- INC(i)
+ INC (i)
END ;
- IF (ReturnType=NulSym) OR q(ReturnType)
+ IF (ReturnType = NulSym) OR q (ReturnType)
THEN
RETURN( result )
ELSE
@@ -6555,25 +6741,25 @@ VAR
type,
ReturnType: CARDINAL ;
BEGIN
- Assert(IsProcedure(sym)) ;
+ Assert (IsProcedure (sym)) ;
i := 1 ;
- ReturnType := GetSType(sym) ;
- WHILE GetNth(sym, i)#NulSym DO
- son := GetNth(sym, i) ;
- type := GetSType(son) ;
- p(type) ;
- INC(i)
+ ReturnType := GetSType (sym) ;
+ WHILE GetNth (sym, i) # NulSym DO
+ son := GetNth (sym, i) ;
+ type := GetSType (son) ;
+ p (type) ;
+ INC (i)
END ;
- IF ReturnType#NulSym
+ IF ReturnType # NulSym
THEN
- p(ReturnType)
+ p (ReturnType)
END
END WalkProcedureDependants ;
(*
IsUnboundedDependants - returns TRUE if the symbol, sym,
- q(dependants) all return TRUE.
+ q (dependants) all return TRUE.
*)
PROCEDURE IsUnboundedDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
@@ -6581,15 +6767,15 @@ VAR
result: BOOLEAN ;
BEGIN
result := TRUE ;
- IF NOT q(GetUnboundedRecordType(sym))
+ IF NOT q (GetUnboundedRecordType (sym))
THEN
result := FALSE
END ;
- IF NOT q(Cardinal)
+ IF NOT q (Cardinal)
THEN
result := FALSE
END ;
- IF NOT q(GetSType(sym))
+ IF NOT q (GetSType (sym))
THEN
result := FALSE
END ;
@@ -6603,9 +6789,9 @@ END IsUnboundedDependants ;
PROCEDURE WalkUnboundedDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
- p(GetUnboundedRecordType(sym)) ;
- p(Cardinal) ;
- p(GetSType(sym))
+ p (GetUnboundedRecordType (sym)) ;
+ p (Cardinal) ;
+ p (GetSType (sym))
END WalkUnboundedDependants ;
@@ -6644,15 +6830,15 @@ VAR
align: CARDINAL ;
type : CARDINAL ;
BEGIN
- type := GetSType(sym) ;
- IF type#NulSym
+ type := GetSType (sym) ;
+ IF type # NulSym
THEN
- p(type)
+ p (type)
END ;
- align := GetAlignment(sym) ;
- IF align#NulSym
+ align := GetAlignment (sym) ;
+ IF align # NulSym
THEN
- p(align)
+ p (align)
END
END WalkTypeDependants ;
@@ -6664,9 +6850,9 @@ END WalkTypeDependants ;
PROCEDURE PoisonSymbols (sym: CARDINAL) ;
BEGIN
- IF IsProcedure(sym)
+ IF IsProcedure (sym)
THEN
- ForeachLocalSymDo(sym, Poison)
+ ForeachLocalSymDo (sym, Poison)
END
END PoisonSymbols ;
@@ -6677,7 +6863,7 @@ END PoisonSymbols ;
PROCEDURE ConstantKnownAndUsed (sym: CARDINAL; t: tree) ;
BEGIN
- DeclareConstantFromTree(sym, RememberConstant(t))
+ DeclareConstantFromTree (sym, RememberConstant (t))
END ConstantKnownAndUsed ;
@@ -6692,14 +6878,31 @@ BEGIN
END InitDeclarations ;
+VAR
+ DeclaredOutstandingTypesDiag,
+ DeclareTypesConstantsProceduresDiag,
+ DeclareTypesConstantsProceduresInRangeDiag: Diagnostic ;
BEGIN
+ DeclaredOutstandingTypesDiag
+ := InitTimeDiagnostic
+ ('M2GCCDeclare:DeclaredOutstandingTypes',
+ '{1N} called {1C} times consuming {1T} ({1P})') ;
+ DeclareTypesConstantsProceduresInRangeDiag
+ := InitTimeDiagnostic
+ ('M2GCCDeclare:DeclareTypesConstantsProceduresInRangeDiag',
+ '{1N} called {1C} times consuming {1T} ({1P})') ;
+ DeclareTypesConstantsProceduresDiag
+ := InitTimeDiagnostic
+ ('M2GCCDeclare:DeclareTypesConstantsProceduresDiag',
+ '{1N} called {1C} times consuming {1T} ({1P})') ;
FreeGroup := NIL ;
GlobalGroup := InitGroup () ;
+ ChainedList := InitSet (1) ;
ErrorDepList := InitSet (1) ;
- ChainedList := InitSet(1) ;
- WatchList := InitSet(1) ;
+ WatchList := InitSet (1) ;
VisitedList := NIL ;
- EnumerationIndex := InitIndex(1) ;
+ EnumerationIndex := InitIndex (1) ;
HaveInitDefaultTypes := FALSE ;
- recursionCaught := FALSE
+ recursionCaught := FALSE ;
+ tempset := 0
END M2GCCDeclare.
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 2440b2acf66a..14a4d5d780be 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -35,6 +35,9 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
GetLowestType,
GetLocalSym, GetVarWritten,
GetVarient, GetVarBackEndType, GetModuleCtors,
+ GetSetInWord, GetDType,
+ GetNthParamAnyClosest,
+ GetMainModule, IsUnknown,
NoOfVariables,
NoOfParamAny, GetParent, GetDimension, IsAModula2Type,
IsModule, IsDefImp, IsType, IsModuleWithinProcedure,
@@ -74,16 +77,20 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
GetProcedureBuiltin,
GetPriority, GetNeedSavePriority,
PutConstStringKnown,
+ GetSetArray,
PutConst, PutConstSet, PutConstructor,
GetSType, GetTypeMode,
HasVarParameters, CopyConstString,
GetVarDeclFullTok,
NulSym ;
-FROM M2Batch IMPORT MakeDefinitionSource ;
+FROM m2tree IMPORT debug_tree, skip_const_decl ;
+FROM gcctypes IMPORT location_t, tree ;
+
+FROM M2Batch IMPORT MakeDefinitionSource, LookupModule ;
FROM M2LexBuf IMPORT FindFileNameFromToken, TokenToLineNo, TokenToLocation,
- MakeVirtualTok, UnknownTokenNo, BuiltinTokenNo ;
+ MakeVirtualTok, MakeVirtual2Tok, UnknownTokenNo, BuiltinTokenNo ;
FROM M2Code IMPORT CodeBlock ;
FROM M2Debug IMPORT Assert ;
@@ -96,7 +103,8 @@ FROM M2MetaError IMPORT MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3,
FROM M2Options IMPORT UnboundedByReference, PedanticCast,
VerboseUnbounded, Iso, Pim, DebugBuiltins, WholeProgram,
StrictTypeChecking, AutoInit, cflag, ScaffoldMain,
- ScaffoldDynamic, ScaffoldStatic, GetDebugTraceQuad ;
+ ScaffoldDynamic, ScaffoldStatic, GetDebugTraceQuad,
+ OptimizeSets, GetWideset ;
FROM M2Printf IMPORT printf0, printf1, printf2, printf4 ;
FROM M2Quiet IMPORT qprintf0 ;
@@ -131,6 +139,7 @@ FROM Lists IMPORT List, InitList, KillList,
NoOfItemsInList, GetItemFromList ;
FROM M2ALU IMPORT PtrToValue,
+ KillValue, PopInto,
IsValueTypeReal, IsValueTypeSet,
IsValueTypeConstructor, IsValueTypeArray,
IsValueTypeRecord, IsValueTypeComplex,
@@ -154,7 +163,7 @@ FROM M2GCCDeclare IMPORT WalkAction,
PromoteToString, PromoteToCString, DeclareLocalVariable,
CompletelyResolved,
PoisonSymbols, GetTypeMin, GetTypeMax,
- IsProcedureGccNested, DeclareParameters,
+ IsProcedureGccNested, DeclareParameters, DeclareProcedure,
ConstantKnownAndUsed, PrintSym ;
FROM M2Range IMPORT CodeRangeCheck, FoldRangeCheck, CodeErrorCheck, GetMinMax ;
@@ -164,10 +173,11 @@ FROM m2builtins IMPORT BuiltInAlloca,
GetBuiltinConst, GetBuiltinTypeInfo,
BuiltinExists, BuildBuiltinTree ;
-FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
+FROM m2expr IMPORT GetIntegerZero, GetIntegerOne, GetWordOne,
GetCardinalOne,
GetPointerZero,
GetCardinalZero,
+ GetBitsetZero,
GetSizeOfInBits,
TreeOverflow,
FoldAndStrip,
@@ -175,6 +185,7 @@ FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
StringLength,
AreConstantsEqual,
GetCstInteger,
+ GetRValue,
BuildForeachWordInSetDoIfExpr,
BuildIfConstInVar,
BuildIfVarInVar,
@@ -182,10 +193,10 @@ FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
BuildIfNotVarInVar,
BuildBinCheckProcedure, BuildUnaryCheckProcedure,
BuildBinProcedure, BuildUnaryProcedure,
- BuildSetProcedure, BuildUnarySetFunction,
+ BuildSetProcedure,
BuildAddCheck, BuildSubCheck, BuildMultCheck, BuildDivTruncCheck,
BuildDivM2Check, BuildModM2Check,
- BuildAdd, BuildSub, BuildMult, BuildLSL,
+ BuildAdd, BuildSub, BuildMult, BuildLSL, BuildMask,
BuildDivCeil, BuildModCeil,
BuildDivTrunc, BuildModTrunc, BuildDivFloor, BuildModFloor,
BuildDivM2, BuildModM2,
@@ -202,10 +213,9 @@ FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
BuildEqualTo, BuildNotEqualTo,
BuildIsSuperset, BuildIsNotSuperset,
BuildIsSubset, BuildIsNotSubset,
+ BuildIfInSet, BuildIfNotInSet,
BuildIndirect, BuildArray,
BuildTrunc, BuildCoerce,
- BuildBinaryForeachWordDo,
- BuildBinarySetDo,
BuildSetNegate,
BuildComponentRef,
BuildCap, BuildAbs, BuildIm, BuildRe, BuildCmplx,
@@ -218,10 +228,12 @@ FROM gcctypes IMPORT location_t, tree ;
FROM m2decl IMPORT BuildStringConstant, BuildCStringConstant,
DeclareKnownConstant, GetBitsPerBitset,
BuildIntegerConstant,
- BuildModuleCtor, DeclareModuleCtor ;
+ BuildModuleCtor, DeclareModuleCtor,
+ DeclareKnownVariable ;
FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunctValue,
- DoJump, BuildUnaryForeachWordDo, BuildGoto, BuildCall2, BuildCall3,
+ IfBitInSetJump, IfExprJump,
+ BuildGoto, BuildCall2, BuildCall3,
BuildStart, BuildEnd, BuildCallInner, BuildStartFunctionCode,
BuildEndFunctionCode,
BuildAssignmentTree, DeclareLabel,
@@ -240,6 +252,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct
FROM m2type IMPORT ChainOnParamValue, GetPointerType, GetIntegerType, AddStatement,
GetCardinalType, GetWordType, GetM2ZType, GetM2RType, GetM2CType,
+ GetBooleanFalse,
BuildCharConstant, AddStringToTreeList, BuildArrayStringConstructor,
GetArrayNoOfElements, GetTreeType, IsGccStrictTypeEquivalent ;
@@ -250,7 +263,8 @@ FROM m2block IMPORT RememberConstant, pushGlobalScope, popGlobalScope, finishFun
FROM m2misc IMPORT DebugTree ;
-FROM m2convert IMPORT BuildConvert, ConvertConstantAndCheck, ToCardinal, ConvertString ;
+FROM m2convert IMPORT BuildConvert, ConvertConstantAndCheck, ToCardinal,
+ ToBitset, ToWord, ConvertString ;
FROM m2except IMPORT BuildThrow, BuildTryBegin, BuildTryEnd,
BuildCatchBegin, BuildCatchEnd ;
@@ -278,19 +292,24 @@ CONST
CascadedDebugging = FALSE ;
TYPE
- DoProcedure = PROCEDURE (CARDINAL) ;
- DoUnaryProcedure = PROCEDURE (CARDINAL) ;
+ UnaryProcedure = PROCEDURE (CARDINAL) ;
+ ProcedureCardinal = PROCEDURE (CARDINAL) ;
+ BinaryFunction = PROCEDURE (location_t, tree, tree) : tree ;
+ UnaryFunction = PROCEDURE (location_t, tree) : tree ;
VAR
Memset, Memcpy : CARDINAL ;
CurrentQuadToken : CARDINAL ;
UnboundedLabelNo : CARDINAL ;
- LastLine : CARDINAL ;(* The Last Line number emitted with the *)
- (* generated code. *)
+ LastLine : CARDINAL ; (* The Last Line number emitted with *)
+ (* the generated code. *)
LastOperator : QuadOperator ; (* The last operator processed. *)
- ScopeStack : StackOfWord ; (* keeps track of the current scope *)
- (* under translation. *)
- NoChange : BOOLEAN ; (* has any constant been resolved? *)
+ ScopeStack : StackOfWord ; (* keeps track of the current scope *)
+ (* under translation. *)
+ NoChange : BOOLEAN ; (* has any constant been resolved? *)
+ SetTemporaryNo : CARDINAL ; (* A unique number for creating set *)
+ (* oarecord parameter names. *)
+ BreakQuad : CARDINAL ; (* Allows interactive debugging. *)
(*
@@ -613,6 +632,7 @@ VAR
BEGIN
InitBuiltinSyms (BuiltinTokenNo) ;
GetQuad(q, op, op1, op2, op3) ;
+ CheckBreak (q) ;
IF op=StatementNoteOp
THEN
FoldStatementNote (op3) (* Will change CurrentQuadToken using op3. *)
@@ -663,12 +683,12 @@ BEGIN
DivFloorOp : CodeDivFloor (q, op2, op3) |
ModFloorOp : CodeModFloor (q, op2, op3) |
GotoOp : CodeGoto (op3) |
- InclOp : CodeIncl (op1, op3) |
- ExclOp : CodeExcl (op1, op3) |
- NegateOp : CodeNegateChecked (q, op1, op3) |
+ InclOp : CodeIncl (q) |
+ ExclOp : CodeExcl (q) |
+ NegateOp : CodeNegateChecked (q) |
LastForIteratorOp : CodeLastForIterator (q) |
- LogicalShiftOp : CodeSetShift (q, op1, op2, op3) |
- LogicalRotateOp : CodeSetRotate (q, op1, op2, op3) |
+ LogicalShiftOp : CodeSetShift (q) |
+ LogicalRotateOp : CodeSetRotate (q) |
LogicalOrOp : CodeSetOr (q) |
LogicalAndOp : CodeSetAnd (q) |
LogicalXorOp : CodeSetSymmetricDifference (q) |
@@ -923,7 +943,7 @@ BEGIN
END
ELSE
MetaErrorT1 (tok,
- 'a constraint to the GNU ASM statement must be a constant string and not a {%1Ed}',
+ 'a constraint to the GNU ASM statement must be a constant string and not a {%1Edv}',
str)
END
END ;
@@ -966,7 +986,7 @@ BEGIN
END
ELSE
MetaErrorT1 (tok,
- 'a constraint to the GNU ASM statement must be a constant string and not a {%1Ed}',
+ 'a constraint to the GNU ASM statement must be a constant string and not a {%1Edv}',
str)
END
END ;
@@ -1114,6 +1134,20 @@ BEGIN
END PopScope ;
+(*
+ GetActiveScope -
+*)
+
+PROCEDURE GetActiveScope () : CARDINAL ;
+BEGIN
+ IF IsEmptyWord (ScopeStack)
+ THEN
+ InternalError ('not expecting scope stack to be empty')
+ END ;
+ RETURN PeepWord (ScopeStack, 1)
+END GetActiveScope ;
+
+
(*
GetCurrentScopeDescription - returns a description of the current scope.
*)
@@ -1671,9 +1705,9 @@ BEGIN
goto tLabel
fi
*)
- DoJump(location, BuildGreaterThan(location, ta, td), NIL, string(fLabel)) ;
- DoJump(location, BuildLessThan(location, tb, tc), NIL, string(fLabel)) ;
- BuildGoto(location, string(tLabel)) ;
+ IfExprJump (location, BuildGreaterThan (location, ta, td), string (fLabel)) ;
+ IfExprJump (location, BuildLessThan (location, tb, tc), string (fLabel)) ;
+ BuildGoto (location, string (tLabel)) ;
IF CascadedDebugging
THEN
printf1('label used %s\n', tLabel) ;
@@ -1752,15 +1786,7 @@ BEGIN
END ;
DeclareLabel(location, string(fLabel)) ;
INC(j)
- END ;
-(*
- nLabel := CreateLabelProcedureN(proc, "fin", UnboundedLabelNo, n+1) ;
- IF CascadedDebugging
- THEN
- printf1('label declared %s\n', nLabel)
- END ;
- DeclareLabel(location, string(nLabel))
-*)
+ END
END
END BuildCascadedIfThenElsif ;
@@ -2548,7 +2574,7 @@ END FoldMakeAdr ;
procedure, op2. The number of the parameter is op1.
*)
-PROCEDURE doParam (quad: CARDINAL; paramtok: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE doParam (paramtok: CARDINAL; quad: CARDINAL; op1, op2, op3: CARDINAL) ;
VAR
location: location_t ;
BEGIN
@@ -2706,7 +2732,7 @@ BEGIN
parameter, procedure)
ELSIF compatible
THEN
- doParam (quad, parampos, nth, procedure, parameter)
+ doParam (parampos, quad, nth, procedure, parameter)
END
END
END CodeParam ;
@@ -2884,17 +2910,6 @@ BEGIN
END CodeAddr ;
-PROCEDURE stop ; BEGIN END stop ;
-
-PROCEDURE CheckStop (q: CARDINAL) ;
-BEGIN
- IF q=3827
- THEN
- stop
- END
-END CheckStop ;
-
-
(*
------------------------------------------------------------------------------
:= Operator
@@ -2906,6 +2921,7 @@ PROCEDURE FoldBecomes (p: WalkAction; bb: BasicBlock; quad: CARDINAL) ;
BEGIN
IF DeclaredOperandsBecomes (p, quad)
THEN
+ CheckBreak (quad) ;
IF (NOT IsConditionalBooleanQuad (quad)) OR IsBasicBlockFirst (bb)
THEN
IF TypeCheckBecomes (p, quad)
@@ -3484,9 +3500,15 @@ END checkBecomes ;
PROCEDURE checkDeclare (sym: CARDINAL) ;
BEGIN
- IF IsTemporary (sym) AND IsVariableSSA (sym) AND (NOT GccKnowsAbout (sym))
+ IF (sym # NulSym) AND (NOT GccKnowsAbout (sym))
THEN
- DeclareLocalVariable (sym)
+ IF IsTemporary (sym) AND IsVariableSSA (sym)
+ THEN
+ DeclareLocalVariable (sym)
+ ELSIF IsProcedure (sym)
+ THEN
+ DeclareProcedure (sym)
+ END
END
END checkDeclare ;
@@ -3602,6 +3624,17 @@ BEGIN
END CodeBecomes ;
+(*
+ getrvalue -
+*)
+
+PROCEDURE getrvalue (location: location_t;
+ expr, type: CARDINAL; islvalue: BOOLEAN) : tree ;
+BEGIN
+ RETURN GetRValue (location, Mod2Gcc (expr), Mod2Gcc (type), islvalue)
+END getrvalue ;
+
+
(*
LValueToGenericPtr - returns a Tree representing symbol, sym.
It coerces a lvalue into an internal pointer type
@@ -3989,7 +4022,7 @@ BEGIN
IF (righttype = NulSym) OR (NOT IsSet (SkipType (righttype)))
THEN
MetaErrorT1 (rightpos,
- 'an {%kIN} expression is expecting {%1Etad} to be a {%kSET} type',
+ 'the right hand side of an {%kIN} expression is expecting {%1Ead} to be a {%kSET} type and not a {%1Etadv}',
right) ;
NoChange := FALSE ;
SubQuad (quad) ;
@@ -4000,72 +4033,259 @@ END CheckElementSetTypes ;
(*
- CodeBinarySet - encode a binary set arithmetic operation.
+ CodeBinarySet - encode a binary set AND arithmetic operation.
Set operands may be longer than a word.
*)
-PROCEDURE CodeBinarySet (binop: BuildBinProcedure; doOp: DoProcedure;
+PROCEDURE CodeBinarySet (constp: ProcedureCardinal;
+ binfunc: BinaryFunction;
+ wideprocname: Name;
quad: CARDINAL) ;
VAR
- location : location_t ;
- constExpr,
- overflowChecking: BOOLEAN ;
op : QuadOperator ;
- virttoken,
- virtexpr,
- des,
- left,
- right,
+ operatorpos,
+ combinedpos,
despos,
leftpos,
- rightpos,
- operatorpos : CARDINAL ;
+ rightpos : CARDINAL ;
+ des, left, right: CARDINAL ;
+ overflowChecking,
+ typeChecking,
+ constExpr : BOOLEAN ;
+ location : location_t ;
+ settype : CARDINAL ;
BEGIN
- GetQuadOtok (quad, operatorpos, op, des, left, right,
- overflowChecking, constExpr,
- despos, leftpos, rightpos) ;
-
+ GetQuadOTypetok (quad, operatorpos, op,
+ des, left, right,
+ overflowChecking, typeChecking, constExpr,
+ despos, leftpos, rightpos) ;
(* Firstly ensure that constant literals are declared. *)
DeclareConstant (rightpos, right) ;
DeclareConstant (leftpos, left) ;
DeclareConstructor (rightpos, quad, right) ;
DeclareConstructor (leftpos, quad, left) ;
-
- virttoken := MakeVirtualTok (operatorpos, despos, rightpos) ;
- location := TokenToLocation (virttoken) ;
- IF CheckBinaryExpressionTypes (quad, NoWalkProcedure)
+ IF IsConst (des)
THEN
- IF IsConst (des)
+ combinedpos := MakeVirtual2Tok (leftpos, rightpos) ;
+ IF IsValueSolved (left) AND IsValueSolved (right)
THEN
- virtexpr := MakeVirtualTok (operatorpos, leftpos, rightpos) ;
- IF IsValueSolved (left) AND IsValueSolved (right)
- THEN
- Assert (MixTypes (FindType (right), FindType (left), virtexpr) # NulSym) ;
- PutConst (des, FindType (right)) ;
- PushValue (left) ;
- PushValue (right) ;
- doOp (virttoken) ;
- PopValue (des) ;
- PutConstSet (des)
- ELSE
- MetaErrorT0 (virtexpr, '{%E}constant expression cannot be evaluated')
- END
+ Assert (MixTypes (FindType (left), FindType (right), combinedpos) # NulSym) ;
+ PutConst (des, FindType (right)) ;
+ PushValue (left) ;
+ PushValue (right) ;
+ constp (combinedpos) ;
+ PopValue (des) ;
+ PutConstSet (des)
ELSE
- checkDeclare (des) ;
- BuildBinaryForeachWordDo (location,
- Mod2Gcc (SkipType (GetType (des))),
- Mod2Gcc (des), Mod2Gcc (left), Mod2Gcc (right), binop,
- GetMode (des) = LeftValue,
- GetMode (left) = LeftValue,
- GetMode (right) = LeftValue,
- IsConst (des),
- IsConst (left),
- IsConst (right))
+ MetaErrorT0 (combinedpos, '{%E}constant expression cannot be evaluated')
+ END
+ ELSE
+ checkDeclare (des) ;
+ settype := GetLType (des) ;
+ Assert (IsSet (settype)) ;
+ combinedpos := MakeVirtualTok (despos, leftpos, rightpos) ;
+ IF GetSetInWord (settype)
+ THEN
+ location := TokenToLocation (combinedpos) ;
+ SetNarrowBinary (location, binfunc, settype, des, left, right)
+ ELSE
+ SetWideBinary (combinedpos, wideprocname, settype, des, left, right)
END
END
END CodeBinarySet ;
+(*
+ MakeTemporarySetName - returns a Name using the template _Tset%d.
+*)
+
+PROCEDURE MakeTemporarySetName () : Name ;
+VAR
+ name: Name ;
+ s : String ;
+BEGIN
+ INC (SetTemporaryNo) ;
+ s := Sprintf1 (Mark (InitString ('_Tset%d')), SetTemporaryNo) ;
+ name := makekey (string (s)) ;
+ s := KillString (s) ;
+ RETURN name
+END MakeTemporarySetName ;
+
+
+(*
+ SetWideBinary -
+*)
+
+PROCEDURE SetWideBinary (tokenno: CARDINAL;
+ wideprocname: Name;
+ settype, des, left, right: CARDINAL) ;
+BEGIN
+ IF OptimizeSets
+ THEN
+ IF wideprocname = MakeKey ('And')
+ THEN
+ SetWideBinaryBuiltin (tokenno, BuildLogicalAnd, des, left, right) ;
+ RETURN
+ ELSIF wideprocname = MakeKey ('Or')
+ THEN
+ SetWideBinaryBuiltin (tokenno, BuildLogicalOr, des, left, right) ;
+ RETURN
+ END
+ END ;
+ SetWideBinaryLibrary (tokenno, wideprocname, settype, des, left, right)
+END SetWideBinary ;
+
+
+(*
+ SetWideBinaryLibrary - call wideprocname (des, left, right) passing des, left, right
+ as an array of byte.
+*)
+
+PROCEDURE SetWideBinaryLibrary (tokenno: CARDINAL;
+ wideprocname: Name;
+ settype, des, left, right: CARDINAL) ;
+VAR
+ location : location_t ;
+ procedure,
+ param1,
+ param2,
+ param3 : CARDINAL ;
+ highbit,
+ array1,
+ array2,
+ array3,
+ call : tree ;
+BEGIN
+ procedure := FromM2WIDESETImport (tokenno, wideprocname) ;
+ checkDeclare (procedure) ;
+ location := TokenToLocation (tokenno) ;
+ param1 := GetNthParamAnyClosest (procedure, 1, GetMainModule ()) ;
+ param2 := GetNthParamAnyClosest (procedure, 2, GetMainModule ()) ;
+ param3 := GetNthParamAnyClosest (procedure, 3, GetMainModule ()) ;
+ array1 := CreateSetArrayParam (location, tokenno, des, param1) ;
+ array2 := CreateSetArrayParam (location, tokenno, left, param2) ;
+ array3 := CreateSetArrayParam (location, tokenno, right, param3) ;
+ highbit := ToCardinal (location, CalcHighSetBit (location, settype)) ;
+ BuildParam (location, highbit) ; (* Parameter 4. *)
+ BuildParam (location, array3) ; (* Parameter 3. *)
+ BuildParam (location, array2) ; (* Parameter 2. *)
+ BuildParam (location, array1) ; (* Parameter 1. *)
+ call := BuildProcedureCallTree (location, Mod2Gcc (procedure), NIL) ;
+ SetLastFunction (NIL) ;
+ AddStatement (location, call)
+END SetWideBinaryLibrary ;
+
+
+(*
+ SetWideBinaryBuiltin - build an builtin wideset NOT operation.
+*)
+
+PROCEDURE SetWideBinaryBuiltin (tokenno: CARDINAL;
+ binfunc: BinaryFunction;
+ des, left, right: CARDINAL) ;
+VAR
+ location : location_t ;
+ byte,
+ lhs, rhs,
+ dest,
+ index,
+ high : tree ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ high := ResolveHigh (tokenno, 1, des) ;
+ index := GetIntegerZero (location) ;
+ byte := Mod2Gcc (Byte) ;
+ REPEAT
+ rhs := BuildArray (location, byte,
+ getrvalue (location, right, GetType (right),
+ GetMode (right) = LeftValue),
+ index, GetIntegerZero (location)) ;
+ lhs := BuildArray (location, byte,
+ getrvalue (location, left, GetType (left),
+ GetMode (left) = LeftValue),
+ index, GetIntegerZero (location)) ;
+ rhs := binfunc (location, lhs, rhs) ;
+ rhs := BuildConvert (location, byte, rhs, FALSE) ;
+ dest := BuildArray (location, byte,
+ getrvalue (location, des, GetType (des),
+ GetMode (des) = LeftValue),
+ index, GetIntegerZero (location)) ;
+ BuildAssignmentStatement (location, dest, rhs) ;
+ PushIntegerTree (index) ;
+ PushCard (1) ;
+ Addn ;
+ index := PopIntegerTree ()
+ UNTIL CompareTrees (index, high) > 0
+END SetWideBinaryBuiltin ;
+
+
+(*
+ SetNarrowBinary - create tree consisting of:
+ result := binfunc (left, right)
+ result, left and right can be lvalues.
+*)
+
+PROCEDURE SetNarrowBinary (location: location_t; binfunc: BinaryFunction;
+ settype, result, left, right: CARDINAL) ;
+VAR
+ isResultL,
+ isLeftL,
+ isRightL : BOOLEAN ;
+BEGIN
+ isResultL := GetMode (result) = LeftValue ;
+ isLeftL := GetMode (left) = LeftValue ;
+ isRightL := GetMode (right) = LeftValue ;
+ BuildAssignmentStatement (location,
+ getrvalue (location, result, settype, isResultL),
+ binfunc (location,
+ getrvalue (location, left, settype, isLeftL),
+ getrvalue (location, right, settype, isRightL)))
+END SetNarrowBinary ;
+
+
+(*
+ CreateSetArrayParam - return a gcc tree containing value contained in an unbounded
+ array parameter.
+*)
+
+PROCEDURE CreateSetArrayParam (location: location_t; tokenno: CARDINAL;
+ value, param: CARDINAL) : tree ;
+VAR
+ dataAddress,
+ designator,
+ oarecord : tree ;
+ unbounded,
+ HighField,
+ scope : CARDINAL ;
+BEGIN
+ unbounded := GetType (param) ;
+ Assert (IsUnbounded (unbounded)) ;
+ scope := GetActiveScope () ;
+ (* Declare oarecord which has a pointer and high field. This will be passed as
+ a parameter into the runtime set procedure and appear as an ARRAY OF BYTE. *)
+ oarecord := DeclareKnownVariable (location, KeyToCharStar (MakeTemporarySetName ()),
+ Mod2Gcc (unbounded),
+ FALSE, FALSE, TRUE, IsProcedure (scope),
+ Mod2Gcc (scope), NIL) ;
+ (* Designator is oarecord.address. *)
+ designator := BuildComponentRef (location, oarecord,
+ Mod2Gcc (GetUnboundedAddressOffset (unbounded))) ;
+ IF GetMode (value) = LeftValue
+ THEN
+ (* Already pointing to the data. *)
+ dataAddress := Mod2Gcc (value)
+ ELSE
+ dataAddress := BuildAddr (location, Mod2Gcc (value), FALSE)
+ END ;
+ BuildAssignmentStatement (location, designator, dataAddress) ;
+ HighField := GetUnboundedHighOffset (unbounded, 1) ;
+ designator := BuildComponentRef (location, oarecord, Mod2Gcc (HighField)) ;
+ BuildAssignmentStatement (location, designator,
+ ResolveHigh (tokenno, 1, value)) ;
+ RETURN oarecord
+END CreateSetArrayParam ;
+
+
(*
CheckUnaryOperand - checks to see whether operand is using a generic type.
*)
@@ -4367,7 +4587,7 @@ PROCEDURE FoldMult (tokenno: CARDINAL; p: WalkAction;
BEGIN
IF BinaryOperands (quad, op2, op3)
THEN
- FoldBinary(tokenno, p, BuildMult, quad, op1, op2, op3)
+ FoldBinary (tokenno, p, BuildMult, quad, op1, op2, op3)
END
END FoldMult ;
@@ -4478,11 +4698,11 @@ END CodeModM2Check ;
PROCEDURE BinaryOperandRealFamily (op: CARDINAL) : BOOLEAN ;
VAR
- t: CARDINAL ;
+ type: CARDINAL ;
BEGIN
- t := SkipType(GetType(op)) ;
- RETURN( IsComplexType(t) OR IsComplexN(t) OR
- IsRealType(t) OR IsRealN(t) )
+ type := GetDType (op) ;
+ RETURN( IsComplexType (type) OR IsComplexN (type) OR
+ IsRealType (type) OR IsRealN (type) )
END BinaryOperandRealFamily ;
@@ -4596,7 +4816,7 @@ PROCEDURE FoldModTrunc (tokenno: CARDINAL; p: WalkAction;
BEGIN
IF BinaryOperands (quad, op2, op3)
THEN
- FoldBinary(tokenno, p, BuildModTrunc, quad, op1, op2, op3)
+ FoldBinary (tokenno, p, BuildModTrunc, quad, op1, op2, op3)
END
END FoldModTrunc ;
@@ -4802,15 +5022,27 @@ PROCEDURE FoldTBitsize (tokenno: CARDINAL; p: WalkAction;
VAR
location: location_t ;
BEGIN
- location := TokenToLocation(tokenno) ;
- TryDeclareType (type) ;
- type := GetDType (type) ;
- IF CompletelyResolved (type)
+ location := TokenToLocation (tokenno) ;
+ IF IsType (type) OR IsVar (type) OR IsConst (type)
THEN
- AddModGcc (res, BuildSystemTBitSize (location, Mod2Gcc (type))) ;
- p (res) ;
- NoChange := FALSE ;
- SubQuad (quad)
+ IF GetDType (type) = NulSym
+ THEN
+ MetaErrorT1 (tokenno, 'unknown type in TBITSIZE parameter {%1Ead}', type) ;
+ NoChange := FALSE ;
+ SubQuad (quad)
+ END ;
+ type := GetDType (type)
+ END ;
+ IF type # NulSym
+ THEN
+ TryDeclareType (type) ;
+ IF CompletelyResolved (type)
+ THEN
+ AddModGcc (res, BuildSystemTBitSize (location, Mod2Gcc (type))) ;
+ p (res) ;
+ NoChange := FALSE ;
+ SubQuad (quad)
+ END
END
END FoldTBitsize ;
@@ -5130,41 +5362,41 @@ END CodeRestorePriority ;
FoldBinarySet - attempts to fold set arithmetic it removes the quad if successful.
*)
-PROCEDURE FoldBinarySet (tokenno: CARDINAL; p: WalkAction; op: DoProcedure;
+PROCEDURE FoldBinarySet (tokenno: CARDINAL; p: WalkAction; op: ProcedureCardinal;
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
VAR
location: location_t ;
BEGIN
(* firstly try and ensure that constants are declared *)
- TryDeclareConstant(tokenno, op2) ;
- TryDeclareConstant(tokenno, op3) ;
- location := TokenToLocation(tokenno) ;
+ TryDeclareConstant (tokenno, op2) ;
+ TryDeclareConstant (tokenno, op3) ;
+ location := TokenToLocation (tokenno) ;
- IF GccKnowsAbout(op2) AND GccKnowsAbout(op3)
+ IF GccKnowsAbout (op2) AND GccKnowsAbout (op3)
THEN
IF CheckBinaryExpressionTypes (quad, p)
THEN
- IF IsConst(op2) AND IsConstSet(op2) AND
- IsConst(op3) AND IsConstSet(op3) AND
- IsConst(op1)
+ IF IsConst (op2) AND IsConstSet (op2) AND
+ IsConst (op3) AND IsConstSet (op3) AND
+ IsConst (op1)
THEN
- IF IsValueSolved(op2) AND IsValueSolved(op3)
+ IF IsValueSolved (op2) AND IsValueSolved (op3)
THEN
- Assert(MixTypes(FindType(op3), FindType(op2), tokenno)#NulSym) ;
- PutConst(op1, MixTypes(FindType(op3), FindType(op2), tokenno)) ;
- PushValue(op2) ;
- PushValue(op3) ;
- op(tokenno) ;
- PopValue(op1) ;
- PushValue(op1) ;
- PutConstSet(op1) ;
- AddModGcc(op1,
- DeclareKnownConstant(location,
- Mod2Gcc(GetType(op3)),
- PopSetTree(tokenno))) ;
- p(op1) ;
+ Assert (MixTypes (FindType (op3), FindType (op2), tokenno) # NulSym) ;
+ PutConst (op1, MixTypes (FindType (op3), FindType (op2), tokenno)) ;
+ PushValue (op2) ;
+ PushValue (op3) ;
+ op (tokenno) ;
+ PopValue (op1) ;
+ PushValue (op1) ;
+ PutConstSet (op1) ;
+ AddModGcc (op1,
+ DeclareKnownConstant (location,
+ Mod2Gcc (GetType (op3)),
+ PopSetTree (tokenno))) ;
+ p (op1) ;
NoChange := FALSE ;
- SubQuad(quad)
+ SubQuad (quad)
END
END
END
@@ -5189,7 +5421,7 @@ END FoldSetOr ;
PROCEDURE CodeSetOr (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalOr, SetOr, quad)
+ CodeBinarySet (SetOr, BuildLogicalOr, MakeKey ("Or"), quad)
END CodeSetOr ;
@@ -5200,7 +5432,7 @@ END CodeSetOr ;
PROCEDURE FoldSetAnd (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; op1, op2, op3: CARDINAL) ;
BEGIN
- FoldBinarySet(tokenno, p, SetAnd, quad, op1, op2, op3)
+ FoldBinarySet (tokenno, p, SetAnd, quad, op1, op2, op3)
END FoldSetAnd ;
@@ -5210,85 +5442,175 @@ END FoldSetAnd ;
PROCEDURE CodeSetAnd (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalAnd, SetAnd, quad)
+ CodeBinarySet (SetAnd, BuildLogicalAnd, MakeKey ("And"), quad)
END CodeSetAnd ;
(*
- CodeBinarySetShift - encode a binary set arithmetic operation.
- The set maybe larger than a machine word
- and the value of one word may effect the
- values of another - ie shift and rotate.
- Set sizes of a word or less are evaluated
- with binop, whereas multiword sets are
- evaluated by M2RTS.
+ CalcHighSetBit - calculate the most significant bit used in a set starting from bit zero.
+*)
+
+PROCEDURE CalcHighSetBit (location: location_t; settype: CARDINAL) : tree ;
+BEGIN
+ PushValue (GetTypeMax (SkipType (GetType (settype)))) ;
+ PushIntegerTree (BuildConvert (location, GetM2ZType (), PopIntegerTree (), FALSE)) ;
+ PushValue (GetTypeMin (SkipType (GetType (settype)))) ;
+ PushIntegerTree (BuildConvert (location, GetM2ZType (), PopIntegerTree (), FALSE)) ;
+ Sub ;
+ RETURN PopIntegerTree ()
+END CalcHighSetBit ;
+
+
+(*
+ CalcBitsInSet - returns the number of minimum number of bits used to represent a set.
+*)
+
+PROCEDURE CalcBitsInSet (location: location_t; settype: CARDINAL) : tree ;
+BEGIN
+ PushIntegerTree (BuildConvert (location, GetM2ZType (),
+ CalcHighSetBit (location, settype), FALSE)) ;
+ PushCard (1) ;
+ PushIntegerTree (BuildConvert (location, GetM2ZType (), PopIntegerTree (), FALSE)) ;
+ Addn ;
+ RETURN PopIntegerTree ()
+END CalcBitsInSet ;
+
+
+(*
+ SetWideSetShiftRotate - generate a call:
+ M2WIDESET.name (dest, src, HIGHBIT (settype), count).
*)
-PROCEDURE CodeBinarySetShift (binop: BuildSetProcedure;
- doOp : DoProcedure;
- var, left, right: Name;
- quad: CARDINAL;
- op1, op2, op3: CARDINAL) ;
+PROCEDURE SetWideSetShiftRotate (tokenno: CARDINAL; name: Name;
+ settype, dest, src, count: CARDINAL) ;
VAR
- nBits,
- unbounded,
- leftproc,
- rightproc,
- varproc : tree ;
+ procedure,
+ param1,
+ param2 : CARDINAL ;
+ array1,
+ array2,
+ call,
+ highbit : tree ;
location : location_t ;
BEGIN
- (* firstly ensure that constant literals are declared *)
- DeclareConstant(CurrentQuadToken, op3) ;
- DeclareConstant(CurrentQuadToken, op2) ;
- DeclareConstructor(CurrentQuadToken, quad, op3) ;
- DeclareConstructor(CurrentQuadToken, quad, op2) ;
- location := TokenToLocation(CurrentQuadToken) ;
+ procedure := FromM2WIDESETImport (tokenno, name) ;
+ location := TokenToLocation (tokenno) ;
+ param1 := GetNthParamAnyClosest (procedure, 1, GetMainModule ()) ;
+ param2 := GetNthParamAnyClosest (procedure, 2, GetMainModule ()) ;
+ array1 := CreateSetArrayParam (location, tokenno, dest, param1) ;
+ array2 := CreateSetArrayParam (location, tokenno, src, param2) ;
+ highbit := CalcHighSetBit (location, settype) ;
+ BuildParam (location, ToCardinal (location, Mod2Gcc (count))) ; (* Parameter 4. *)
+ BuildParam (location, ToCardinal (location, highbit)) ; (* Parameter 3. *)
+ BuildParam (location, array2) ; (* Parameter 2. *)
+ BuildParam (location, array1) ; (* Parameter 1. *)
+ call := BuildProcedureCallTree (location, Mod2Gcc (procedure), NIL) ;
+ SetLastFunction (NIL) ;
+ AddStatement (location, call)
+END SetWideSetShiftRotate ;
- IF IsConst(op1)
- THEN
- IF IsValueSolved(op2) AND IsValueSolved(op3)
- THEN
- Assert(MixTypes(FindType(op3),
- FindType(op2), CurrentQuadToken)#NulSym) ;
- PutConst(op1, FindType(op3)) ;
- PushValue(op2) ;
- PushValue(op3) ;
- doOp(CurrentQuadToken) ;
- PopValue(op1) ;
- PutConstSet(op1)
+
+(*
+ CodeNarrowSetShift -
+*)
+
+PROCEDURE CodeNarrowSetShift (tokenno: CARDINAL; settype: CARDINAL;
+ dest, src, count: CARDINAL) ;
+VAR
+ location: location_t ;
+ nbits : tree ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ nbits := CalcBitsInSet (location, settype) ;
+ BuildLogicalShift (location, Mod2Gcc (dest), Mod2Gcc (src), Mod2Gcc (count), nbits, FALSE)
+END CodeNarrowSetShift ;
+
+
+(*
+ CodeNarrowSetRotate -
+*)
+
+PROCEDURE CodeNarrowSetRotate (tokenno: CARDINAL; settype: CARDINAL;
+ dest, src, count: CARDINAL) ;
+VAR
+ location: location_t ;
+ nbits : tree ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ nbits := CalcBitsInSet (location, settype) ;
+ BuildLogicalRotate (location, Mod2Gcc (dest), Mod2Gcc (src), Mod2Gcc (count), nbits, FALSE)
+END CodeNarrowSetRotate ;
+
+
+(*
+ CodeBinarySetShiftRotate - encode a binary set arithmetic operation.
+*)
+
+PROCEDURE CodeBinarySetShiftRotate (quad: CARDINAL; isshift: BOOLEAN) ;
+VAR
+ op : QuadOperator ;
+ combined,
+ lastpos, destpos,
+ srcpos, countpos: CARDINAL ;
+ dest, src, count: CARDINAL ;
+ overflowChecking,
+ constExpr : BOOLEAN ;
+ settype : CARDINAL ;
+BEGIN
+ GetQuadOtok (quad, lastpos, op, dest, src, count,
+ overflowChecking, constExpr,
+ destpos, srcpos, countpos) ;
+
+ (* Firstly ensure that constant literals are declared. *)
+ DeclareConstant (countpos, count) ;
+ DeclareConstant (srcpos, src) ;
+ DeclareConstructor (countpos, quad, count) ;
+ DeclareConstructor (srcpos, quad, src) ;
+
+ IF IsConst (dest)
+ THEN
+ combined := MakeVirtual2Tok (srcpos, countpos) ;
+ IF IsValueSolved (src) AND IsValueSolved (count)
+ THEN
+ Assert (MixTypes (FindType (count),
+ FindType (src), combined) # NulSym) ;
+ PutConst (dest, FindType (count)) ;
+ PushValue (src) ;
+ PushValue (count) ;
+ IF isshift
+ THEN
+ SetShift (combined)
+ ELSE
+ SetRotate (combined)
+ END ;
+ PopValue (dest) ;
+ PutConstSet (dest)
ELSE
- MetaErrorT0 (CurrentQuadToken, '{%E}constant expression cannot be evaluated')
+ MetaErrorT0 (combined, '{%E}constant expression cannot be evaluated')
END
ELSE
- varproc := Mod2Gcc(FromModuleGetSym(CurrentQuadToken, var, System)) ;
- leftproc := Mod2Gcc(FromModuleGetSym(CurrentQuadToken, left, System)) ;
- rightproc := Mod2Gcc(FromModuleGetSym(CurrentQuadToken, right, System)) ;
- unbounded := Mod2Gcc(GetType(GetNthParamAny (FromModuleGetSym(CurrentQuadToken,
- var, System), 1))) ;
- PushValue(GetTypeMax(SkipType(GetType(op1)))) ;
- PushIntegerTree(BuildConvert(location, GetM2ZType(), PopIntegerTree(), FALSE)) ;
-
- PushValue(GetTypeMin(SkipType(GetType(op1)))) ;
- PushIntegerTree(BuildConvert(location, GetM2ZType(), PopIntegerTree(), FALSE)) ;
- Sub ;
- PushCard(1) ;
- PushIntegerTree(BuildConvert(location, GetM2ZType(), PopIntegerTree(), FALSE)) ;
- Addn ;
- nBits := PopIntegerTree() ;
- BuildBinarySetDo(location,
- Mod2Gcc(SkipType(GetType(op1))),
- Mod2Gcc(op1),
- Mod2Gcc(op2),
- Mod2Gcc(op3),
- binop,
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- GetMode(op3)=LeftValue,
- nBits,
- unbounded,
- varproc, leftproc, rightproc)
+ combined := MakeVirtualTok (destpos, srcpos, countpos) ;
+ settype := GetDType (dest) ;
+ Assert (IsSet (settype)) ;
+ (* Check for narrow and wide sets and call M2WIDESET if appropriate. *)
+ IF GetSetInWord (settype)
+ THEN
+ IF isshift
+ THEN
+ CodeNarrowSetShift (combined, settype, dest, src, count)
+ ELSE
+ CodeNarrowSetRotate (combined, settype, dest, src, count)
+ END
+ ELSE
+ IF isshift
+ THEN
+ SetWideSetShiftRotate (combined, MakeKey ('Shift'), settype, dest, src, count)
+ ELSE
+ SetWideSetShiftRotate (combined, MakeKey ('Rotate'), settype, dest, src, count)
+ END
+ END
END
-END CodeBinarySetShift ;
+END CodeBinarySetShiftRotate ;
(*
@@ -5296,9 +5618,9 @@ END CodeBinarySetShift ;
*)
PROCEDURE FoldSetShift (tokenno: CARDINAL; p: WalkAction;
- quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+ quad: CARDINAL; Dest, Src, ShiftCount: CARDINAL) ;
BEGIN
- FoldBinarySet(tokenno, p, SetShift, quad, op1, op2, op3)
+ FoldBinarySet (tokenno, p, SetShift, quad, Dest, Src, ShiftCount)
END FoldSetShift ;
@@ -5306,14 +5628,9 @@ END FoldSetShift ;
CodeSetShift - encode set arithmetic shift.
*)
-PROCEDURE CodeSetShift (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetShift (quad: CARDINAL) ;
BEGIN
- CodeBinarySetShift (BuildLogicalShift,
- SetShift,
- MakeKey('ShiftVal'),
- MakeKey('ShiftLeft'),
- MakeKey('ShiftRight'),
- quad, op1, op2, op3)
+ CodeBinarySetShiftRotate (quad, TRUE)
END CodeSetShift ;
@@ -5322,9 +5639,9 @@ END CodeSetShift ;
*)
PROCEDURE FoldSetRotate (tokenno: CARDINAL; p: WalkAction;
- quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+ quad: CARDINAL; Dest, Src, RotateCount: CARDINAL) ;
BEGIN
- FoldBinarySet(tokenno, p, SetRotate, quad, op1, op2, op3)
+ FoldBinarySet (tokenno, p, SetRotate, quad, Dest, Src, RotateCount)
END FoldSetRotate ;
@@ -5332,14 +5649,9 @@ END FoldSetRotate ;
CodeSetRotate - encode set arithmetic rotate.
*)
-PROCEDURE CodeSetRotate (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeSetRotate (quad: CARDINAL) ;
BEGIN
- CodeBinarySetShift (BuildLogicalRotate,
- SetRotate,
- MakeKey ('RotateVal'),
- MakeKey ('RotateLeft'),
- MakeKey ('RotateRight'),
- quad, op1, op2, op3)
+ CodeBinarySetShiftRotate (quad, FALSE)
END CodeSetRotate ;
@@ -5362,7 +5674,8 @@ END FoldSetLogicalDifference ;
PROCEDURE CodeSetLogicalDifference (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalDifference, SetDifference, quad)
+ CodeBinarySet (SetAnd, BuildLogicalDifference,
+ MakeKey ("LogicalDifference"), quad)
END CodeSetLogicalDifference ;
@@ -5379,11 +5692,13 @@ END FoldSymmetricDifference ;
(*
CodeSetSymmetricDifference - code set difference.
+ A logical xor expression.
*)
PROCEDURE CodeSetSymmetricDifference (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildSymmetricDifference, SetSymmetricDifference, quad)
+ CodeBinarySet (SetSymmetricDifference, BuildSymmetricDifference,
+ MakeKey ("SymmetricDifference"), quad)
END CodeSetSymmetricDifference ;
@@ -5392,15 +5707,19 @@ END CodeSetSymmetricDifference ;
Set operands may be longer than a word.
*)
-PROCEDURE CodeUnarySet (unop: BuildUnarySetFunction; constop: DoUnaryProcedure;
+PROCEDURE CodeUnarySet (constop: ProcedureCardinal;
+ unfunc: UnaryFunction;
+ tokenno: CARDINAL;
+ wideprocname: Name;
quad: CARDINAL; result, expr: CARDINAL) ;
VAR
location: location_t ;
+ settype : CARDINAL ;
BEGIN
- (* firstly ensure that constant literals are declared *)
- DeclareConstant (CurrentQuadToken, expr) ;
- DeclareConstructor (CurrentQuadToken, quad, expr) ;
- location := TokenToLocation (CurrentQuadToken) ;
+ (* Firstly ensure that constant literals are declared. *)
+ DeclareConstant (tokenno, expr) ;
+ DeclareConstructor (tokenno, quad, expr) ;
+ location := TokenToLocation (tokenno) ;
IF IsConst (result)
THEN
@@ -5409,68 +5728,201 @@ BEGIN
Assert (FindType (expr) # NulSym) ;
PutConst (result, FindType (expr)) ;
PushValue (expr) ;
- constop (CurrentQuadToken) ;
+ constop (tokenno) ;
PopValue (result) ;
PushValue (result) ;
PutConstSet (result) ;
ConstantKnownAndUsed (result,
- DeclareKnownConstant(location,
- Mod2Gcc (GetType (expr)),
- PopSetTree (CurrentQuadToken)))
+ DeclareKnownConstant (location,
+ Mod2Gcc (GetType (expr)),
+ PopSetTree (tokenno)))
ELSE
- MetaErrorT0 (CurrentQuadToken,
+ MetaErrorT0 (tokenno,
'{%E}constant expression cannot be evaluated')
END
ELSE
checkDeclare (result) ;
- BuildUnaryForeachWordDo (location,
- Mod2Gcc (GetType (result)), Mod2Gcc (result), Mod2Gcc (expr), unop,
- GetMode(result) = LeftValue, GetMode(expr) = LeftValue,
- IsConst (result), IsConst (expr))
+ settype := GetLType (result) ;
+ Assert (IsSet (settype)) ;
+ IF GetSetInWord (settype)
+ THEN
+ SetNarrowUnary (location, unfunc, settype, result, expr)
+ ELSE
+ SetWideUnary (tokenno, wideprocname, settype, result, expr)
+ END
END
END CodeUnarySet ;
(*
- FoldIncl - check whether we can fold the InclOp.
- result := result + (1 << expr)
+ FromM2WIDESETImport - returns M2WIDESET.name.
*)
-PROCEDURE FoldIncl (tokenno: CARDINAL; p: WalkAction;
- quad: CARDINAL; result, expr: CARDINAL) ;
+PROCEDURE FromM2WIDESETImport (tokenno: CARDINAL; name: Name) : CARDINAL ;
+VAR
+ sym, module: CARDINAL ;
BEGIN
- (* firstly ensure that constant literals are declared *)
- TryDeclareConstant (tokenno, expr) ;
- IF IsConst (result) AND IsConst (expr)
+ IF GetWideset ()
THEN
- IF GccKnowsAbout (expr) AND IsValueSolved (result)
+ module := MakeDefinitionSource (tokenno, MakeKey ("M2WIDESET")) ;
+ sym := FromModuleGetSym (tokenno, name, module) ;
+ IF IsUnknown (sym)
THEN
- (* fine, we can take advantage of this and fold constants *)
- PushValue (result) ;
- AddBit (tokenno, expr) ;
- AddModGcc (result, PopSetTree(tokenno)) ;
- p (result) ;
- NoChange := FALSE ;
- SubQuad (quad)
+ MetaErrorT2 (tokenno, 'procedure function {%1Aad} is not available from {%2ad}',
+ sym, module)
END
- END
-END FoldIncl ;
+ ELSE
+ MetaErrorT0 (tokenno, '{%0A}wideset is not available due to -fno-wideset')
+ END ;
+ RETURN sym
+END FromM2WIDESETImport ;
(*
- FoldIfLess - check to see if it is possible to evaluate
- if op1 < op2 then goto op3.
+ SetWideUnaryLibrary - call wideprocname (result, expr) passing result and expr
+ as an array of byte.
*)
-PROCEDURE FoldIfLess (tokenno: CARDINAL;
- quad: CARDINAL; left, right, destQuad: CARDINAL) ;
-BEGIN
- (* Firstly ensure that constant literals are declared. *)
- TryDeclareConstant(tokenno, left) ;
- TryDeclareConstant(tokenno, right) ;
- IF IsConst (left) AND IsConst (right)
- THEN
- IF IsValueSolved (left) AND IsValueSolved (right)
+PROCEDURE SetWideUnaryLibrary (tokenno: CARDINAL;
+ wideprocname: Name;
+ settype, result, expr: CARDINAL) ;
+VAR
+ location : location_t ;
+ procedure,
+ param1,
+ param2 : CARDINAL ;
+ highbit,
+ array1,
+ array2,
+ call : tree ;
+BEGIN
+ procedure := FromM2WIDESETImport (tokenno, wideprocname) ;
+ checkDeclare (procedure) ;
+ location := TokenToLocation (tokenno) ;
+ highbit := ToCardinal (location, CalcBitsInSet (location, settype)) ;
+ param1 := GetNthParamAnyClosest (procedure, 1, GetMainModule ()) ;
+ param2 := GetNthParamAnyClosest (procedure, 2, GetMainModule ()) ;
+ array1 := CreateSetArrayParam (location, tokenno, result, param1) ;
+ array2 := CreateSetArrayParam (location, tokenno, expr, param2) ;
+ BuildParam (location, highbit) ; (* 3rd Parameter. *)
+ BuildParam (location, array2) ; (* 2nd Parameter. *)
+ BuildParam (location, array1) ; (* 1st Parameter. *)
+ call := BuildProcedureCallTree (location, Mod2Gcc (procedure), NIL) ;
+ SetLastFunction (NIL) ;
+ AddStatement (location, call)
+END SetWideUnaryLibrary ;
+
+
+(*
+ SetWideUnaryBuiltinNot - build an builtin wideset NOT operation.
+*)
+
+PROCEDURE SetWideUnaryBuiltinNot (tokenno: CARDINAL; result, expr: CARDINAL) ;
+VAR
+ location : location_t ;
+ byte,
+ lhs, rhs,
+ index,
+ high : tree ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ high := ResolveHigh (tokenno, 1, result) ;
+ index := GetIntegerZero (location) ;
+ byte := Mod2Gcc (Byte) ;
+ REPEAT
+ rhs := BuildArray (location, byte, Mod2Gcc (expr),
+ index, GetIntegerZero (location)) ;
+ rhs := BuildSetNegate (location, rhs) ;
+ rhs := BuildConvert (location, byte, rhs, FALSE) ;
+ lhs := BuildArray (location, byte, Mod2Gcc (result),
+ index, GetIntegerZero (location)) ;
+ BuildAssignmentStatement (location, lhs, rhs) ;
+ PushIntegerTree (index) ;
+ PushCard (1) ;
+ Addn ;
+ index := PopIntegerTree ()
+ UNTIL CompareTrees (index, high) > 0
+END SetWideUnaryBuiltinNot ;
+
+
+(*
+ SetWideUnary - either call the library wideprocname or the builtin
+ version depending upon the optimization setting.
+*)
+
+PROCEDURE SetWideUnary (tokenno: CARDINAL;
+ wideprocname: Name;
+ settype, result, expr: CARDINAL) ;
+BEGIN
+ IF OptimizeSets AND (wideprocname = MakeKey ('Not'))
+ THEN
+ SetWideUnaryBuiltinNot (tokenno, result, expr)
+ ELSE
+ SetWideUnaryLibrary (tokenno, wideprocname, settype, result, expr)
+ END
+END SetWideUnary ;
+
+
+(*
+ SetNarrowUnary - create tree consisting of:
+ result := unfunc (expr)
+ result and expr can be lvalues.
+*)
+
+PROCEDURE SetNarrowUnary (location: location_t; unfunc: UnaryFunction;
+ settype, result, expr: CARDINAL) ;
+VAR
+ isResultL,
+ isExprL : BOOLEAN ;
+BEGIN
+ isResultL := GetMode (result) = LeftValue ;
+ isExprL := GetMode (expr) = LeftValue ;
+ BuildAssignmentStatement (location, getrvalue (location, result, settype, isResultL),
+ unfunc (location,
+ getrvalue (location, expr, settype, isExprL)))
+END SetNarrowUnary ;
+
+
+(*
+ FoldIncl - check whether we can fold the InclOp.
+ result := result + (1 << expr)
+*)
+
+PROCEDURE FoldIncl (tokenno: CARDINAL; p: WalkAction;
+ quad: CARDINAL; result, expr: CARDINAL) ;
+BEGIN
+ (* firstly ensure that constant literals are declared *)
+ TryDeclareConstant (tokenno, expr) ;
+ IF IsConst (result) AND IsConst (expr)
+ THEN
+ IF GccKnowsAbout (expr) AND IsValueSolved (result)
+ THEN
+ (* fine, we can take advantage of this and fold constants *)
+ PushValue (result) ;
+ AddBit (tokenno, expr) ;
+ AddModGcc (result, PopSetTree (tokenno)) ;
+ p (result) ;
+ NoChange := FALSE ;
+ SubQuad (quad)
+ END
+ END
+END FoldIncl ;
+
+
+(*
+ FoldIfLess - check to see if it is possible to evaluate
+ if op1 < op2 then goto op3.
+*)
+
+PROCEDURE FoldIfLess (tokenno: CARDINAL;
+ quad: CARDINAL; left, right, destQuad: CARDINAL) ;
+BEGIN
+ (* Firstly ensure that constant literals are declared. *)
+ TryDeclareConstant(tokenno, left) ;
+ TryDeclareConstant(tokenno, right) ;
+ IF IsConst (left) AND IsConst (right)
+ THEN
+ IF IsValueSolved (left) AND IsValueSolved (right)
THEN
(* We can take advantage of the known values and evaluate the condition. *)
PushValue (left) ;
@@ -5661,8 +6113,8 @@ PROCEDURE FoldIfEqu (tokenno: CARDINAL;
left, right, destQuad: CARDINAL) ;
BEGIN
(* Firstly ensure that constant literals are declared. *)
- TryDeclareConstant(tokenno, left) ;
- TryDeclareConstant(tokenno, right) ;
+ TryDeclareConstant (tokenno, left) ;
+ TryDeclareConstant (tokenno, right) ;
IF IsConst (left) AND IsConst (right)
THEN
IF IsValueSolved (left) AND IsValueSolved (right)
@@ -5693,8 +6145,8 @@ PROCEDURE FoldIfNotEqu (tokenno: CARDINAL;
left, right, destQuad: CARDINAL) ;
BEGIN
(* Firstly ensure that constant literals are declared. *)
- TryDeclareConstant(tokenno, left) ;
- TryDeclareConstant(tokenno, right) ;
+ TryDeclareConstant (tokenno, left) ;
+ TryDeclareConstant (tokenno, right) ;
IF IsConst (left) AND IsConst (right)
THEN
IF IsValueSolved (left) AND IsValueSolved (right)
@@ -5723,93 +6175,256 @@ PROCEDURE GetSetLimits (set: CARDINAL; VAR low, high: CARDINAL) ;
VAR
type: CARDINAL ;
BEGIN
- type := GetType(set) ;
- IF IsSubrange(type)
+ type := GetType (set) ;
+ IF IsSubrange (type)
THEN
- GetSubrange(type, high, low) ;
+ GetSubrange (type, high, low) ;
ELSE
- low := GetTypeMin(type) ;
- high := GetTypeMax(type)
+ low := GetTypeMin (type) ;
+ high := GetTypeMax (type)
END
END GetSetLimits ;
(*
- GetFieldNo - returns the field number in the, set, which contains, element.
+ IsElementInRange - returns TRUE if expr references a bit in setvar
+ which is in the range [low..high]. If expr is a
+ variable it returns TRUE. FALSE is returned if we
+ know expr to be out of bounds.
*)
-PROCEDURE GetFieldNo (tokenno: CARDINAL; element: CARDINAL; set: CARDINAL; VAR offset: tree) : INTEGER ;
+PROCEDURE IsElementInRange (tokenno: CARDINAL; settype, setvar, expr: CARDINAL) : BOOLEAN ;
VAR
- low, high, bpw, c: CARDINAL ;
- location : location_t ;
+ low,
+ high: CARDINAL ;
BEGIN
- location := TokenToLocation(tokenno) ;
- bpw := GetBitsPerBitset() ;
- GetSetLimits(set, low, high) ;
+ IF IsConst (expr)
+ THEN
+ GetSetLimits (settype, low, high) ;
+ PushValue (expr) ;
+ PushValue (high) ;
+ IF Gre (tokenno)
+ THEN
+ MetaErrorT1 (tokenno, 'bit exceeds the range of set {%1Eatd}', setvar) ;
+ RETURN FALSE
+ END ;
+ PushValue (expr) ;
+ PushValue (low) ;
+ IF Less (tokenno)
+ THEN
+ MetaErrorT1 (tokenno, 'bit underflows the range of set {%1Eatd}', setvar) ;
+ RETURN FALSE
+ END
+ END ;
+ RETURN TRUE
+END IsElementInRange ;
- (* check element is legal *)
- PushValue(element) ;
- PushValue(low) ;
- IF Less(tokenno)
- THEN
- (* out of range *)
- RETURN( -1 )
+(*
+ SetElementToBit -
+*)
+
+PROCEDURE SetElementToBit (location: location_t; settype, expr: CARDINAL) : tree ;
+VAR
+ lowelement, highelement: CARDINAL ;
+ low : tree ;
+BEGIN
+ GetSetLimits (settype, lowelement, highelement) ;
+ PushValue (lowelement) ;
+ low := PopIntegerTree () ;
+ RETURN BuildSub (location, ToCardinal (location, Mod2Gcc (expr)),
+ ToCardinal (location, low), FALSE)
+END SetElementToBit ;
+
+
+(*
+ CodeNarrowIncl - result |= (1 << expr).
+*)
+
+PROCEDURE CodeNarrowIncl (location: location_t; settype, result, expr: CARDINAL) ;
+VAR
+ bit : tree ;
+ isLvalue: BOOLEAN ;
+BEGIN
+ bit := SetElementToBit (location, settype, expr) ;
+ isLvalue := GetMode (result) = LeftValue ;
+ BuildAssignmentStatement (location, getrvalue (location, result, settype, isLvalue),
+ ToBitset (location, BuildLogicalOr (location,
+ getrvalue (location, result, settype, isLvalue),
+ BuildLSL (location, GetWordOne (location),
+ bit, FALSE))))
+END CodeNarrowIncl ;
+
+
+(*
+ CodeNarrowExcl - result &= (~ (1 << expr)).
+*)
+
+PROCEDURE CodeNarrowExcl (location: location_t; settype, result, expr: CARDINAL) ;
+VAR
+ bit, mask: tree ;
+ isLvalue : BOOLEAN ;
+BEGIN
+ bit := SetElementToBit (location, settype, expr) ;
+ mask := BuildSetNegate (location,
+ BuildLSL (location, GetWordOne (location),
+ ToWord (location, bit), FALSE)) ;
+ isLvalue := GetMode (result) = LeftValue ;
+ BuildAssignmentStatement (location, getrvalue (location, result, settype, isLvalue),
+ ToBitset (location, BuildLogicalAnd (location,
+ getrvalue (location, result, settype, isLvalue),
+ mask)))
+END CodeNarrowExcl ;
+
+
+(*
+ SetWideUnaryBuiltinIncl -
+*)
+
+PROCEDURE SetWideUnaryBuiltinIncl (location: location_t; dest, bitno: tree) ;
+BEGIN
+ BuildAssignmentStatement (location, dest,
+ BuildConvert (location, Mod2Gcc (Byte),
+ BuildLogicalOr (location,
+ dest,
+ BuildLSL (location, GetWordOne (location),
+ bitno, FALSE)),
+ FALSE))
+END SetWideUnaryBuiltinIncl ;
+
+
+(*
+ SetWideUnaryBuiltinExcl -
+*)
+
+PROCEDURE SetWideUnaryBuiltinExcl (location: location_t; dest, bitno: tree) ;
+VAR
+ mask: tree ;
+BEGIN
+ mask := BuildSetNegate (location,
+ BuildLSL (location, GetWordOne (location),
+ ToWord (location, bitno), FALSE)) ;
+ BuildAssignmentStatement (location, dest,
+ BuildConvert (location, Mod2Gcc (Byte),
+ BuildLogicalAnd (location, dest, mask),
+ FALSE))
+END SetWideUnaryBuiltinExcl ;
+
+
+(*
+ SetWideUnaryBuiltinIncl -
+*)
+
+PROCEDURE SetWideUnaryBuiltinInclExcl (tokenno: CARDINAL;
+ settype, des, expr: CARDINAL;
+ incl: BOOLEAN) ;
+VAR
+ bitsperbyte,
+ byteno,
+ bitno,
+ dest,
+ bit : tree ;
+ location: location_t ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ bit := ToCardinal (location, SetElementToBit (location, settype, expr)) ;
+ bitsperbyte := ToCardinal (location, GetSizeOfInBits (Mod2Gcc (Byte))) ;
+ byteno := BuildDivFloor (location, bit, bitsperbyte, FALSE) ;
+ bitno := BuildModFloor (location, bit, bitsperbyte, FALSE) ;
+ dest := BuildArray (location, Mod2Gcc (Byte),
+ getrvalue (location, des, GetType (des),
+ GetMode (des) = LeftValue),
+ byteno, GetIntegerZero (location)) ;
+ IF incl
+ THEN
+ SetWideUnaryBuiltinIncl (location, dest, bitno)
ELSE
- PushValue(element) ;
- PushValue(high) ;
- IF Gre(tokenno)
+ SetWideUnaryBuiltinExcl (location, dest, bitno)
+ END
+END SetWideUnaryBuiltinInclExcl ;
+
+
+(*
+ SetWideInclExcl - generates M2WIDESET.procedurename (result, expr).
+*)
+
+PROCEDURE SetWideInclExcl (tokenno: CARDINAL; settype, result, expr: CARDINAL;
+ procedurename: Name) ;
+BEGIN
+ IF OptimizeSets
+ THEN
+ IF procedurename = MakeKey ('Incl')
+ THEN
+ SetWideUnaryBuiltinInclExcl (tokenno, settype, result, expr, TRUE)
+ ELSIF procedurename = MakeKey ('Excl')
THEN
- RETURN( -1 )
+ SetWideUnaryBuiltinInclExcl (tokenno, settype, result, expr, FALSE)
+ ELSE
+ InternalError ('expecting Incl or Excl procedure')
END
- END ;
+ ELSE
+ SetWideInclExclLibrary (tokenno, settype, result, expr, procedurename)
+ END
+END SetWideInclExcl ;
- (* all legal *)
- PushValue(low) ;
- offset := PopIntegerTree() ;
- c := 0 ;
- PushValue(element) ;
- PushValue(low) ;
- PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
- PushCard(bpw) ;
- PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
- Addn ;
- WHILE GreEqu(tokenno) DO
- INC(c) ; (* move onto next field *)
- PushValue(element) ;
- PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
- PushCard((c+1)*bpw) ;
- PushValue(low) ;
- PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
- Addn ;
- PushIntegerTree(offset) ;
- PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
- PushCard(bpw) ;
- PushIntegerTree(ToCardinal(location, PopIntegerTree())) ;
- Addn ;
- offset := PopIntegerTree()
- END ;
- RETURN( VAL(INTEGER, c) )
-END GetFieldNo ;
+(*
+ SetWideInclExclLibrary -
+*)
+
+PROCEDURE SetWideInclExclLibrary (tokenno: CARDINAL; settype, result, expr: CARDINAL;
+ procedurename: Name) ;
+VAR
+ location : location_t ;
+ procedure,
+ setparam : CARDINAL ;
+ highbit,
+ bit,
+ setarray,
+ call : tree ;
+BEGIN
+ procedure := FromM2WIDESETImport (tokenno, procedurename) ;
+ location := TokenToLocation (tokenno) ;
+ bit := SetElementToBit (location, settype, expr) ;
+ highbit := ToCardinal (location, CalcBitsInSet (location, settype)) ;
+ setparam := GetNthParamAnyClosest (procedure, 1, GetMainModule ()) ;
+ setarray := CreateSetArrayParam (location, tokenno, result, setparam) ;
+ BuildParam (location, highbit) ; (* 3rd Parameter. *)
+ BuildParam (location, ToCardinal (location, bit)) ; (* 2nd Parameter. *)
+ BuildParam (location, setarray) ; (* 1st Parameter. *)
+ call := BuildProcedureCallTree (location, Mod2Gcc (procedure), NIL) ;
+ SetLastFunction (NIL) ;
+ AddStatement (location, call)
+END SetWideInclExclLibrary ;
(*
CodeIncl - encode an InclOp:
- result := result + (1 << expr)
+ result |= (1 << expr).
*)
-PROCEDURE CodeIncl (result, expr: CARDINAL) ;
+PROCEDURE CodeIncl (quad: CARDINAL) ;
VAR
- low,
- high : CARDINAL ;
- offset : tree ;
- fieldno : INTEGER ;
- location: location_t ;
+ overflow,
+ constExpr : BOOLEAN ;
+ op : QuadOperator ;
+ tokenno : CARDINAL;
+ result, expr: CARDINAL;
+ settype : CARDINAL ;
+ nooperand : CARDINAL ;
+ nopos : CARDINAL ;
+ location : location_t ;
BEGIN
- (* firstly ensure that constant literals are declared *)
- DeclareConstant (CurrentQuadToken, expr) ;
- location := TokenToLocation (CurrentQuadToken) ;
+ GetQuadOtok (quad, tokenno, op,
+ result, nooperand, expr,
+ overflow, constExpr,
+ nopos, nopos, nopos) ;
+ (* Firstly ensure that constant literals are declared *)
+ DeclareConstant (tokenno, expr) ;
+ location := TokenToLocation (tokenno) ;
+ checkDeclare (result) ;
+ settype := GetLType (result) ;
+ Assert (IsSet (settype)) ;
IF IsConst (result)
THEN
@@ -5820,27 +6435,14 @@ BEGIN
InternalError ('should not get to here (why are we generating <incl const, var> ?)')
END
ELSE
- IF IsConst (expr)
+ IF IsElementInRange (tokenno, settype, result, expr)
THEN
- fieldno := GetFieldNo (CurrentQuadToken, expr, GetType (result), offset) ;
- IF fieldno >= 0
+ IF GetSetInWord (settype)
THEN
- PushValue (expr) ;
- PushIntegerTree (offset) ;
- Sub ;
- BuildIncludeVarConst (location,
- Mod2Gcc (GetType (result)),
- Mod2Gcc (result),
- PopIntegerTree (),
- GetMode (result) = LeftValue, fieldno)
+ CodeNarrowIncl (location, settype, result, expr)
ELSE
- MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', result)
+ SetWideInclExcl (tokenno, settype, result, expr, MakeKey ("Incl"))
END
- ELSE
- GetSetLimits (GetType (result), low, high) ;
- BuildIncludeVarVar (location,
- Mod2Gcc (GetType(result)),
- Mod2Gcc (result), Mod2Gcc(expr), GetMode(result) = LeftValue, Mod2Gcc (low))
END
END
END CodeIncl ;
@@ -5848,13 +6450,13 @@ END CodeIncl ;
(*
FoldExcl - check whether we can fold the InclOp.
- op1 := op1 - (1 << op3)
+ result &= ~ (1 << expr).
*)
PROCEDURE FoldExcl (tokenno: CARDINAL; p: WalkAction;
quad: CARDINAL; result, expr: CARDINAL) ;
BEGIN
- (* firstly ensure that constant literals are declared *)
+ (* Firstly ensure that constant literals are declared *)
TryDeclareConstant (tokenno, expr) ;
IF IsConst (result) AND IsConst (expr)
THEN
@@ -5873,45 +6475,49 @@ END FoldExcl ;
(*
CodeExcl - encode an ExclOp:
- result := result - (1 << expr)
+ result &= (~ (1 << expr)).
*)
-PROCEDURE CodeExcl (result, expr: CARDINAL) ;
+PROCEDURE CodeExcl (quad: CARDINAL) ;
VAR
- low,
- high : CARDINAL ;
- offset : tree ;
- fieldno : INTEGER ;
- location: location_t ;
+ overflow,
+ constExpr : BOOLEAN ;
+ op : QuadOperator ;
+ tokenno : CARDINAL;
+ result, expr: CARDINAL;
+ settype : CARDINAL ;
+ nooperand : CARDINAL ;
+ nopos : CARDINAL ;
+ location : location_t ;
BEGIN
- (* firstly ensure that constant literals are declared *)
- DeclareConstant (CurrentQuadToken, expr) ;
- location := TokenToLocation(CurrentQuadToken) ;
+ GetQuadOtok (quad, tokenno, op,
+ result, nooperand, expr,
+ overflow, constExpr,
+ nopos, nopos, nopos) ;
+ (* Firstly ensure that constant literals are declared *)
+ DeclareConstant (tokenno, expr) ;
+ location := TokenToLocation (tokenno) ;
+ checkDeclare (result) ;
+ settype := GetLType (result) ;
+ Assert (IsSet (settype)) ;
IF IsConst (result)
THEN
- InternalError ('should not get to here (if we do we should consider calling FoldInclOp)')
- ELSE
IF IsConst (expr)
THEN
- fieldno := GetFieldNo (CurrentQuadToken, expr, GetType (result), offset) ;
- IF fieldno >= 0
+ InternalError ('this quadruple should have been removed by FoldExcl')
+ ELSE
+ InternalError ('should not get to here (why are we generating <excl const, var> ?)')
+ END
+ ELSE
+ IF IsElementInRange (tokenno, settype, result, expr)
+ THEN
+ IF GetSetInWord (settype)
THEN
- PushValue (expr) ;
- PushIntegerTree (offset) ;
- Sub ;
- BuildExcludeVarConst (location,
- Mod2Gcc (GetType (result)),
- Mod2Gcc (result), PopIntegerTree (),
- GetMode (result)=LeftValue, fieldno)
+ CodeNarrowExcl (location, settype, result, expr)
ELSE
- MetaErrorT1 (CurrentQuadToken, 'bit exceeded the range of set {%1Eatd}', result)
+ SetWideInclExcl (tokenno, settype, result, expr, MakeKey ("Excl"))
END
- ELSE
- GetSetLimits (GetType (result), low, high) ;
- BuildExcludeVarVar (location,
- Mod2Gcc (GetType(result)),
- Mod2Gcc (result), Mod2Gcc(expr), GetMode(result) = LeftValue, Mod2Gcc (low))
END
END
END CodeExcl ;
@@ -5978,7 +6584,7 @@ END FoldUnary ;
FoldUnarySet - check whether we can fold the doOp operation.
*)
-PROCEDURE FoldUnarySet (tokenno: CARDINAL; p: WalkAction; doOp: DoUnaryProcedure;
+PROCEDURE FoldUnarySet (tokenno: CARDINAL; p: WalkAction; doOp: ProcedureCardinal;
quad: CARDINAL; result, expr: CARDINAL) ;
VAR
location: location_t ;
@@ -6120,18 +6726,32 @@ END FoldNegate ;
is required.
*)
-PROCEDURE CodeNegateChecked (quad: CARDINAL; op1, op3: CARDINAL) ;
+PROCEDURE CodeNegateChecked (quad: CARDINAL) ;
+VAR
+ operatorpos,
+ resultpos,
+ nopos, exprpos,
+ result, noop,
+ expr : CARDINAL ;
+ typeChecking,
+ constExpr,
+ overflowChecking: BOOLEAN ;
+ op : QuadOperator ;
BEGIN
- IF IsConstSet (op3) OR IsSet (GetType (op3))
+ GetQuadOTypetok (quad, operatorpos, op,
+ result, noop, expr,
+ overflowChecking, typeChecking, constExpr,
+ resultpos, nopos, exprpos) ;
+ IF IsConstSet (expr) OR IsSet (GetType (expr))
THEN
- CodeUnarySet (BuildSetNegate, SetNegate, quad, op1, op3)
- ELSIF UnaryOperand (quad, op3)
+ CodeUnarySet (SetNegate, BuildSetNegate, operatorpos, MakeKey ('Not'), quad, result, expr)
+ ELSIF UnaryOperand (quad, expr)
THEN
IF MustCheckOverflow (quad)
THEN
- CodeUnaryCheck (BuildNegateCheck, NIL, quad, op1, op3)
+ CodeUnaryCheck (BuildNegateCheck, NIL, quad, result, expr)
ELSE
- CodeUnary (BuildNegate, NIL, quad, op1, op3)
+ CodeUnary (BuildNegate, NIL, quad, result, expr)
END
END
END CodeNegateChecked ;
@@ -6345,6 +6965,19 @@ BEGIN
END BuildHighFromArray ;
+(*
+ BuildHighFromSetArray -
+*)
+
+PROCEDURE BuildHighFromSetArray (tokenno: CARDINAL; settype: CARDINAL) : tree ;
+VAR
+ location: location_t ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ RETURN BuildHighFromStaticArray (location, GetSetArray (settype))
+END BuildHighFromSetArray ;
+
+
(*
BuildHighFromStaticArray -
*)
@@ -6414,26 +7047,29 @@ VAR
Type : CARDINAL ;
location: location_t ;
BEGIN
- Type := SkipType(GetType(operand)) ;
- location := TokenToLocation(tokenno) ;
+ Type := SkipType (GetType (operand)) ;
+ location := TokenToLocation (tokenno) ;
IF (Type=Char) AND (dim=1)
THEN
- RETURN( BuildHighFromChar(operand) )
+ RETURN( BuildHighFromChar (operand) )
ELSIF IsConstString(operand) AND (dim=1)
THEN
- RETURN( BuildHighFromString(operand) )
+ RETURN( BuildHighFromString (operand) )
ELSIF IsArray(Type)
THEN
- RETURN( BuildHighFromArray(tokenno, dim, operand) )
- ELSIF IsUnbounded(Type)
+ RETURN( BuildHighFromArray (tokenno, dim, operand) )
+ ELSIF IsSet (Type)
+ THEN
+ RETURN( BuildHighFromSetArray (tokenno, Type) )
+ ELSIF IsUnbounded (Type)
THEN
- RETURN( GetHighFromUnbounded(location, dim, operand) )
+ RETURN( GetHighFromUnbounded (location, dim, operand) )
ELSE
MetaErrorT1 (tokenno,
'base procedure HIGH expects a variable of type array or a constant string or CHAR as its parameter, rather than {%1Etad}',
operand) ;
- RETURN( GetIntegerZero(location) )
+ RETURN( GetIntegerZero (location) )
END
END ResolveHigh ;
@@ -6500,11 +7136,11 @@ VAR
BEGIN
location := TokenToLocation (CurrentQuadToken) ;
- (* firstly ensure that any constant literal is declared *)
+ (* Firstly ensure that any constant literal is declared. *)
DeclareConstant (CurrentQuadToken, array) ;
IF IsConst (result)
THEN
- (* still have a constant which was not resolved, pass it to gcc *)
+ (* Still have a constant which was not resolved, pass it to gcc. *)
ConstantKnownAndUsed (result,
DeclareKnownConstant(location,
GetM2ZType (),
@@ -6522,7 +7158,7 @@ END CodeHigh ;
(*
CodeUnbounded - codes the creation of an unbounded parameter variable.
- places the address of op3 into *op1
+ result = &array. array can be an lvalue or rvalue.
*)
PROCEDURE CodeUnbounded (result, array: CARDINAL) ;
@@ -6535,23 +7171,31 @@ BEGIN
DeclareConstant (CurrentQuadToken, array) ;
IF IsConstString (array) OR (IsConst (array) AND (GetSType (array) = Char))
THEN
- BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, PromoteToString (CurrentQuadToken, array), FALSE))
+ BuildAssignmentStatement (location, Mod2Gcc (result),
+ BuildAddr (location, PromoteToString (CurrentQuadToken, array), FALSE))
ELSIF IsConstructor (array)
THEN
- BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, Mod2Gcc (array), TRUE))
+ BuildAssignmentStatement (location, Mod2Gcc (result),
+ BuildAddr (location, Mod2Gcc (array), TRUE))
ELSIF IsUnbounded (GetType (array))
THEN
IF GetMode(array) = LeftValue
THEN
+ (* We already have the address of the array, convert it to type of result. *)
Addr := BuildConvert (location, Mod2Gcc (GetType (result)), Mod2Gcc (array), FALSE)
ELSE
+ (* Access the address field from the unbounded record. *)
Addr := BuildComponentRef (location, Mod2Gcc (array), Mod2Gcc (GetUnboundedAddressOffset (GetType (array))))
END ;
+ (* Store address in result. *)
BuildAssignmentStatement (location, Mod2Gcc (result), Addr)
- ELSIF GetMode(array) = RightValue
+ ELSIF GetMode (array) = RightValue
THEN
- BuildAssignmentStatement (location, Mod2Gcc (result), BuildAddr (location, Mod2Gcc (array), FALSE))
+ (* Static array, get the address and store into result. *)
+ BuildAssignmentStatement (location, Mod2Gcc (result),
+ BuildAddr (location, Mod2Gcc (array), FALSE))
ELSE
+ (* Static array which is a left value, just copy the address into result. *)
BuildAssignmentStatement (location, Mod2Gcc (result), Mod2Gcc (array))
END
END CodeUnbounded ;
@@ -6866,9 +7510,7 @@ VAR
tl, tr : tree ;
location: location_t ;
BEGIN
- CheckStop(quad) ;
-
- (* firstly ensure that constant literals are declared *)
+ (* Firstly ensure that constant literals are declared. *)
DeclareConstant(CurrentQuadToken, rhs) ;
DeclareConstructor(CurrentQuadToken, quad, rhs) ;
location := TokenToLocation(CurrentQuadToken) ;
@@ -6876,20 +7518,20 @@ BEGIN
tl := LValueToGenericPtr(location, type) ;
IF IsProcedure(rhs)
THEN
- tr := BuildAddr(location, Mod2Gcc(rhs), FALSE)
+ tr := BuildAddr (location, Mod2Gcc (rhs), FALSE)
ELSE
tr := LValueToGenericPtr(location, rhs) ;
tr := ConvertRHS(tr, type, rhs)
END ;
IF IsConst(lhs)
THEN
- (* fine, we can take advantage of this and fold constant *)
+ (* Fine, we can take advantage of this and fold constant. *)
PutConst(lhs, type) ;
tl := Mod2Gcc(SkipType(type)) ;
ConstantKnownAndUsed (lhs,
BuildConvert (location, tl, Mod2Gcc (rhs), TRUE))
ELSE
- BuildAssignmentStatement (location, Mod2Gcc (lhs), BuildConvert (location, tl, tr, TRUE)) ;
+ BuildAssignmentStatement (location, Mod2Gcc (lhs), BuildConvert (location, tl, tr, TRUE))
END
END CodeConvert ;
@@ -7115,7 +7757,7 @@ END CreateLabelProcedureN ;
PROCEDURE CreateLabelName (q: CARDINAL) : String ;
BEGIN
- (* prefixed by . to ensure that no Modula-2 identifiers clash *)
+ (* Prefixed by . to ensure that no Modula-2 identifiers clash *)
RETURN( Sprintf1(Mark(InitString('.L%d')), q) )
END CreateLabelName ;
@@ -7142,86 +7784,120 @@ VAR
location: location_t ;
BEGIN
location := TokenToLocation(CurrentQuadToken) ;
-
- (* we do not create labels for procedure entries *)
- IF (op#ProcedureScopeOp) AND (op#NewLocalVarOp) AND IsReferenced(quad)
+ (* We do not create labels for procedure entries. *)
+ IF (op # ProcedureScopeOp) AND (op # NewLocalVarOp) AND IsReferenced (quad)
THEN
- DeclareLabel(location, string(CreateLabelName(quad)))
+ DeclareLabel (location, string (CreateLabelName (quad)))
END
END CheckReferenced ;
(*
- CodeIfSetLess -
+ CodeIfSetCondition - code IF left cond right then destquad for set types.
*)
-PROCEDURE CodeIfSetLess (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeIfSetCondition (tokenno: CARDINAL;
+ left, right, destquad: CARDINAL;
+ cond: BinaryFunction; procedurename: Name) ;
VAR
- settype : CARDINAL ;
- falselabel: ADDRESS ;
- location : location_t ;
+ settype : CARDINAL ;
+ location: location_t ;
+ expr : tree ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- IF IsConst(op1) AND IsConst(op2)
+ location := TokenToLocation (tokenno) ;
+ IF IsConst (left) AND IsConst (right)
THEN
InternalError ('this should have been folded in the calling procedure')
- ELSIF IsConst(op1)
+ ELSIF IsConst(left)
THEN
- settype := SkipType(GetType(op2))
+ settype := SkipType (GetType (right))
ELSE
- settype := SkipType(GetType(op1))
+ settype := SkipType (GetType (left))
END ;
- IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
- THEN
- (* word size sets *)
- DoJump(location,
- BuildIsNotSuperset(location,
- BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
- BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
- NIL, string(CreateLabelName(op3)))
+ IF GetSetInWord (settype)
+ THEN
+ (* WORD size sets. *)
+ expr := cond (location,
+ BuildConvert (location, GetWordType (),
+ Mod2Gcc (left), FALSE),
+ BuildConvert (location, GetWordType (),
+ Mod2Gcc (right), FALSE))
ELSE
- falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
+ expr := CallSetWideBoolFunction (location, tokenno,
+ procedurename, settype, left, right)
+ END ;
+ IfExprJump (location, expr, string (CreateLabelName (destquad)))
+END CodeIfSetCondition ;
- BuildForeachWordInSetDoIfExpr(location,
- Mod2Gcc(settype),
- Mod2Gcc(op1), Mod2Gcc(op2),
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- IsConst(op1), IsConst(op2),
- BuildIsSuperset,
- falselabel) ;
- BuildGoto(location, string(CreateLabelName(op3))) ;
- DeclareLabel(location, falselabel)
- END
+(*
+ CodeIfSetLess - code IF left < right then destquad for set types.
+*)
+
+PROCEDURE CodeIfSetLess (tokenno: CARDINAL; left, right, destquad: CARDINAL) ;
+BEGIN
+ CodeIfSetCondition (tokenno, left, right, destquad,
+ BuildIsSubset, MakeKey ("Less"))
END CodeIfSetLess ;
(*
- PerformCodeIfLess - codes the quadruple if op1 < op2 then goto op3
+ CodeIfSetLessEqu - code IF left <= right then destquad for set types.
*)
-PROCEDURE PerformCodeIfLess (quad: CARDINAL) ;
-VAR
- tl, tr : tree ;
- location : location_t ;
- left, right, dest, combined,
- leftpos, rightpos, destpos : CARDINAL ;
- constExpr, overflow : BOOLEAN ;
- op : QuadOperator ;
+PROCEDURE CodeIfSetLessEqu (tokenno: CARDINAL; left, right, destquad: CARDINAL) ;
BEGIN
- GetQuadOtok (quad, combined, op,
- left, right, dest, overflow,
- constExpr,
- leftpos, rightpos, destpos) ;
- location := TokenToLocation (combined) ;
+ CodeIfSetCondition (tokenno, left, right, destquad,
+ BuildIsSubset, MakeKey ("LessEqu"))
+END CodeIfSetLessEqu ;
- IF IsConst(left) AND IsConst(right)
- THEN
- PushValue(left) ;
- PushValue(right) ;
- IF Less(CurrentQuadToken)
+
+(*
+ CodeIfSetGre - code IF left > right then destquad for set types.
+*)
+
+PROCEDURE CodeIfSetGre (tokenno: CARDINAL; left, right, destquad: CARDINAL) ;
+BEGIN
+ CodeIfSetCondition (tokenno, left, right, destquad,
+ BuildIsNotSubset, MakeKey ("Gre"))
+END CodeIfSetGre ;
+
+
+(*
+ CodeIfSetGreEqu - code IF left >= right then destquad for set types.
+*)
+
+PROCEDURE CodeIfSetGreEqu (tokenno: CARDINAL; left, right, destquad: CARDINAL) ;
+BEGIN
+ CodeIfSetCondition (tokenno, left, right, destquad,
+ BuildIsNotSubset, MakeKey ("GreEqu"))
+END CodeIfSetGreEqu ;
+
+
+(*
+ PerformCodeIfLess - codes the quadruple if op1 < op2 then goto op3
+*)
+
+PROCEDURE PerformCodeIfLess (quad: CARDINAL) ;
+VAR
+ tl, tr : tree ;
+ location : location_t ;
+ left, right, dest, combined,
+ leftpos, rightpos, destpos : CARDINAL ;
+ constExpr, overflow : BOOLEAN ;
+ op : QuadOperator ;
+BEGIN
+ GetQuadOtok (quad, combined, op,
+ left, right, dest, overflow,
+ constExpr,
+ leftpos, rightpos, destpos) ;
+ location := TokenToLocation (combined) ;
+
+ IF IsConst(left) AND IsConst(right)
+ THEN
+ PushValue(left) ;
+ PushValue(right) ;
+ IF Less(CurrentQuadToken)
THEN
BuildGoto(location, string(CreateLabelName(dest)))
ELSE
@@ -7230,7 +7906,7 @@ BEGIN
ELSIF IsConstSet(left) OR (IsVar(left) AND IsSet(SkipType(GetType(left)))) OR
IsConstSet(right) OR (IsVar(right) AND IsSet(SkipType(GetType(right))))
THEN
- CodeIfSetLess(quad, left, right, dest)
+ CodeIfSetLess (combined, left, right, dest)
ELSE
IF IsComposite(GetType(left)) OR IsComposite(GetType(right))
THEN
@@ -7245,8 +7921,8 @@ BEGIN
SkipType (GetType (right)),
combined),
left, right) ;
- DoJump (location,
- BuildLessThan (location, tl, tr), NIL, string (CreateLabelName (dest)))
+ IfExprJump (location,
+ BuildLessThan(location, tl, tr), string(CreateLabelName (dest)))
END
END
END PerformCodeIfLess ;
@@ -7266,50 +7942,151 @@ END CodeIfLess ;
(*
- CodeIfSetGre -
+ CodeIfSetEquNarrow -
*)
-PROCEDURE CodeIfSetGre (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+PROCEDURE CodeIfSetEquNarrow (location: location_t; invertCondition: BOOLEAN;
+ settype: CARDINAL; left, right: tree;
+ destQuad: CARDINAL) ;
VAR
- settype : CARDINAL ;
- falselabel: ADDRESS ;
- location : location_t ;
+ condition,
+ mask : tree ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
+ (* The set type fits inside a word, so mask off any unused bits. *)
+ mask := BuildMask (location, CalcBitsInSet (location, settype), FALSE) ;
+ left := BuildLogicalAnd (location, left, mask) ;
+ right := BuildLogicalAnd (location, right, mask) ;
+ IF invertCondition
+ THEN
+ condition := BuildNotEqualTo (location, left, right)
+ ELSE
+ condition := BuildEqualTo (location, left, right)
+ END ;
+ IfExprJump (location, condition,
+ string (CreateLabelName (destQuad)))
+END CodeIfSetEquNarrow ;
- IF IsConst(op1) AND IsConst(op2)
+
+(*
+ CallSetWideBoolFunction - return a tree containing a call to
+ M2WIDESET.widefuncname (left, right, HIGHBIT (settype)).
+*)
+
+PROCEDURE CallSetWideBoolFunction (location: location_t; tokenno: CARDINAL;
+ widefuncname: Name;
+ settype, left, right: CARDINAL) : tree ;
+VAR
+ function,
+ param1,
+ param2 : CARDINAL ;
+ highbit,
+ array1,
+ array2,
+ call : tree ;
+BEGIN
+ function := FromM2WIDESETImport (tokenno, widefuncname) ;
+ checkDeclare (function) ;
+ location := TokenToLocation (tokenno) ;
+ param1 := GetNthParamAnyClosest (function, 1, GetMainModule ()) ;
+ param2 := GetNthParamAnyClosest (function, 2, GetMainModule ()) ;
+ array1 := CreateSetArrayParam (location, tokenno, left, param1) ;
+ array2 := CreateSetArrayParam (location, tokenno, right, param2) ;
+ highbit := ToCardinal (location, CalcHighSetBit (location, settype)) ;
+ BuildParam (location, highbit) ; (* Parameter 3. *)
+ BuildParam (location, array2) ; (* Parameter 2. *)
+ BuildParam (location, array1) ; (* Parameter 1. *)
+ call := BuildProcedureCallTree (location, Mod2Gcc (function),
+ Mod2Gcc (GetType (function))) ;
+ SetLastFunction (NIL) ;
+ RETURN call
+END CallSetWideBoolFunction ;
+
+
+(*
+ CodeIfSetEquWide - creates a statement tree:
+ if left = right then goto destQuad. The boolean
+ invertCondition will check left # right.
+*)
+
+PROCEDURE CodeIfSetEquWide (location: location_t; tokenno: CARDINAL;
+ invertCondition: BOOLEAN;
+ settype, left, right: CARDINAL; destQuad: CARDINAL) ;
+VAR
+ call, expr, label: tree ;
+BEGIN
+ call := CallSetWideBoolFunction (location, tokenno, MakeKey ("Equal"),
+ settype, left, right) ;
+ label := CreateLabelName (destQuad) ;
+ IF invertCondition
THEN
- InternalError ('this should have been folded in the calling procedure')
- ELSIF IsConst(op1)
+ expr := BuildEqualTo (location, call, GetBooleanFalse ())
+ ELSE
+ expr := BuildNotEqualTo (location, call, GetBooleanFalse ())
+ END ;
+ IfExprJump (location, expr, string (label))
+END CodeIfSetEquWide ;
+
+
+(*
+ CodeIfSetEquLower code a comparison between left and right and if true
+ jump to destQuad. The invertCondition allows for the inverse test.
+ Note that if op1 and op2 are not both constants as this will have been
+ evaluated in CodeIfNotEqu.
+*)
+
+PROCEDURE CodeIfSetEquLower (tokenno: CARDINAL; invertCondition: BOOLEAN;
+ left, right, destQuad: CARDINAL) ;
+VAR
+ settype : CARDINAL ;
+ location: location_t ;
+BEGIN
+ location := TokenToLocation (tokenno) ;
+ IF IsConst (left) AND IsConst (right)
THEN
- settype := SkipType(GetType(op2))
+ InternalError ('this should have been folded by CodeIfEqu or CodeIfNotEqu')
+ ELSIF IsConst (left)
+ THEN
+ settype := GetLType (right)
ELSE
- settype := SkipType(GetType(op1))
+ settype := GetLType (left)
END ;
- IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
- THEN
- (* word size sets *)
- DoJump(location,
- BuildIsNotSubset(location,
- BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
- BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
- NIL, string(CreateLabelName(op3)))
+ IF GetLType (left) # GetLType (right)
+ THEN
+ (* This test used to occur after the GetSetInWord (settype) condition. *)
+ MetaErrorT2 (tokenno,
+ 'set comparison is only allowed between the same set type, the set types used by {%1Eatd} and {%2atd} are different',
+ left, right)
+ END ;
+ IF GetSetInWord (settype)
+ THEN
+ (* Allow sets to be compared against { } for bitset. *)
+ CodeIfSetEquNarrow (location, invertCondition, settype,
+ Mod2Gcc (left), Mod2Gcc (right), destQuad)
ELSE
- falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
+ CodeIfSetEquWide (location, tokenno, invertCondition, settype,
+ left, right, destQuad)
+ END
+END CodeIfSetEquLower ;
- BuildForeachWordInSetDoIfExpr(location,
- Mod2Gcc(settype),
- Mod2Gcc(op1), Mod2Gcc(op2),
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- IsConst(op1), IsConst(op2),
- BuildIsSubset,
- falselabel) ;
- BuildGoto(location, string(CreateLabelName(op3))) ;
- DeclareLabel(location, falselabel)
- END
-END CodeIfSetGre ;
+(*
+ CodeIfSetNotEqu - codes if op1 # op2 then goto op3
+*)
+
+PROCEDURE CodeIfSetNotEqu (tokenno: CARDINAL; left, right, destQuad: CARDINAL) ;
+BEGIN
+ CodeIfSetEquLower (tokenno, TRUE, left, right, destQuad)
+END CodeIfSetNotEqu ;
+
+
+(*
+ CodeIfSetEqu - codes if op1 = op2 then goto op3
+*)
+
+PROCEDURE CodeIfSetEqu (tokenno: CARDINAL; left, right, destQuad: CARDINAL) ;
+BEGIN
+ CodeIfSetEquLower (tokenno, FALSE, left, right, destQuad)
+END CodeIfSetEqu ;
(*
@@ -7318,7 +8095,7 @@ END CodeIfSetGre ;
PROCEDURE PerformCodeIfGre (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
@@ -7342,22 +8119,23 @@ BEGIN
ELSIF IsConstSet(left) OR (IsVar(left) AND IsSet(SkipType(GetType(left)))) OR
IsConstSet(right) OR (IsVar(right) AND IsSet(SkipType(GetType(right))))
THEN
- CodeIfSetGre(quad, left, right, dest)
+ CodeIfSetGre (combined, left, right, dest)
ELSE
- IF IsComposite(GetType(left)) OR IsComposite(GetType(right))
+ IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
MetaErrorT2 (combined,
'comparison tests between composite types not allowed {%1Eatd} and {%2atd}',
left, right)
ELSE
- ConvertBinaryOperands(location,
- tl, tr,
- ComparisonMixTypes (left, right,
- SkipType (GetType (left)),
- SkipType (GetType (right)),
- combined),
- left, right) ;
- DoJump(location, BuildGreaterThan(location, tl, tr), NIL, string(CreateLabelName(dest)))
+ ConvertBinaryOperands (location,
+ tl, tr,
+ ComparisonMixTypes (left, right,
+ SkipType (GetType (left)),
+ SkipType (GetType (right)),
+ combined),
+ left, right) ;
+ condition := BuildGreaterThan (location, tl, tr) ;
+ IfExprJump (location, condition, string (CreateLabelName (dest)))
END
END
END PerformCodeIfGre ;
@@ -7376,60 +8154,13 @@ BEGIN
END CodeIfGre ;
-(*
- CodeIfSetLessEqu -
-*)
-
-PROCEDURE CodeIfSetLessEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
-VAR
- settype : CARDINAL ;
- falselabel: ADDRESS ;
- location : location_t ;
-BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- IF IsConst(op1) AND IsConst(op2)
- THEN
- InternalError ('this should have been folded in the calling procedure')
- ELSIF IsConst(op1)
- THEN
- settype := SkipType(GetType(op2))
- ELSE
- settype := SkipType(GetType(op1))
- END ;
- IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
- THEN
- (* word size sets *)
- DoJump(location,
- BuildIsSubset(location,
- BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
- BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
- NIL, string(CreateLabelName(op3)))
- ELSE
- falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
-
- BuildForeachWordInSetDoIfExpr(location,
- Mod2Gcc(settype),
- Mod2Gcc(op1), Mod2Gcc(op2),
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- IsConst(op1), IsConst(op2),
- BuildIsNotSubset,
- falselabel) ;
-
- BuildGoto(location, string(CreateLabelName(op3))) ;
- DeclareLabel(location, falselabel)
- END
-END CodeIfSetLessEqu ;
-
-
(*
PerformCodeIfLessEqu - codes the quadruple if op1 <= op2 then goto op3
*)
PROCEDURE PerformCodeIfLessEqu (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
@@ -7454,7 +8185,7 @@ BEGIN
ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
THEN
- CodeIfSetLessEqu (quad, left, right, dest)
+ CodeIfSetLessEqu (combined, left, right, dest)
ELSE
IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
@@ -7469,8 +8200,8 @@ BEGIN
SkipType (GetType (right)),
combined),
left, right) ;
- DoJump (location, BuildLessThanOrEqual (location, tl, tr),
- NIL, string (CreateLabelName (dest)))
+ condition := BuildLessThanOrEqual (location, tl, tr) ;
+ IfExprJump (location, condition, string (CreateLabelName (dest)))
END
END
END PerformCodeIfLessEqu ;
@@ -7489,60 +8220,13 @@ BEGIN
END CodeIfLessEqu ;
-(*
- CodeIfSetGreEqu -
-*)
-
-PROCEDURE CodeIfSetGreEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
-VAR
- settype : CARDINAL ;
- falselabel: ADDRESS ;
- location: location_t ;
-BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- IF IsConst(op1) AND IsConst(op2)
- THEN
- InternalError ('this should have been folded in the calling procedure')
- ELSIF IsConst(op1)
- THEN
- settype := SkipType(GetType(op2))
- ELSE
- settype := SkipType(GetType(op1))
- END ;
- IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
- THEN
- (* word size sets *)
- DoJump(location,
- BuildIsSuperset(location,
- BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
- BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
- NIL, string(CreateLabelName(op3)))
- ELSE
- falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
-
- BuildForeachWordInSetDoIfExpr(location,
- Mod2Gcc(settype),
- Mod2Gcc(op1), Mod2Gcc(op2),
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- IsConst(op1), IsConst(op2),
- BuildIsNotSuperset,
- falselabel) ;
-
- BuildGoto(location, string(CreateLabelName(op3))) ;
- DeclareLabel(location, falselabel)
- END
-END CodeIfSetGreEqu ;
-
-
(*
PerformCodeIfGreEqu - codes the quadruple if op1 >= op2 then goto op3
*)
PROCEDURE PerformCodeIfGreEqu (quad: CARDINAL) ;
VAR
- tl, tr: tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
@@ -7567,7 +8251,7 @@ BEGIN
ELSIF IsConstSet(left) OR (IsVar(left) AND IsSet(SkipType(GetType(left)))) OR
IsConstSet(right) OR (IsVar(right) AND IsSet(SkipType(GetType(right))))
THEN
- CodeIfSetGreEqu(quad, left, right, dest)
+ CodeIfSetGreEqu (combined, left, right, dest)
ELSE
IF IsComposite(GetType(left)) OR IsComposite(GetType(right))
THEN
@@ -7582,7 +8266,8 @@ BEGIN
SkipType (GetType (right)),
combined),
left, right) ;
- DoJump(location, BuildGreaterThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(dest)))
+ condition := BuildGreaterThanOrEqual(location, tl, tr) ;
+ IfExprJump (location, condition, string (CreateLabelName (dest)))
END
END
END PerformCodeIfGreEqu ;
@@ -7601,111 +8286,6 @@ BEGIN
END CodeIfGreEqu ;
-(*
- CodeIfSetEqu - codes if op1 = op2 then goto op3
- Note that if op1 and op2 are not both constants
- since this will have been evaluated in CodeIfEqu.
-*)
-
-PROCEDURE CodeIfSetEqu (quad: CARDINAL; op1, op2, op3: CARDINAL) ;
-VAR
- settype : CARDINAL ;
- falselabel: ADDRESS ;
- location : location_t ;
-BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- IF IsConst(op1) AND IsConst(op2)
- THEN
- InternalError ('this should have been folded in the calling procedure')
- ELSIF IsConst(op1)
- THEN
- settype := SkipType(GetType(op2))
- ELSE
- settype := SkipType(GetType(op1))
- END ;
- IF CompareTrees(FindSize(CurrentQuadToken, settype), FindSize(CurrentQuadToken, Word)) <= 0
- THEN
- (* word size sets *)
- DoJump(location,
- BuildEqualTo(location,
- BuildConvert(location, GetWordType(), Mod2Gcc(op1), FALSE),
- BuildConvert(location, GetWordType(), Mod2Gcc(op2), FALSE)),
- NIL, string(CreateLabelName(op3)))
- ELSIF GetSType(op1)=GetSType(op2)
- THEN
- falselabel := string(Sprintf1(Mark(InitString('.Lset%dcomp')), quad)) ;
-
- BuildForeachWordInSetDoIfExpr(location,
- Mod2Gcc(settype),
- Mod2Gcc(op1), Mod2Gcc(op2),
- GetMode(op1)=LeftValue,
- GetMode(op2)=LeftValue,
- IsConst(op1), IsConst(op2),
- BuildNotEqualTo,
- falselabel) ;
-
- BuildGoto(location, string(CreateLabelName(op3))) ;
- DeclareLabel(location, falselabel)
- ELSE
- MetaErrorT2 (CurrentQuadToken,
- 'set comparison is only allowed between the same set type, the set types used by {%1Eatd} and {%2atd} are different',
- op1, op2)
- END
-END CodeIfSetEqu ;
-
-
-(*
- CodeIfSetNotEqu - codes if op1 # op2 then goto op3
- Note that if op1 and op2 are not both constants
- since this will have been evaluated in CodeIfNotEqu.
-*)
-
-PROCEDURE CodeIfSetNotEqu (left, right, destQuad: CARDINAL) ;
-VAR
- settype : CARDINAL ;
- truelabel: ADDRESS ;
- location : location_t ;
-BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- IF IsConst (left) AND IsConst (right)
- THEN
- InternalError ('this should have been folded in the calling procedure')
- ELSIF IsConst (left)
- THEN
- settype := SkipType (GetType (right))
- ELSE
- settype := SkipType (GetType (left))
- END ;
- IF CompareTrees (FindSize (CurrentQuadToken, settype), FindSize (CurrentQuadToken, Word)) <= 0
- THEN
- (* word size sets *)
- DoJump (location,
- BuildNotEqualTo(location,
- BuildConvert (location, GetWordType (), Mod2Gcc (left), FALSE),
- BuildConvert (location, GetWordType (), Mod2Gcc (right), FALSE)),
- NIL, string (CreateLabelName (destQuad)))
- ELSIF GetSType (left) = GetSType (right)
- THEN
- truelabel := string (CreateLabelName (destQuad)) ;
-
- BuildForeachWordInSetDoIfExpr (location,
- Mod2Gcc (settype),
- Mod2Gcc (left), Mod2Gcc (right),
- GetMode (left) = LeftValue,
- GetMode (right) = LeftValue,
- IsConst (left), IsConst (right),
- BuildNotEqualTo,
- truelabel)
- ELSE
- MetaErrorT2 (CurrentQuadToken,
- 'set comparison is only allowed between the same set type, the set types used by {%1Eatd} and {%2atd} are different',
- left, right)
- END
-END CodeIfSetNotEqu ;
-
-
(*
ComparisonMixTypes -
*)
@@ -7730,7 +8310,7 @@ END ComparisonMixTypes ;
PROCEDURE PerformCodeIfEqu (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
@@ -7770,8 +8350,8 @@ BEGIN
SkipType (GetType (right)),
combined),
left, right) ;
- DoJump (location, BuildEqualTo (location, tl, tr), NIL,
- string (CreateLabelName (dest)))
+ condition := BuildEqualTo (location, tl, tr) ;
+ IfExprJump (location, condition, string (CreateLabelName (dest)))
END
END
END PerformCodeIfEqu ;
@@ -7783,7 +8363,7 @@ END PerformCodeIfEqu ;
PROCEDURE PerformCodeIfNotEqu (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
@@ -7809,7 +8389,7 @@ BEGIN
ELSIF IsConstSet (left) OR (IsVar (left) AND IsSet (SkipType (GetType (left)))) OR
IsConstSet (right) OR (IsVar (right) AND IsSet (SkipType (GetType (right))))
THEN
- CodeIfSetNotEqu (left, right, dest)
+ CodeIfSetNotEqu (combined, left, right, dest)
ELSE
IF IsComposite (GetType (left)) OR IsComposite (GetType (right))
THEN
@@ -7824,8 +8404,8 @@ BEGIN
SkipType (GetType (right)),
combined),
left, right) ;
- DoJump (location, BuildNotEqualTo (location, tl, tr), NIL,
- string (CreateLabelName (dest)))
+ condition := BuildNotEqualTo (location, tl, tr) ;
+ IfExprJump (location, condition, string (CreateLabelName (dest)))
END
END
END PerformCodeIfNotEqu ;
@@ -7938,207 +8518,205 @@ END BuildIfVarInConstValue ;
BuildIfNotVarInConstValue - if not (var in constsetvalue) then goto trueexit
*)
-PROCEDURE BuildIfNotVarInConstValue (quad: CARDINAL; constsetvalue: PtrToValue; var, trueexit: CARDINAL) ;
+PROCEDURE BuildIfNotVarInConstValue (location: location_t; tokenno: CARDINAL;
+ quad: CARDINAL;
+ constsetvalue: PtrToValue;
+ var, trueexit: CARDINAL) ;
VAR
- vt, lt, ht : tree ;
+ vt, lt, ht : tree ;
type,
- low, high, n: CARDINAL ;
+ low, high, n : CARDINAL ;
falselabel,
- truelabel : String ;
- location : location_t ;
+ truelabel : String ;
BEGIN
- location := TokenToLocation(CurrentQuadToken) ;
-
- truelabel := string(CreateLabelName(trueexit)) ;
+ truelabel := string (CreateLabelName (trueexit)) ;
n := 1 ;
- WHILE GetRange(constsetvalue, n, low, high) DO
- INC(n)
+ WHILE GetRange (constsetvalue, n, low, high) DO
+ INC (n)
END ;
IF n=2
THEN
- (* actually only one set range, so we invert it *)
- type := MixTypes3(low, high, var, CurrentQuadToken) ;
- ConvertBinaryOperands(location, vt, lt, type, var, low) ;
- ConvertBinaryOperands(location, ht, lt, type, high, low) ;
- BuildIfNotInRangeGoto(location, vt, lt, ht, truelabel)
+ (* Only one set range, so we invert it *)
+ type := MixTypes3 (low, high, var, tokenno) ;
+ ConvertBinaryOperands (location, vt, lt, type, var, low) ;
+ ConvertBinaryOperands (location, ht, lt, type, high, low) ;
+ BuildIfNotInRangeGoto (location, vt, lt, ht, truelabel)
ELSE
n := 1 ;
- falselabel := string(Sprintf1(Mark(InitString('.Lset%d')), quad)) ;
- WHILE GetRange(constsetvalue, n, low, high) DO
- type := MixTypes3(low, high, var, CurrentQuadToken) ;
- ConvertBinaryOperands(location, vt, lt, type, var, low) ;
- ConvertBinaryOperands(location, ht, lt, type, high, low) ;
- BuildIfInRangeGoto(location, vt, lt, ht, falselabel) ;
- INC(n)
+ falselabel := string (Sprintf1 (Mark (InitString ('.Lset%d')), quad)) ;
+ WHILE GetRange (constsetvalue, n, low, high) DO
+ type := MixTypes3 (low, high, var, tokenno) ;
+ ConvertBinaryOperands (location, vt, lt, type, var, low) ;
+ ConvertBinaryOperands (location, ht, lt, type, high, low) ;
+ BuildIfInRangeGoto (location, vt, lt, ht, falselabel) ;
+ INC (n)
END ;
- BuildGoto(location, truelabel) ;
- DeclareLabel(location, falselabel)
+ BuildGoto (location, truelabel) ;
+ DeclareLabel (location, falselabel)
END
END BuildIfNotVarInConstValue ;
(*
- PerformCodeIfIn - code the quadruple: if op1 in op2 then goto op3
+ SetWideIfIn - if M2WIDESET.In (set, element) then goto branch end.
*)
-PROCEDURE PerformCodeIfIn (quad: CARDINAL) ;
+PROCEDURE SetWideIfIn (location: location_t; tokenno: CARDINAL;
+ invertCondition: BOOLEAN;
+ settype, element, set: CARDINAL; branch: CARDINAL) ;
VAR
- low,
- high : CARDINAL ;
- lowtree,
- hightree,
- offset : tree ;
- fieldno : INTEGER ;
- location : location_t ;
- left, right, dest, combined,
- leftpos, rightpos, destpos : CARDINAL ;
- constExpr, overflow : BOOLEAN ;
- op : QuadOperator ;
+ label : String ;
+ bit, call,
+ expr,
+ setarray : tree ;
+ setparam,
+ procedure: CARDINAL ;
BEGIN
- (* Ensure that any remaining undeclared constant literal is declared. *)
- GetQuadOtok (quad, combined, op,
- left, right, dest,
- constExpr, overflow,
- leftpos, rightpos, destpos) ;
- location := TokenToLocation (combined) ;
- IF IsConst(left) AND IsConst(right)
+ procedure := FromM2WIDESETImport (tokenno, MakeKey ("In")) ;
+ setparam := GetNthParamAnyClosest (procedure, 1, GetMainModule ()) ;
+ setarray := CreateSetArrayParam (location, tokenno, set, setparam) ;
+ bit := SetElementToBit (location, settype, element) ;
+ BuildParam (location, ToCardinal (location, bit)) ;
+ BuildParam (location, setarray) ;
+ call := BuildProcedureCallTree (location,
+ Mod2Gcc (procedure),
+ Mod2Gcc (GetType (procedure))) ;
+ SetLastFunction (NIL) ;
+ label := CreateLabelName (branch) ;
+ IF invertCondition
THEN
- InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
- ELSIF CheckElementSetTypes (quad)
+ expr := BuildEqualTo (location, call, GetBooleanFalse ())
+ ELSE
+ expr := BuildNotEqualTo (location, call, GetBooleanFalse ())
+ END ;
+ IfExprJump (location, expr, string (label))
+END SetWideIfIn ;
+
+
+(*
+ CodeNarrowIfIn -
+*)
+
+PROCEDURE CodeNarrowIfIn (location: location_t;
+ settype: CARDINAL; invertCondition: BOOLEAN;
+ element, set: CARDINAL; branch: CARDINAL) ;
+VAR
+ label, cond,
+ bit, mask, bitset: tree ;
+BEGIN
+ bit := ToBitset (location, SetElementToBit (location, settype, element)) ;
+ mask := BuildMask (location, CalcBitsInSet (location, settype), FALSE) ;
+ (* Mask off only the bits we need. *)
+ bitset := ToBitset (location, BuildLogicalAnd (location, Mod2Gcc (set), mask)) ;
+ IF invertCondition
THEN
- IF IsConst(left)
- THEN
- fieldno := GetFieldNo(combined, left, GetType(right), offset) ;
- IF fieldno>=0
- THEN
- PushValue(left) ;
- PushIntegerTree(offset) ;
- ConvertToType(GetType(left)) ;
- Sub ;
- BuildIfConstInVar(location,
- Mod2Gcc(SkipType(GetType(right))),
- Mod2Gcc(right), PopIntegerTree(),
- GetMode(right)=LeftValue, fieldno,
- string(CreateLabelName(dest)))
- ELSE
- MetaErrorT1 (combined, 'bit exceeded the range of set {%1Eatd}', left)
- END
- ELSIF IsConst(right)
- THEN
- (* builds a cascaded list of if statements *)
- PushValue(right) ;
- BuildIfVarInConstValue(location, combined, GetValue(combined), left, dest)
- ELSE
- GetSetLimits(SkipType(GetType(right)), low, high) ;
-
- PushValue(low) ;
- lowtree := PopIntegerTree() ;
- PushValue(high) ;
- hightree := PopIntegerTree() ;
-
- BuildIfVarInVar(location,
- Mod2Gcc(SkipType(GetType(right))),
- Mod2Gcc(right), Mod2Gcc(left),
- GetMode(right)=LeftValue,
- lowtree, hightree,
- string(CreateLabelName(dest)))
- END
- END
-END PerformCodeIfIn ;
+ cond := BuildIfNotInSet (location, bitset, bit)
+ ELSE
+ cond := BuildIfInSet (location, bitset, bit)
+ END ;
+ label := CreateLabelName (branch) ;
+ IfExprJump (location, cond, string (label))
+END CodeNarrowIfIn ;
(*
- PerformCodeIfNotIn - code the quadruple: if not (op1 in op2) then goto op3
+ CodeIfInLower - code the quadruple: if element in set then goto branch.
+ The invertCondition can be set to TRUE to handle CodeIfNotIn.
*)
-PROCEDURE PerformCodeIfNotIn (quad: CARDINAL) ;
+PROCEDURE CodeIfInLower (tokenno: CARDINAL; quad: CARDINAL;
+ invertCondition: BOOLEAN;
+ element, set, branch: CARDINAL) ;
VAR
- low,
- high : CARDINAL ;
- lowtree,
- hightree,
- offset : tree ;
- fieldno : INTEGER ;
- location : location_t ;
- left, right, dest, combined,
- leftpos, rightpos, destpos : CARDINAL ;
- constExpr, overflow : BOOLEAN ;
- op : QuadOperator ;
+ settype : CARDINAL ;
+ location : location_t ;
+ constsetvalue: PtrToValue ;
BEGIN
- (* Ensure that any remaining undeclared constant literal is declared. *)
- GetQuadOtok (quad, combined, op,
- left, right, dest,
- overflow, constExpr,
- leftpos, rightpos, destpos) ;
- location := TokenToLocation (combined) ;
- IF IsConst(left) AND IsConst(right)
+ location := TokenToLocation (tokenno) ;
+ (* Firstly ensure that any constant literal is declared. *)
+ DeclareConstant (tokenno, set) ;
+ DeclareConstant (tokenno, element) ;
+ DeclareConstructor (tokenno, quad, set) ;
+ DeclareConstructor (tokenno, quad, element) ;
+ checkDeclare (set) ;
+ checkDeclare (element) ;
+ settype := GetLType (set) ;
+
+ IF IsConst (element) AND IsConst (set)
THEN
InternalError ('should not get to here (if we do we should consider calling FoldIfIn)')
ELSIF CheckElementSetTypes (quad)
THEN
- IF IsConst(left)
+ IF IsConst (set)
THEN
- fieldno := GetFieldNo(combined, left, SkipType(GetType(right)), offset) ;
- IF fieldno>=0
+ PushValue (set) ;
+ constsetvalue := GetValue (tokenno) ;
+ IF invertCondition
THEN
- PushValue(left) ;
- PushIntegerTree(offset) ;
- ConvertToType(GetType(left)) ;
- Sub ;
- BuildIfNotConstInVar(location,
- Mod2Gcc(SkipType(GetType(right))),
- Mod2Gcc(right), PopIntegerTree(),
- GetMode(right)=LeftValue, fieldno,
- string(CreateLabelName(dest)))
+ (* Builds a cascaded list of if statements. *)
+ BuildIfNotVarInConstValue (location, tokenno, quad, constsetvalue, element, branch)
ELSE
- MetaErrorT1 (combined, 'bit exceeded the range of set {%1Eatd}', right)
+ (* Builds a very different cascaded list of if statements. *)
+ BuildIfVarInConstValue (location, tokenno, constsetvalue, element, branch)
END
- ELSIF IsConst(right)
- THEN
- (* builds a cascaded list of if statements *)
- PushValue(right) ;
- BuildIfNotVarInConstValue(quad, GetValue(combined), left, dest)
ELSE
- GetSetLimits(SkipType(GetType(right)), low, high) ;
-
- PushValue(low) ;
- lowtree := PopIntegerTree() ;
- PushValue(high) ;
- hightree := PopIntegerTree() ;
-
- BuildIfNotVarInVar(location,
- Mod2Gcc(SkipType(GetType(right))),
- Mod2Gcc(right), Mod2Gcc(left),
- GetMode(right)=LeftValue,
- lowtree, hightree,
- string(CreateLabelName(dest)))
+ Assert (IsVar (set)) ;
+ IF IsElementInRange (tokenno, settype, set, element)
+ THEN
+ (* Check for narrow and wide sets and call M2WIDESET if appropriate. *)
+ IF GetSetInWord (settype)
+ THEN
+ CodeNarrowIfIn (location, settype, invertCondition, element, set, branch)
+ ELSE
+ SetWideIfIn (location, tokenno, invertCondition, settype, element, set, branch)
+ END
+ END
END
END
-END PerformCodeIfNotIn ;
+END CodeIfInLower ;
+
+
+(*
+ PerformCodeIfIn -
+*)
+
+PROCEDURE PerformCodeIfIn (quad: CARDINAL; invert: BOOLEAN) ;
+VAR
+ op : QuadOperator ;
+ element, set, branch, combined,
+ elementpos, setpos, destpos : CARDINAL ;
+ constExpr, overflow : BOOLEAN ;
+BEGIN
+ GetQuadOtok (quad, combined, op,
+ element, set, branch,
+ overflow, constExpr,
+ elementpos, setpos, destpos) ;
+ CodeIfInLower (combined, quad, invert, element, set, branch)
+END PerformCodeIfIn ;
(*
- CodeIfIn - code the quadruple: if op1 in op2 then goto op3
+ CodeIfIn - code the quadruple: if element in set then goto branch.
*)
PROCEDURE CodeIfIn (quad: CARDINAL) ;
BEGIN
IF IsValidExpressionRelOp (quad, TRUE)
THEN
- PerformCodeIfIn (quad)
+ PerformCodeIfIn (quad, FALSE)
END
END CodeIfIn ;
(*
- CodeIfNotIn - code the quadruple: if not (op1 in op2) then goto op3
+ CodeIfNotIn - code the quadruple: if not (element in set) then goto branch.
*)
PROCEDURE CodeIfNotIn (quad: CARDINAL) ;
BEGIN
IF IsValidExpressionRelOp (quad, TRUE)
THEN
- PerformCodeIfNotIn (quad)
+ PerformCodeIfIn (quad, TRUE)
END
END CodeIfNotIn ;
@@ -8293,10 +8871,66 @@ BEGIN
END InitBuiltinSyms ;
+(*
+ gdbhook - a debugger convenience hook.
+*)
+
+PROCEDURE gdbhook ;
+END gdbhook ;
+
+
+(*
+ BreakWhenQuadTranslated - to be called interactively by gdb.
+*)
+
+PROCEDURE BreakWhenQuadTranslated (quad: CARDINAL) ;
+BEGIN
+ BreakQuad := quad
+END BreakWhenQuadTranslated ;
+
+
+(*
+ CheckBreak - if quad = BreakQuad then call gdbhook.
+*)
+
+PROCEDURE CheckBreak (quad: CARDINAL) ;
BEGIN
+ IF quad = BreakQuad
+ THEN
+ gdbhook
+ END
+END CheckBreak ;
+
+
+(*
+ Init -
+*)
+
+PROCEDURE Init ;
+BEGIN
+ (* You might want to add the option -fm2-debug-trace=quad to cc1gm2 if
+ contenplating interactively debugging cc1gm2 using the scheme below. *)
+ BreakWhenQuadTranslated (0) ; (* Disable the interactive quad watch. *)
+ (* To examine when a quad is about to be converted into a gimple tree
+ run cc1gm2 from gdb and set a break point on gdbhook.
+ (gdb) break gdbhook
+ (gdb) run
+ Now below interactively call BreakWhenQuadTranslated with the quad
+ under investigation. *)
+ gdbhook ;
+ (* Now is the time to interactively call gdb, for example:
+ (gdb) print BreakWhenQuadTranslated (1234)
+ (gdb) cont
+ and you will arrive at gdbhook when this quad is about to be translated. *)
Memset := NulSym ;
Memcpy := NulSym ;
UnboundedLabelNo := 0 ;
CurrentQuadToken := 0 ;
+ SetTemporaryNo := 0 ;
ScopeStack := InitStackWord ()
+END Init ;
+
+
+BEGIN
+ Init
END M2GenGCC.
diff --git a/gcc/m2/gm2-compiler/M2MetaError.def b/gcc/m2/gm2-compiler/M2MetaError.def
index 3dfe9fa01b42..8c660ad7cea9 100644
--- a/gcc/m2/gm2-compiler/M2MetaError.def
+++ b/gcc/m2/gm2-compiler/M2MetaError.def
@@ -43,7 +43,8 @@ FROM NameKey IMPORT Name ;
{%1Td} get the type of the first symbol and describe it.
{%1Sd} skip the type pseudonyms of the first symbol and describe it.
{%1ua} force no quotes after substituting the text.
-
+ {%1av} check name for starting with a vowel and if so append n to the
+ previous word.
{%1D} sets the error message to where symbol 1 was declared.
The declaration will choose the definition module, then
implementation (or program) module.
diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod
index 3aa7543231d7..5b8aafec4aa0 100644
--- a/gcc/m2/gm2-compiler/M2MetaError.mod
+++ b/gcc/m2/gm2-compiler/M2MetaError.mod
@@ -44,7 +44,8 @@ FROM Indexing IMPORT Index, InitIndex, KillIndex, GetIndice, PutIndice,
FROM DynamicStrings IMPORT String, InitString, InitStringCharStar,
ConCat, ConCatChar, Mark, string, KillString,
- Dup, char, Length, Mult, EqualArray, Equal ;
+ Dup, char, Length, Mult, EqualArray, Equal,
+ RemoveWhitePostfix ;
FROM SymbolTable IMPORT NulSym,
IsDefImp, IsModule, IsInnerModule,
@@ -88,6 +89,7 @@ TYPE
highplus1 : CARDINAL ;
len,
ini : INTEGER ;
+ vowel,
glyph,
chain,
root,
@@ -507,13 +509,14 @@ BEGIN
WITH eb DO
useError := TRUE ;
e := NIL ;
- type := error ; (* default to the error color. *)
+ type := error ; (* Default to the error color. *)
out := InitString ('') ;
in := input ;
highplus1 := HIGH (sym) + 1 ;
len := Length (input) ;
ini := 0 ;
- glyph := FALSE ; (* nothing to output yet. *)
+ glyph := FALSE ; (* Nothing to output yet. *)
+ vowel := FALSE ; (* Check for a vowel when outputing string? *)
quotes := TRUE ;
positive := TRUE ;
root := FALSE ;
@@ -542,7 +545,7 @@ END push ;
(*
- pop - copies contents of oldblock into newblock. It only copies the error
+ pop - copies contents of fromblock into toblock. It only copies the error
handle if the toblock.e is NIL.
*)
@@ -550,6 +553,7 @@ PROCEDURE pop (VAR toblock, fromblock: errorBlock) ;
VAR
c: colorType ;
BEGIN
+ checkVowel (toblock, fromblock) ;
IF empty (fromblock)
THEN
toblock.stackPtr := fromblock.stackPtr ;
@@ -708,7 +712,7 @@ END killErrorBlock ;
)
=:
- op := {'a'|'q'|'t'|'d'|'n'|'s'|'B'|'D'|'F'|'G'|'H'|'M'|'U'|'E'|'V'|'W'|'A'} then =:
+ op := {'a'|'q'|'t'|'d'|'n'|'s'|'v'|'B'|'D'|'F'|'G'|'H'|'M'|'U'|'E'|'V'|'W'|'A'} then =:
then := [ ':' ebnf ] =:
*)
@@ -972,6 +976,38 @@ BEGIN
END empty ;
+(*
+ checkVowel - checks to see if the from block word starts with
+ a vowel and if so adds an n to the to block output.
+*)
+
+PROCEDURE checkVowel (VAR to: errorBlock; from: errorBlock) ;
+BEGIN
+ IF from.vowel AND (NOT empty (from))
+ THEN
+ IF isVowel (char (from.out, 0))
+ THEN
+ IF Length (to.out) > 0
+ THEN
+ to.out := RemoveWhitePostfix (Mark (to.out)) ;
+ to.out := ConCat (to.out, Mark (InitString ('n '))) ;
+ from.vowel := FALSE
+ END
+ END
+ END
+END checkVowel ;
+
+
+(*
+ isVowel - returns TRUE if ch is a, e, i, o or u.
+*)
+
+PROCEDURE isVowel (ch: CHAR) : BOOLEAN ;
+BEGIN
+ RETURN (ch = 'a') OR (ch = 'e') OR (ch = 'i') OR (ch = 'o') OR (ch = 'u')
+END isVowel ;
+
+
(*
clear - remove the output string.
*)
@@ -1624,7 +1660,7 @@ BEGIN
RETURN InitString('set')
ELSIF IsUnknown(sym)
THEN
- RETURN InitString('an unknown')
+ RETURN InitString('unknown')
ELSIF IsSubrange(sym)
THEN
RETURN InitString('subrange')
@@ -1676,7 +1712,7 @@ END copySym ;
(*
- op := {'!'|'a'|'c'|'d'|'k'|'n'|'p'|'q'|'s'|'t'|'u'|
+ op := {'!'|'a'|'c'|'d'|'k'|'n'|'p'|'q'|'s'|'t'|'u'|'v'|
'A'|'B'|'C'|'D'|'E'|'F'|'G'|'H'|'K'|'M'|'N'|
'O'|'P'|'Q'|'R'|'S'|'T'|'U'|'V'|'W'|'X'|'Y'|'Z'} then =:
*)
@@ -1705,6 +1741,7 @@ BEGIN
's': doSkipType (eb, sym, bol) |
't': doType (eb, sym, bol) |
'u': eb.quotes := FALSE |
+ 'v': eb.vowel := TRUE |
'A': eb.type := aborta ;
seenAbort := TRUE |
'B': declaredType (eb, sym, bol) |
diff --git a/gcc/m2/gm2-compiler/M2Options.def b/gcc/m2/gm2-compiler/M2Options.def
index 4cb7f8f483eb..59b59244363a 100644
--- a/gcc/m2/gm2-compiler/M2Options.def
+++ b/gcc/m2/gm2-compiler/M2Options.def
@@ -55,9 +55,10 @@ VAR
StyleChecking, (* -Wstudents checks for common student errs*)
UnboundedByReference, (* -funbounded-by-reference *)
VerboseUnbounded, (* -Wverbose-unbounded *)
- OptimizeUncalledProcedures, (* -Ouncalled removes uncalled procedures *)
- OptimizeBasicBlock, (* -Obb create basic blocks and optimize. *)
- OptimizeCommonSubExpressions, (* -Ocse optimize common subexpressions *)
+ OptimizeUncalledProcedures, (* Removes uncalled procedures? *)
+ OptimizeBasicBlock, (* Create basic blocks and optimize? *)
+ OptimizeCommonSubExpressions, (* Optimize common subexpressions? *)
+ OptimizeSets, (* TRUE if -On when n>0. False for -Os. *)
WholeProgram, (* -fwhole-program optimization. *)
NilChecking, (* -fnil makes compiler test for pointer *)
(* NIL. *)
@@ -115,6 +116,7 @@ VAR
SharedFlag, (* -fshared indicating this module needs *)
(* the shared library version of the *)
(* scaffold. *)
+ TimeReport, MemReport, (* -ftime-report and -fmem-report values. *)
ForcedLocation,
GenerateStatementNote,
Optimizing,
@@ -1165,6 +1167,34 @@ PROCEDURE SetFileOffsetBits (value: BOOLEAN; bits: CARDINAL) : BOOLEAN ;
PROCEDURE GetFileOffsetBits () : CARDINAL ;
+(*
+ SetMemReport - set MemReport to value.
+*)
+
+PROCEDURE SetMemReport (value: BOOLEAN) ;
+
+
+(*
+ SetTimeReport - set TimeReport to value.
+*)
+
+PROCEDURE SetTimeReport (value: BOOLEAN) ;
+
+
+(*
+ SetWideset - set the Wideset flag to value.
+*)
+
+PROCEDURE SetWideset (value: BOOLEAN) ;
+
+
+(*
+ GetWideset - return the Wideset flag value.
+*)
+
+PROCEDURE GetWideset () : 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 542b87b12d2c..cde3c36b035b 100644
--- a/gcc/m2/gm2-compiler/M2Options.mod
+++ b/gcc/m2/gm2-compiler/M2Options.mod
@@ -85,6 +85,7 @@ VAR
DumpDecl, (* -fm2-dump=decl. *)
DumpGimple, (* -fm2-dump=gimple. *)
DumpQuad, (* -fq, -fm2-dump=quad dump quadruples. *)
+ WidesetFlag, (* -fwideset. *)
MFlag,
MMFlag,
MPFlag,
@@ -1326,12 +1327,14 @@ BEGIN
Optimizing := TRUE ;
OptimizeBasicBlock := TRUE ;
OptimizeUncalledProcedures := TRUE ;
- OptimizeCommonSubExpressions := TRUE
+ OptimizeCommonSubExpressions := TRUE ;
+ OptimizeSets := TRUE
ELSE
Optimizing := FALSE ;
OptimizeBasicBlock := FALSE ;
OptimizeUncalledProcedures := FALSE ;
- OptimizeCommonSubExpressions := FALSE
+ OptimizeCommonSubExpressions := FALSE ;
+ OptimizeSets := FALSE
END
END SetOptimizing ;
@@ -2074,6 +2077,46 @@ BEGIN
END GetFileOffsetBits ;
+(*
+ SetMemReport - set MemReport to value.
+*)
+
+PROCEDURE SetMemReport (value: BOOLEAN) ;
+BEGIN
+ MemReport := value
+END SetMemReport ;
+
+
+(*
+ SetTimeReport - set TimeReport to value.
+*)
+
+PROCEDURE SetTimeReport (value: BOOLEAN) ;
+BEGIN
+ TimeReport := value
+END SetTimeReport ;
+
+
+(*
+ SetWideset - set the Wideset flag to value.
+*)
+
+PROCEDURE SetWideset (value: BOOLEAN) ;
+BEGIN
+ WidesetFlag := value
+END SetWideset ;
+
+
+(*
+ GetWideset - return the Wideset flag value.
+*)
+
+PROCEDURE GetWideset () : BOOLEAN ;
+BEGIN
+ RETURN WidesetFlag
+END GetWideset ;
+
+
BEGIN
cflag := FALSE ; (* -c. *)
RuntimeModuleOverride := InitString (DefaultRuntimeModuleOverride) ;
@@ -2099,6 +2142,7 @@ BEGIN
OptimizeBasicBlock := FALSE ;
OptimizeUncalledProcedures := FALSE ;
OptimizeCommonSubExpressions := FALSE ;
+ OptimizeSets := FALSE ;
NilChecking := FALSE ;
WholeDivChecking := FALSE ;
WholeValueChecking := FALSE ;
@@ -2168,6 +2212,9 @@ BEGIN
DumpGimple := FALSE ;
M2Dump := NIL ;
M2DumpFilter := NIL ;
+ TimeReport := FALSE ;
+ MemReport := FALSE ;
EnableForward := TRUE ;
OffTBits := 0 ; (* Default to CSSIZE_T. *)
+ WidesetFlag := TRUE ;
END M2Options.
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index 748ce2498dbb..9489bd8d114b 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -57,6 +57,8 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
MakeConstString, MakeConstant, MakeConstVar,
MakeConstStringM2nul, MakeConstStringCnul,
Make2Tuple, IsTuple,
+ MakeSubrange, PutSubrange,
+ PutSetArray, MakeSetArray,
RequestSym, MakePointer, PutPointer,
SkipType,
GetDType, GetSType, GetLType,
@@ -109,6 +111,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
IsFieldEnumeration,
IsVar, IsProcType, IsType, IsSubrange, IsExported,
IsConst, IsConstString, IsModule, IsDefImp,
+ IsConstVar,
IsArray, IsUnbounded, IsProcedureNested,
IsParameterUnbounded,
IsPartialUnbounded, IsProcedureBuiltin,
@@ -150,7 +153,8 @@ FROM M2Batch IMPORT MakeDefinitionSource ;
FROM M2GCCDeclare IMPORT PutToBeSolvedByQuads ;
FROM FifoQueue IMPORT GetConstFromFifoQueue,
- PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue ;
+ PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue,
+ GetSetFromFifoQueue ;
FROM M2Comp IMPORT CompilingImplementationModule,
CompilingProgramModule ;
@@ -280,6 +284,8 @@ FROM M2CaseList IMPORT PushCase, PopCase, AddRange, BeginCaseList, EndCaseList,
FROM PCSymBuild IMPORT SkipConst ;
FROM m2builtins IMPORT GetBuiltinTypeInfoType ;
FROM M2LangDump IMPORT IsDumpRequired ;
+FROM SymbolConversion IMPORT GccKnowsAbout ;
+FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemSet ;
IMPORT M2Error, FIO, SFIO, DynamicStrings, StdIO ;
@@ -399,6 +405,7 @@ VAR
(* in order. *)
NoOfQuads : CARDINAL ; (* Number of used quadruples. *)
Head : CARDINAL ; (* Head of the list of quadruples. *)
+ QuadMemDiag : Diagnostic ; (* Contains memory related statistics. *)
BreakQuad : CARDINAL ; (* Stop when BreakQuad is created. *)
@@ -2063,7 +2070,9 @@ BEGIN
ELSE
INC (NoOfQuads) ;
PutIndice (QuadArray, QuadNo, f) ;
- f^.NoOfTimesReferenced := 0
+ f^.NoOfTimesReferenced := 0 ;
+ MemSet (QuadMemDiag, 1, NoOfQuads) ;
+ MemIncr (QuadMemDiag, 2, SIZE (f^))
END
END ;
WITH f^ DO
@@ -3404,7 +3413,7 @@ BEGIN
IF IsPseudoBaseProcedure (expr) OR IsPseudoBaseFunction (expr)
THEN
MetaErrorT1 (exprtok,
- 'an assignment cannot assign a {%1d} {%1a}', expr)
+ 'an assignment cannot assign a {%1dv} {%1a}', expr)
END
END CheckCompatibleWithBecomes ;
@@ -3812,25 +3821,24 @@ END BuildAssignConstant ;
(*
- doBuildAssignment - subsiduary procedure of BuildAssignment.
- It builds the assignment and optionally
- checks the types are compatible.
+ BuildAssignmentBoolean - build the quadruples for a boolean variable or constant
+ which will be assigned to the result of a boolean expression.
+ For example:
+
+ foo := a = b ;
+ foo := a IN b ;
+
+ The boolean result is contained in the control flow
+ the true value will emerge from the quad path t.
+ The false value will emerge from the quad path f.
+ This procedure terminates both paths by backpatching
+ and assigns TRUE or FALSE to the variable/constant.
+ A variable maybe an L value so it will require dereferencing.
*)
-PROCEDURE doBuildAssignment (becomesTokNo: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
-VAR
- r, w,
- t, f,
- Array,
- Des, Exp : CARDINAL ;
- combinedtok,
- destok, exptok: CARDINAL ;
+PROCEDURE BuildAssignmentBoolean (becomesTokNo: CARDINAL; checkTypes, checkOverflow: BOOLEAN;
+ t, f: CARDINAL; Des: CARDINAL; destok: CARDINAL) ;
BEGIN
- DisplayStack ;
- IF IsBoolean (1)
- THEN
- PopBool (t, f) ;
- PopTtok (Des, destok) ;
PutVarConditional (Des, TRUE) ; (* Des will contain the result of a boolean relop. *)
(* Conditional Boolean Assignment. *)
BackPatch (t, NextQuad) ;
@@ -3852,6 +3860,36 @@ BEGIN
ELSE
GenQuadO (becomesTokNo, BecomesOp, Des, NulSym, False, checkOverflow)
END
+END BuildAssignmentBoolean ;
+
+
+(*
+ doBuildAssignment - subsiduary procedure of BuildAssignment.
+ It builds the assignment and optionally
+ checks the types are compatible.
+*)
+
+PROCEDURE doBuildAssignment (becomesTokNo: CARDINAL; checkTypes, checkOverflow: BOOLEAN) ;
+VAR
+ r, w,
+ t, f,
+ Array,
+ Des, Exp : CARDINAL ;
+ combinedtok,
+ destok, exptok: CARDINAL ;
+BEGIN
+ DisplayStack ;
+ IF IsBoolean (1)
+ THEN
+ PopBool (t, f) ;
+ PopTtok (Des, destok) ;
+ IF IsVar (Des) OR IsConstVar (Des)
+ THEN
+ BuildAssignmentBoolean (becomesTokNo, checkTypes, checkOverflow,
+ t, f, Des, destok)
+ ELSE
+ MetaErrorT1 (destok, 'expecting the designator {%1Ead} to be a constant or a variable and not a {%1dv}', Des)
+ END
ELSE
PopTrwtok (Exp, r, exptok) ;
MarkAsRead (r) ;
@@ -5795,8 +5833,8 @@ BEGIN
WHILE i<=n DO
IF IsVarParamAny (ProcType, i) # IsVarParamAny (CheckedProcedure, i)
THEN
- MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', ProcType, GetNth (ProcType, i), i) ;
- MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2d}', call, GetNth (call, i), i)
+ MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2dv}', ProcType, GetNth (ProcType, i), i) ;
+ MetaError3 ('parameter {%3n} in {%1dD} causes a mismatch it was declared as a {%2dv}', call, GetNth (call, i), i)
END ;
BuildRange (InitTypesParameterCheck (tokno, CheckedProcedure, i,
GetNthParamAnyClosest (CheckedProcedure, i, GetCurrentModule ()),
@@ -7863,9 +7901,9 @@ BEGIN
(* Error issue message and fake return stack. *)
IF Iso
THEN
- MetaErrorT0 (functok, 'the only functions permissible in a constant expression are: {%kCAP}, {%kCHR}, {%kCMPLX}, {%kFLOAT}, {%kHIGH}, {%kIM}, {%kLENGTH}, {%kMAX}, {%kMIN}, {%kODD}, {%kORD}, {%kRE}, {%kSIZE}, {%kTSIZE}, {%kTRUNC}, {%kVAL} and gcc builtins')
+ MetaErrorT0 (functok, 'the only functions permissible in a constant expression are: {%kCAP}, {%kCHR}, {%kCMPLX}, {%kFLOAT}, {%kHIGH}, {%kIM}, {%kLENGTH}, {%kMAX}, {%kMIN}, {%kODD}, {%kORD}, {%kRE}, {%kSIZE}, {%kTSIZE}, {%kTBITSIZE}, {%kTRUNC}, {%kVAL} and gcc builtins')
ELSE
- MetaErrorT0 (functok, 'the only functions permissible in a constant expression are: {%kCAP}, {%kCHR}, {%kFLOAT}, {%kHIGH}, {%kMAX}, {%kMIN}, {%kODD}, {%kORD}, {%kSIZE}, {%kTSIZE}, {%kTRUNC}, {%kVAL} and gcc builtins')
+ MetaErrorT0 (functok, 'the only functions permissible in a constant expression are: {%kCAP}, {%kCHR}, {%kFLOAT}, {%kHIGH}, {%kMAX}, {%kMIN}, {%kODD}, {%kORD}, {%kSIZE}, {%kTSIZE}, {%kTRUNC}, {%kTBITSIZE}, {%kVAL} and gcc builtins')
END ;
IF NoOfParam > 0
THEN
@@ -8212,7 +8250,7 @@ BEGIN
PushTFtok (ReturnVar, Address, combinedtok)
ELSE
MetaErrorT1 (functok,
- 'the first parameter to ADDADR {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
+ 'the first parameter to ADDADR {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsdv}',
VarSym) ;
PushTFtok (MakeConstLit (combinedtok, MakeKey('0'), Address), Address, combinedtok)
END
@@ -8295,7 +8333,7 @@ BEGIN
PushTFtok (ReturnVar, Address, combinedtok)
ELSE
MetaErrorT1 (functok,
- 'the first parameter to {%EkSUBADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
+ 'the first parameter to {%EkSUBADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsdv}',
VarSym) ;
PushTFtok (MakeConstLit (vartok, MakeKey('0'), Address), Address, vartok)
END
@@ -8394,13 +8432,13 @@ BEGIN
PushT (2) ; (* Two parameters *)
BuildConvertFunction (Convert, ConstExpr)
ELSE
- MetaError1 ('the second parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
+ MetaError1 ('the second parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsdv}',
OperandSym) ;
PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
END
ELSE
MetaErrorT1 (vartok,
- 'the first parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsd}',
+ 'the first parameter to {%EkDIFADR} {%1Ea} must be a variable of type ADDRESS or a {%EkPOINTER}, rather than a {%1Etsdv}',
VarSym) ;
PushTFtok (MakeConstLit (combinedtok, MakeKey ('0'), Integer), Integer, combinedtok)
END
@@ -8615,7 +8653,7 @@ BEGIN
IF ConstExpr AND IsVar (Var)
THEN
MetaErrorT2 (optok,
- 'the procedure function {%1Ea} is being called from within a constant expression and therefore the parameter {%2a} must be a constant, seen a {%2da}',
+ 'the procedure function {%1Ea} is being called from within a constant expression and therefore the parameter {%2a} must be a constant, seen a {%2dav}',
Func, Var) ;
RETURN TRUE
ELSE
@@ -9352,7 +9390,8 @@ BEGIN
PopTtok (varSet, vartok) ;
PopT (procSym) ;
combinedtok := MakeVirtualTok (functok, functok, exptok) ;
- IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
+ IF (GetSType (varSet) # NulSym)
+ AND (IsSet (GetDType (varSet)) OR IsGenericSystemType (GetDType (varSet)))
THEN
derefExp := DereferenceLValue (exptok, Exp) ;
BuildRange (InitShiftCheck (varSet, derefExp)) ;
@@ -9427,7 +9466,8 @@ BEGIN
MarkAsRead (r) ;
PopTtok (varSet, vartok) ;
PopT (procSym) ;
- IF (GetSType (varSet) # NulSym) AND IsSet (GetDType (varSet))
+ IF (GetSType (varSet) # NulSym)
+ AND (IsSet (GetDType (varSet)) OR IsGenericSystemType (GetDType (varSet)))
THEN
combinedtok := MakeVirtualTok (functok, functok, exptok) ;
derefExp := DereferenceLValue (exptok, Exp) ;
@@ -11609,7 +11649,7 @@ BEGIN
BuildStaticArray
ELSE
MetaErrorT1 (arrayTok,
- 'can only index static or dynamic arrays, {%1Ead} is not an array but a {%tad}',
+ 'can only index static or dynamic arrays, {%1Ead} is not an array but a {%tadv}',
Sym) ;
BuildDesignatorError ('bad array access')
END
@@ -11971,7 +12011,7 @@ BEGIN
MarkAsRead (rw) ;
BuildDesignatorPointerError (Type1, rw, combinedtok, 'bad opaque pointer dereference')
ELSE
- MetaError2 ('{%1Ead} is not a pointer type but a {%2d}', Sym1, Type1) ;
+ MetaError2 ('{%1Ead} is not a pointer type but a {%2dv}', Sym1, Type1) ;
MarkAsRead (rw) ;
BuildDesignatorPointerError (Type1, rw, combinedtok, 'bad pointer dereference')
END
@@ -13065,7 +13105,7 @@ BEGIN
WarnStringAt (s, OldPos) ;
s := InitString ('combined') ;
WarnStringAt (s, OperatorPos) ;
- (* MetaErrorT1 (GetDeclaredMod (t), 'in binary with a {%1a}', t) *)
+ (* MetaErrorT1 (GetDeclaredMod (t), 'in binary with a {%1av}', t) *)
END ;
GenQuadOtok (OperatorPos, MakeOp (NewOp), value, left, right, checkOverflow,
OperatorPos, leftpos, rightpos)
@@ -13384,12 +13424,12 @@ BEGIN
THEN
MetaErrorsT1 (tokpos,
'{%1Ead} expected a variable, procedure, constant or expression',
- 'and it was declared as a {%1Dd}', sym) ;
+ 'and it was declared as a {%1Ddv}', sym) ;
ELSIF (type#NulSym) AND IsArray(type)
THEN
MetaErrorsT1 (tokpos,
'{%1EU} not expecting an array variable as an operand for either comparison or binary operation',
- 'it was declared as a {%1Dd}', sym)
+ 'it was declared as a {%1Ddv}', sym)
ELSIF IsConstString (sym) AND IsConstStringKnown (sym) AND (GetStringLength (tokpos, sym) > 1)
THEN
MetaErrorT1 (tokpos,
@@ -14014,9 +14054,12 @@ END ds ;
PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
BEGIN
+ IF QuadNo # 0
+ THEN
DSdbEnter ;
fprintf1 (GetDumpFile (), '%4d ', QuadNo) ; WriteQuad(QuadNo) ; fprintf0 (GetDumpFile (), '\n') ;
DSdbExit
+ END
END DisplayQuad ;
@@ -14337,7 +14380,11 @@ BEGIN
THEN
fprintf0 (GetDumpFile (), '[') ; WriteMode (GetMode (Sym)) ; fprintf0 (GetDumpFile (), ']')
END ;
- fprintf1 (GetDumpFile (), '(%d)', Sym)
+ fprintf1 (GetDumpFile (), '(%d)', Sym) ;
+ IF GccKnowsAbout (Sym)
+ THEN
+ fprintf0 (GetDumpFile (), '[gcc]')
+ END
END
END WriteOperand ;
@@ -16173,6 +16220,10 @@ BEGIN
InitList(VarientFields) ;
VarientFieldNo := 0 ;
NoOfQuads := 0 ;
+ QuadMemDiag
+ := InitMemDiagnostic
+ ('M2Quad:Quadruples',
+ '{0N} total quadruples {1d} consuming {2M} ram {0M} ({2P})')
END Init ;
diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod
index f1516d3a5e50..a51f224727a0 100644
--- a/gcc/m2/gm2-compiler/M2Range.mod
+++ b/gcc/m2/gm2-compiler/M2Range.mod
@@ -1978,7 +1978,7 @@ BEGIN
IF NOT reportedError (r)
THEN
MetaErrorT2 (tokenNo,
- 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1d}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible',
+ 'assignment designator {%1Ea} {%1ta:of type {%1ta}} {%1d:is a {%1dv}} and expression {%2a} {%2tad:of type {%2tad}} are incompatible',
des, expr)
END ;
setReported (r)
@@ -2047,7 +2047,7 @@ BEGIN
ELSE
MetaErrorT2 (tokenNo,
'assignment designator {%1Ea} {%1ta:of type {%1ta}}' +
- ' {%1d:is a {%1d}} and expression {%2a}' +
+ ' {%1d:is a {%1dv}} and expression {%2a}' +
' {%2tad:of type {%2tad}} are incompatible',
des, expr)
END ;
diff --git a/gcc/m2/gm2-compiler/M2Scaffold.mod b/gcc/m2/gm2-compiler/M2Scaffold.mod
index ff8e20f65a36..e337534fcc36 100644
--- a/gcc/m2/gm2-compiler/M2Scaffold.mod
+++ b/gcc/m2/gm2-compiler/M2Scaffold.mod
@@ -580,7 +580,7 @@ BEGIN
ELSIF ScaffoldDynamic AND (NOT cflag)
THEN
MetaErrorT0 (tokenno,
- '{%O}dynamic linking enabled but no module ctor list has been created, hint use -fuse-list=filename or -fgen-module-list=-')
+ '{%O}dynamic module registration enabled but no module ctor list has been created, hint use -fuse-list=filename or -fgen-module-list=-')
END ;
initFunction := MakeProcedure (tokenno, MakeKey ("_M2_init")) ;
diff --git a/gcc/m2/gm2-compiler/M2SymInit.mod b/gcc/m2/gm2-compiler/M2SymInit.mod
index 6c8912f2c4c0..2740395cf86d 100644
--- a/gcc/m2/gm2-compiler/M2SymInit.mod
+++ b/gcc/m2/gm2-compiler/M2SymInit.mod
@@ -155,11 +155,16 @@ BEGIN
printf (" initialized\n") ;
IF (desc^.type # NulSym) AND IsRecord (desc^.type)
THEN
- i := 1 ;
- n := Indexing.HighIndice (desc^.rec.fieldDesc) ;
- WHILE i <= n DO
- PrintSymInit (Indexing.GetIndice (desc^.rec.fieldDesc, i)) ;
- INC (i)
+ IF desc^.rec.fieldDesc = NIL
+ THEN
+ printf (" record field descriptor has not been initialized yet\n") ;
+ ELSE
+ i := 1 ;
+ n := Indexing.HighIndice (desc^.rec.fieldDesc) ;
+ WHILE i <= n DO
+ PrintSymInit (Indexing.GetIndice (desc^.rec.fieldDesc, i)) ;
+ INC (i)
+ END
END
END
END PrintSymInit ;
diff --git a/gcc/m2/gm2-compiler/M2System.mod b/gcc/m2/gm2-compiler/M2System.mod
index 68ed9dc52ed5..d267df9af5cb 100644
--- a/gcc/m2/gm2-compiler/M2System.mod
+++ b/gcc/m2/gm2-compiler/M2System.mod
@@ -509,8 +509,8 @@ END IsPseudoSystemFunction ;
PROCEDURE IsPseudoSystemFunctionConstExpression (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN(
- (sym=Size) OR (sym=TSize) OR (sym=Rotate) OR (sym=Shift) OR
- (Iso AND ((sym=Cast) OR (sym=MakeAdr)))
+ (sym=Size) OR (sym=TSize) OR (sym=TBitSize) OR (sym=Rotate) OR (sym=Shift) OR
+ (Iso AND ((sym=Cast) OR (sym=MakeAdr) OR (sym=TBitSize)))
)
END IsPseudoSystemFunctionConstExpression ;
diff --git a/gcc/m2/gm2-compiler/NameKey.mod b/gcc/m2/gm2-compiler/NameKey.mod
index 5d68940dc0ee..47c8efbd7204 100644
--- a/gcc/m2/gm2-compiler/NameKey.mod
+++ b/gcc/m2/gm2-compiler/NameKey.mod
@@ -31,6 +31,7 @@ FROM NumberIO IMPORT WriteCard ;
FROM StrLib IMPORT StrLen ;
FROM libc IMPORT strlen ;
FROM ASCII IMPORT nul ;
+(* FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemDecr, MemSet ; *)
TYPE
@@ -50,6 +51,10 @@ VAR
BinaryTree: NameNode ;
KeyIndex : Index ;
LastIndice: CARDINAL ;
+(*
+ NameKeyTreeMemDiag,
+ NameKeyWordMemDiag: Diagnostic ;
+*)
(*
@@ -144,11 +149,19 @@ BEGIN
IF result=less
THEN
NEW(child) ;
- father^.Left := child
+ father^.Left := child ;
+ (*
+ MemIncr (NameKeyTreeMemDiag, 1, 1) ;
+ MemIncr (NameKeyTreeMemDiag, 2, SIZE (child^))
+ *)
ELSIF result=greater
THEN
NEW(child) ;
- father^.Right := child
+ father^.Right := child ;
+ (*
+ MemIncr (NameKeyTreeMemDiag, 1, 1) ;
+ MemIncr (NameKeyTreeMemDiag, 2, SIZE (child^))
+ *)
END ;
WITH child^ DO
Right := NIL ;
@@ -161,7 +174,11 @@ BEGIN
k := LastIndice
ELSE
DEALLOCATE(n, higha+1) ;
- k := child^.Key
+ k := child^.Key ;
+ (*
+ MemDecr (NameKeyWordMemDiag, 1, 1) ;
+ MemDecr (NameKeyWordMemDiag, 2, higha + 1)
+ *)
END ;
RETURN( k )
END DoMakeKey ;
@@ -182,9 +199,13 @@ VAR
BEGIN
higha := StrLen(a) ;
ALLOCATE(p, higha+1) ;
+ (*
+ MemIncr (NameKeyWordMemDiag, 1, 1) ;
+ MemIncr (NameKeyWordMemDiag, 2, higha + 1) ;
+ *)
IF p=NIL
THEN
- HALT (* out of memory error *)
+ HALT (* Out of memory error. *)
ELSE
n := p ;
i := 0 ;
@@ -194,7 +215,6 @@ BEGIN
INC(p)
END ;
p^ := nul ;
-
RETURN( DoMakeKey(n, higha) )
END
END MakeKey ;
@@ -223,7 +243,7 @@ BEGIN
ALLOCATE(p, higha+1) ;
IF p=NIL
THEN
- HALT (* out of memory error *)
+ HALT (* Out of memory error. *)
ELSE
n := p ;
pa := a ;
@@ -413,8 +433,18 @@ END CharKey ;
BEGIN
+(*
+ NameKeyWordMemDiag
+ := InitMemDiagnostic
+ ('NameKey:Words',
+ '{0N} total words {1d} consuming {2M} ({2P})') ;
+ NameKeyTreeMemDiag
+ := InitMemDiagnostic
+ ('NameKey:Tree',
+ '{0N} total tree nodes {1d} consuming {2M} ({2P})') ;
+*)
LastIndice := 0 ;
KeyIndex := InitIndex(1) ;
NEW(BinaryTree) ;
- BinaryTree^.Left := NIL
+ BinaryTree^.Left := NIL ;
END NameKey.
diff --git a/gcc/m2/gm2-compiler/P1SymBuild.mod b/gcc/m2/gm2-compiler/P1SymBuild.mod
index 08a0fc3f9eb0..d6c0f2fcdcf5 100644
--- a/gcc/m2/gm2-compiler/P1SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P1SymBuild.mod
@@ -914,7 +914,7 @@ BEGIN
EndBuildForward. *)
PutDeclared (tokno, ProcSym)
ELSE
- MetaError1 ('expecting a procedure name and symbol {%1Ea} has been declared as a {%1d}', ProcSym) ;
+ MetaError1 ('expecting a procedure name and symbol {%1Ea} has been declared as a {%1dv}', ProcSym) ;
PushT (ProcSym) ;
RETURN
END ;
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod
index 54e624f64929..8efed994df0b 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P2SymBuild.mod
@@ -2589,7 +2589,7 @@ BEGIN
Field := PutFieldRecord(Record, OperandT(NoOfPragmas*2+NoOfFields+3-i), Type, Varient) ;
HandleRecordFieldPragmas(Record, Field, NoOfPragmas)
ELSE
- MetaErrors2('record field {%1ad} has already been declared inside a {%2Dd} {%2a}',
+ MetaErrors2('record field {%1ad} has already been declared inside a {%2Ddv} {%2a}',
'attempting to declare a duplicate record field', fsym, Parent)
END ;
(* adjust the location of declaration to the one on the stack (rather than GetTokenNo). *)
diff --git a/gcc/m2/gm2-compiler/P3Build.bnf b/gcc/m2/gm2-compiler/P3Build.bnf
index 0033d33e446a..89a122b9c13b 100644
--- a/gcc/m2/gm2-compiler/P3Build.bnf
+++ b/gcc/m2/gm2-compiler/P3Build.bnf
@@ -1041,7 +1041,8 @@ SilentExpList := SilentConstExpression { "," SilentConstExpression } =:
-- end of the Silent constant rules
-SetType := ( "SET" | "PACKEDSET" ) "OF" SimpleType =:
+SetType := ( "SET" | "PACKEDSET" ) "OF" SimpleType
+ =:
PointerType := "POINTER" "TO"
Type
diff --git a/gcc/m2/gm2-compiler/PathName.def b/gcc/m2/gm2-compiler/PathName.def
index 39d9b15bb3a1..efd21c694d9d 100644
--- a/gcc/m2/gm2-compiler/PathName.def
+++ b/gcc/m2/gm2-compiler/PathName.def
@@ -1,13 +1,25 @@
-DEFINITION MODULE PathName ;
+(* PathName.def maintains a dictionary of named paths.
-(*
- Title : PathName
- Author : Gaius Mulley
- System : GNU Modula-2
- Date : Wed Feb 8 09:59:46 2023
- Revision : $Version$
- Description: maintains a dictionary of named paths.
-*)
+Copyright (C) 2001-2023 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Modula-2; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. *)
+
+DEFINITION MODULE PathName ;
FROM DynamicStrings IMPORT String ;
FROM DynamicPath IMPORT PathList ;
diff --git a/gcc/m2/gm2-compiler/PathName.mod b/gcc/m2/gm2-compiler/PathName.mod
index 0ba902408204..e641a4fea428 100644
--- a/gcc/m2/gm2-compiler/PathName.mod
+++ b/gcc/m2/gm2-compiler/PathName.mod
@@ -1,5 +1,4 @@
(* M2PathName.mod maintain a dictionary of named paths.
-
Copyright (C) 2023-2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
diff --git a/gcc/m2/gm2-compiler/SymbolConversion.mod b/gcc/m2/gm2-compiler/SymbolConversion.mod
index c25fe5735d5a..dd83b4fa5958 100644
--- a/gcc/m2/gm2-compiler/SymbolConversion.mod
+++ b/gcc/m2/gm2-compiler/SymbolConversion.mod
@@ -39,7 +39,7 @@ FROM SYSTEM IMPORT ADDRESS ;
CONST
USEPOISON = TRUE ;
- GGCPOISON = 0A5A5A5A5H ; (* poisoned memory contains this code *)
+ GGCPOISON = 0A5A5A5A5H ; (* Poisoned memory contains this code. *)
TYPE
PtrToCardinal = POINTER TO CARDINAL ;
@@ -47,6 +47,38 @@ TYPE
VAR
mod2gcc : Index ;
PoisonedSymbol: ADDRESS ;
+ BookSym : CARDINAL ; (* Allows interactive debugging. *)
+
+
+(*
+ gdbhook - a debugger convenience hook.
+*)
+
+PROCEDURE gdbhook ;
+END gdbhook ;
+
+
+(*
+ BreakWhenSymBooked - to be called interactively by gdb.
+*)
+
+PROCEDURE BreakWhenSymBooked (sym: CARDINAL) ;
+BEGIN
+ BookSym := sym
+END BreakWhenSymBooked ;
+
+
+(*
+ CheckBook - if sym = BookSym then call gdbhook.
+*)
+
+PROCEDURE CheckBook (sym: CARDINAL) ;
+BEGIN
+ IF sym = BookSym
+ THEN
+ gdbhook
+ END
+END CheckBook ;
(*
@@ -117,6 +149,7 @@ VAR
old: tree ;
t : PtrToCardinal ;
BEGIN
+ CheckBook (sym) ;
IF gcc=GetErrorNode()
THEN
InternalError ('error node generated during symbol conversion')
@@ -258,6 +291,18 @@ END Poison ;
PROCEDURE Init ;
BEGIN
+ BreakWhenSymBooked (NulSym) ; (* Disable the intereactive sym watch. *)
+ (* To examine when a symbol is double booked run cc1gm2 from gdb
+ and set a break point on gdbhook.
+ (gdb) break gdbhook
+ (gdb) run
+ Now below interactively call BreakWhenSymBooked with the symbol
+ under investigation. *)
+ gdbhook ;
+ (* Now is the time to interactively call gdb, for example:
+ (gdb) print BreakWhenSymBooked (1234)
+ (gdb) cont
+ and you will arrive at gdbhook when this symbol is booked. *)
mod2gcc := InitIndexTuned (1, 1024*1024 DIV 16, 16) ;
ALLOCATE (PoisonedSymbol, 1)
END Init ;
diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def
index 5b93f2923811..12a3b3ad97d8 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.def
+++ b/gcc/m2/gm2-compiler/SymbolTable.def
@@ -580,6 +580,41 @@ PROCEDURE MakeSubrange (tok: CARDINAL; SubrangeName: Name) : CARDINAL ;
PROCEDURE MakeSet (tok: CARDINAL; SetName: Name) : CARDINAL ;
+(*
+ GetSetArray - return the set array for a large set.
+*)
+
+PROCEDURE GetSetArray (sym: CARDINAL) : CARDINAL ;
+
+
+(*
+ PutSetArray - places array into the setarray field.
+*)
+
+PROCEDURE PutSetArray (Sym: CARDINAL; array: CARDINAL) ;
+
+
+(*
+ MakeSetArray - create an ARRAY simpletype OF BOOLEAN.
+*)
+
+PROCEDURE MakeSetArray (token: CARDINAL; subrangetype: CARDINAL) : CARDINAL ;
+
+
+(*
+ PutSetInWord - set the SetInWord boolean to value.
+*)
+
+PROCEDURE PutSetInWord (sym: CARDINAL; value: BOOLEAN) ;
+
+
+(*
+ GetSetInWord - return SetInWord.
+*)
+
+PROCEDURE GetSetInWord (sym: CARDINAL) : BOOLEAN ;
+
+
(*
MakeArray - makes an Array symbol with name ArrayName.
*)
@@ -3496,4 +3531,20 @@ PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL;
currentmodule: CARDINAL) : CARDINAL ;
+(*
+ IsConstVar - returns TRUE if sym is a const var. This is a
+ constant which might be assigned to TRUE or FALSE
+ depending upon the result of the quad stack control flow.
+ Typically used in CONST foo = (a AND b) or similar.
+ This symbol will only be assigned once with a value, but
+ will appear more than once as a designator to an assignment
+ in the quad table. However as the quad table is reduced
+ only one assignment will remain. If after reducing quads
+ two or more assignments remain, then there is an error
+ as sym should not have been declared a constant.
+*)
+
+PROCEDURE IsConstVar (sym: CARDINAL) : BOOLEAN ;
+
+
END SymbolTable.
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index 00946e52b2ed..d610e78821e3 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -80,9 +80,9 @@ FROM SymbolKey IMPORT NulKey, SymbolTree, IsSymbol,
NoOfNodes ;
FROM M2Base IMPORT MixTypes, MixTypesDecl, InitBase, Char, Integer, LongReal,
- Cardinal, LongInt, LongCard, ZType, RType ;
+ Cardinal, LongInt, LongCard, Boolean, ZType, RType ;
-FROM M2System IMPORT Address ;
+FROM M2System IMPORT Address, Byte ;
FROM m2expr IMPORT OverflowZType ;
FROM gcctypes IMPORT tree ;
FROM m2linemap IMPORT BuiltinsLocation ;
@@ -94,6 +94,7 @@ FROM M2Comp IMPORT CompilingDefinitionModule,
FROM FormatStrings IMPORT HandleEscape ;
FROM M2Scaffold IMPORT DeclareArgEnvParams ;
+FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemSet ;
FROM M2SymInit IMPORT InitDesc, InitSymInit, GetInitialized, ConfigSymInit,
SetInitialized, SetFieldInitialized, GetFieldInitialized,
@@ -107,6 +108,7 @@ CONST
DebugUnknownToken = FALSE ; (* If enabled it will generate a warning every
time a symbol is created with an unknown
location. *)
+ BreakNew = 97 ; (* -1 disables the break. *)
(*
The Unbounded is a pseudo type used within the compiler
@@ -653,6 +655,9 @@ TYPE
(* (subrange or enumeration). *)
packedInfo: PackedInfo ; (* the equivalent packed type *)
ispacked : BOOLEAN ;
+ SetInWord: BOOLEAN ; (* Is the set stored in a word? *)
+ SetArray : CARDINAL ; (* Array used for large sets. *)
+ Align : CARDINAL ; (* The alignment of this type *)
Size : PtrToValue ; (* Runtime size of symbol. *)
oafamily : CARDINAL ; (* The oafamily for this sym *)
Scope : CARDINAL ; (* Scope of declaration. *)
@@ -933,6 +938,7 @@ VAR
(* errors. *)
ConstLitArray : Indexing.Index ;
BreakSym : CARDINAL ; (* Allows interactive debugging. *)
+ SymMemDiag : Diagnostic ; (* Contains memory related statistics *)
(*
@@ -1080,7 +1086,9 @@ BEGIN
END ;
PutIndice(Symbols, sym, pSym) ;
CheckBreak (sym) ;
- INC(FreeSymbol)
+ INC (FreeSymbol) ;
+ MemSet (SymMemDiag, 1, FreeSymbol-1) ;
+ MemIncr (SymMemDiag, 2, SIZE (pSym^))
END NewSym ;
@@ -1683,6 +1691,10 @@ PROCEDURE Init ;
VAR
pCall: PtrToCallFrame ;
BEGIN
+ SymMemDiag
+ := InitMemDiagnostic
+ ('SymbolTable:Symbols',
+ '{0N} total symbols {1d} consuming {2M} ram {0M} ({2P})') ;
BreakWhenSymCreated (NulSym) ; (* Disable the intereactive sym watch. *)
(* To examine the symbol table when a symbol is created run cc1gm2 from gdb
and set a break point on gdbhook.
@@ -5403,6 +5415,28 @@ BEGIN
END MakeConstVar ;
+(*
+ IsConstVar - returns TRUE if sym is a const var. This is a
+ constant which might be assigned to TRUE or FALSE
+ depending upon the result of the quad stack control flow.
+ Typically used in CONST foo = (a AND b) or similar.
+ This symbol will only be assigned once with a value, but
+ will appear more than once as a designator to an assignment
+ in the quad table. However as the quad table is reduced
+ only one assignment will remain. If after reducing quads
+ two or more assignments remain, then there is an error
+ as sym should not have been declared a constant.
+*)
+
+PROCEDURE IsConstVar (sym: CARDINAL) : BOOLEAN ;
+VAR
+ pSym: PtrToSymbol ;
+BEGIN
+ pSym := GetPsym (sym) ;
+ RETURN( pSym^.SymbolType=ConstVarSym )
+END IsConstVar ;
+
+
(*
InitConstString - initialize the constant string.
*)
@@ -5827,7 +5861,7 @@ BEGIN
VarSym: RETURN Var.IsSSA
ELSE
- InternalError ('expecting a variable symbol')
+ RETURN FALSE
END
END
END IsVariableSSA ;
@@ -6391,8 +6425,8 @@ BEGIN
Size := InitValue() ; (* Size of array. *)
Offset := InitValue() ; (* Offset of array. *)
Type := NulSym ; (* The Array Type. ARRAY OF Type. *)
+ Align := NulSym ; (* Alignment of this type. *)
Large := FALSE ; (* is this array large? *)
- Align := NulSym ; (* The alignment of this type. *)
oafamily := oaf ; (* The unbounded for this array *)
Scope := GetCurrentScope() ; (* Which scope created it *)
InitWhereDeclaredTok(tok, At) (* Declared here *)
@@ -6992,19 +7026,19 @@ END GetNthParamChoice ;
PROCEDURE GetNthParamOrdered (sym: CARDINAL; ParamNo: CARDINAL;
a, b, c: ProcedureKind) : CARDINAL ;
-VAR
- param: CARDINAL ;
BEGIN
- param := GetNthParamChoice (sym, ParamNo, a) ;
- IF param = NulSym
+ IF GetProcedureParametersDefined (sym, a)
THEN
- param := GetNthParamChoice (sym, ParamNo, b) ;
- IF param = NulSym
+ RETURN GetNthParamChoice (sym, ParamNo, a)
+ ELSIF GetProcedureParametersDefined (sym, b)
+ THEN
+ RETURN GetNthParamChoice (sym, ParamNo, b)
+ ELSIF GetProcedureParametersDefined (sym, c)
THEN
- param := GetNthParamChoice (sym, ParamNo, c)
+ RETURN GetNthParamChoice (sym, ParamNo, c)
+ ELSE
+ RETURN NulSym
END
- END ;
- RETURN param
END GetNthParamOrdered ;
@@ -7023,6 +7057,10 @@ END GetNthParamOrdered ;
PROCEDURE GetNthParamAnyClosest (sym: CARDINAL; ParamNo: CARDINAL;
currentmodule: CARDINAL) : CARDINAL ;
BEGIN
+ IF IsUnknown (sym)
+ THEN
+ InternalError (__FILE__ + ":" + __FUNCTION__ + ":not expecting an unknown symbol")
+ END ;
IF GetOuterModuleScope (currentmodule) = GetOuterModuleScope (sym)
THEN
(* Same module. *)
@@ -7042,11 +7080,22 @@ END GetNthParamAnyClosest ;
PROCEDURE GetOuterModuleScope (sym: CARDINAL) : CARDINAL ;
BEGIN
- WHILE NOT (IsDefImp (sym) OR
- (IsModule (sym) AND (GetScope (sym) = NulSym))) DO
- sym := GetScope (sym)
- END ;
+ REPEAT
+ IF IsDefImp (sym)
+ THEN
+ (* Definition/implementation module. *)
RETURN sym
+ ELSIF IsModule (sym)
+ THEN
+ IF GetScope (sym) = NulSym
+ THEN
+ (* Outer module. *)
+ RETURN sym
+ END
+ END ;
+ sym := GetScope (sym)
+ UNTIL sym = NulSym ;
+ InternalError ('not expecting to reach an outer scope')
END GetOuterModuleScope ;
@@ -11857,10 +11906,6 @@ BEGIN
CASE SymbolType OF
ErrorSym : n := 0 |
-(*
- ArraySym ,
- UnboundedSym : n := 1 | (* Standard language limitation *)
-*)
EnumerationSym: n := pSym^.Enumeration.NoOfElements |
InterfaceSym : n := HighIndice(Interface.Parameters)
@@ -11995,6 +12040,10 @@ BEGIN
InitPacked(packedInfo) ; (* not packed and no *)
(* equivalent (yet). *)
ispacked := FALSE ; (* Not yet known to be packed. *)
+ SetInWord := TRUE ; (* Can the set be stored in a *)
+ (* single word? *)
+ SetArray := NulSym ; (* Set used for large sets. *)
+ Align := NulSym ;
oafamily := oaf ; (* The unbounded sym for this *)
Scope := GetCurrentScope() ; (* Which scope created it *)
InitWhereDeclaredTok(tok, At) (* Declared here *)
@@ -12031,6 +12080,46 @@ BEGIN
END PutSet ;
+(*
+ PutSetArray - places array into the setarray field.
+*)
+
+PROCEDURE PutSetArray (Sym: CARDINAL; array: CARDINAL) ;
+VAR
+ pSym: PtrToSymbol ;
+BEGIN
+ pSym := GetPsym(Sym) ;
+ WITH pSym^ DO
+ CASE SymbolType OF
+
+ ErrorSym: |
+ SetSym: WITH Set DO
+ SetArray := array
+ END
+ ELSE
+ InternalError ('expecting a Set symbol')
+ END
+ END
+END PutSetArray ;
+
+
+(*
+ MakeSetArray - create an ARRAY simpletype OF BOOLEAN.
+*)
+
+PROCEDURE MakeSetArray (token: CARDINAL; subrangetype: CARDINAL) : CARDINAL ;
+VAR
+ array, subscript: CARDINAL ;
+BEGIN
+ array := MakeArray (token, NulSym) ;
+ PutArray (array, Byte) ;
+ subscript := MakeSubscript () ;
+ PutSubscript (subscript, subrangetype) ;
+ PutArraySubscript (array, subscript) ;
+ RETURN array
+END MakeSetArray ;
+
+
(*
IsSet - returns TRUE if Sym is a set symbol.
*)
@@ -12059,6 +12148,77 @@ BEGIN
END IsSetPacked ;
+(*
+ GetSetArray - return the set array for a large set.
+*)
+
+PROCEDURE GetSetArray (sym: CARDINAL) : CARDINAL ;
+VAR
+ pSym: PtrToSymbol ;
+BEGIN
+ AssertInRange (sym) ;
+ pSym := GetPsym (sym) ;
+ WITH pSym^ DO
+ CASE SymbolType OF
+
+ SetSym: RETURN Set.SetArray
+
+ ELSE
+ RETURN NulSym
+ END
+ END
+END GetSetArray ;
+
+
+(*
+ PutSetInWord - set the SetInWord boolean to value.
+*)
+
+PROCEDURE PutSetInWord (sym: CARDINAL; value: BOOLEAN) ;
+VAR
+ pSym: PtrToSymbol ;
+BEGIN
+ AssertInRange (sym) ;
+ pSym := GetPsym (sym) ;
+ WITH pSym^ DO
+ CASE SymbolType OF
+
+ SetSym: Set.SetInWord := value ;
+ IF value
+ THEN
+ Set.Align := MakeConstant (GetDeclaredMod (sym), 0) ;
+ Set.ispacked := TRUE
+ END
+
+ ELSE
+ InternalError ('expecting a set symbol')
+ END
+ END
+END PutSetInWord ;
+
+
+(*
+ GetSetInWord - return SetInWord.
+*)
+
+PROCEDURE GetSetInWord (sym: CARDINAL) : BOOLEAN ;
+VAR
+ pSym: PtrToSymbol ;
+BEGIN
+ AssertInRange (sym) ;
+ pSym := GetPsym (sym) ;
+ WITH pSym^ DO
+ CASE SymbolType OF
+
+ SetSym: RETURN Set.SetInWord
+
+ ELSE
+ InternalError ('expecting a Set symbol')
+ END
+ END
+END GetSetInWord ;
+
+
(*
ForeachParameterDo -
*)
@@ -12742,9 +12902,9 @@ BEGIN
type := SkipType(GetType(subscript)) ;
IF IsAModula2Type(type)
THEN
- (* ok all is good *)
+ (* Ok all is good. *)
ELSE
- MetaError2('the array {%1Dad} must be declared with a simpletype in the [..] component rather than a {%2d}',
+ MetaError2('the array {%1Dad} must be declared with a simpletype in the [..] component rather than a {%2dv}',
sym, type)
END
END
@@ -15166,9 +15326,10 @@ BEGIN
RecordSym : Record.Align := align |
RecordFieldSym: RecordField.Align := align |
TypeSym : Type.Align := align |
- ArraySym : Array.Align := align |
PointerSym : Pointer.Align := align |
- SubrangeSym : Subrange.Align := align
+ SubrangeSym : Subrange.Align := align |
+ SetSym : Set.Align := align |
+ ArraySym : Array.Align := align
ELSE
InternalError ('expecting record, field, pointer, type, subrange or an array symbol')
@@ -15193,11 +15354,12 @@ BEGIN
RecordSym : RETURN( Record.Align ) |
RecordFieldSym : RETURN( RecordField.Align ) |
TypeSym : RETURN( Type.Align ) |
- ArraySym : RETURN( Array.Align ) |
PointerSym : RETURN( Pointer.Align ) |
VarientFieldSym: RETURN( GetAlignment(VarientField.Parent) ) |
VarientSym : RETURN( GetAlignment(Varient.Parent) ) |
- SubrangeSym : RETURN( Subrange.Align )
+ SubrangeSym : RETURN( Subrange.Align ) |
+ SetSym : RETURN( Set.Align ) |
+ ArraySym : RETURN( Array.Align )
ELSE
InternalError ('expecting record, field, pointer, type, subrange or an array symbol')
diff --git a/gcc/m2/gm2-gcc/init.cc b/gcc/m2/gm2-gcc/init.cc
index 3156c3f2d6c6..fefcfd4cfa32 100644
--- a/gcc/m2/gm2-gcc/init.cc
+++ b/gcc/m2/gm2-gcc/init.cc
@@ -107,6 +107,7 @@ EXTERN void _M2_M2SSA_init (int argc, char *argv[], char *envp[]);
EXTERN void _M2_M2SymInit_init (int argc, char *argv[], char *envp[]);
EXTERN void _M2_M2StateCheck_init (int argc, char *argv[], char *envp[]);
EXTERN void _M2_P3Build_init (int argc, char *argv[], char *envp[]);
+EXTERN void _M2_M2Diagnostic_init (int argc, char *argv[], char *envp[]);
EXTERN void exit (int);
EXTERN void M2Comp_compile (const char *filename);
EXTERN void RTExceptions_DefaultErrorCatch (void);
@@ -126,6 +127,7 @@ init_FrontEndInit (void)
_M2_M2Dependent_init (0, NULL, NULL);
_M2_M2RTS_init (0, NULL, NULL);
_M2_SysExceptions_init (0, NULL, NULL);
+ _M2_M2Diagnostic_init (0, NULL, NULL);
_M2_DynamicStrings_init (0, NULL, NULL);
_M2_Assertion_init (0, NULL, NULL);
_M2_FormatStrings_init (0, NULL, NULL);
diff --git a/gcc/m2/gm2-gcc/m2block.cc b/gcc/m2/gm2-gcc/m2block.cc
index c4877d1b0416..32e3bd10f60a 100644
--- a/gcc/m2/gm2-gcc/m2block.cc
+++ b/gcc/m2/gm2-gcc/m2block.cc
@@ -115,6 +115,22 @@ typedef struct stmt_tree_s *stmt_tree_t;
static location_t pending_location;
static int pending_statement = false;
+/* GetTotalConstants returns the number of global constants. */
+
+int
+m2block_GetTotalConstants (void)
+{
+ return m2treelib_nCount (global_binding_level->constants);
+}
+
+/* GetGlobalTypes returns the number of global types. */
+
+int
+m2block_GetGlobalTypes (void)
+{
+ return m2treelib_nCount (global_binding_level->types);
+}
+
/* assert_global_names asserts that the global_binding_level->names
can be chained. */
diff --git a/gcc/m2/gm2-gcc/m2block.def b/gcc/m2/gm2-gcc/m2block.def
index 1860379ef239..1986e57a5fa6 100644
--- a/gcc/m2/gm2-gcc/m2block.def
+++ b/gcc/m2/gm2-gcc/m2block.def
@@ -220,4 +220,18 @@ PROCEDURE addStmtNote (location: location_t) ;
PROCEDURE removeStmtNote ;
+(*
+ GetTotalConstants - returns the number of global constants.
+*)
+
+PROCEDURE GetTotalConstants () : CARDINAL ;
+
+
+(*
+ GetGlobalTypes - returns the number of global types.
+*)
+
+PROCEDURE GetGlobalTypes () : CARDINAL ;
+
+
END m2block.
diff --git a/gcc/m2/gm2-gcc/m2block.h b/gcc/m2/gm2-gcc/m2block.h
index 0a58940c1747..04b6aaadeaab 100644
--- a/gcc/m2/gm2-gcc/m2block.h
+++ b/gcc/m2/gm2-gcc/m2block.h
@@ -72,6 +72,8 @@ EXTERN void m2block_includeDecl (tree);
EXTERN tree m2block_add_stmt (location_t location, tree t);
EXTERN void m2block_addStmtNote (location_t location);
EXTERN void m2block_removeStmtNote (void);
+EXTERN int m2block_GetTotalConstants (void);
+EXTERN int m2block_GetGlobalTypes (void);
EXTERN void m2block_init (void);
diff --git a/gcc/m2/gm2-gcc/m2convert.cc b/gcc/m2/gm2-gcc/m2convert.cc
index 8a497e50f6b2..785326cac2f1 100644
--- a/gcc/m2/gm2-gcc/m2convert.cc
+++ b/gcc/m2/gm2-gcc/m2convert.cc
@@ -344,6 +344,17 @@ same_size_types (location_t location, tree t1, tree t2)
return m2expr_CompareTrees (n1, n2) == 0;
}
+/* converting_ISO_generic attempts to convert value to type and returns true
+ if successful. This is a helper function to BuildConvert which will try
+ each generic data type in turn.
+
+ generic_type will be set to any of ISO BYTE, PIM BYTE WORD, etc.
+ If type == generic_type then specific conversion procedures
+ are applied. A constant will be converted via const_to_ISO_type
+ whereas non constants are converted by *(type *) &value.
+
+ Remember that in ISO M2 BYTE is an ARRAY [0..0] OF LOC. */
+
static int
converting_ISO_generic (location_t location, tree type, tree value,
tree generic_type, tree *result)
@@ -354,11 +365,17 @@ converting_ISO_generic (location_t location, tree type, tree value,
/* We let the caller deal with this. */
return false;
- if ((TREE_CODE (value) == INTEGER_CST) && (type == generic_type))
+ if (TREE_CODE (value) == INTEGER_CST)
+ {
+ if (type == generic_type)
{
*result = const_to_ISO_type (location, value, generic_type);
return true;
}
+ /* We must not attempt to convert a constant by taking its
+ address below, so we bail out here. */
+ return false;
+ }
if (same_size_types (location, type, value_type))
{
@@ -382,8 +399,8 @@ converting_ISO_generic (location_t location, tree type, tree value,
return false;
}
-/* convert_char_to_array - convert a single char, value, into an
- type. The type will be array [..] of char. The array type
+/* convert_char_to_array convert a single char value into a type.
+ The type will be array [..] of char. The array type
returned will have nuls appended to pad the single char to the
correct array length. */
@@ -638,6 +655,15 @@ m2convert_ToLoc (location_t location, tree expr)
false);
}
+/* ToPIMByte - convert an expression expr to a PIM BYTE. */
+
+tree
+m2convert_ToPIMByte (location_t location, tree expr)
+{
+ return m2convert_BuildConvert (location, m2type_GetByteType (), expr,
+ false);
+}
+
/* GenericToType - converts, expr, into, type, providing that expr is
a generic system type (byte, word etc). Otherwise expr is
returned unaltered. */
diff --git a/gcc/m2/gm2-gcc/m2convert.def b/gcc/m2/gm2-gcc/m2convert.def
index 83005ec8cd00..2385c3f61270 100644
--- a/gcc/m2/gm2-gcc/m2convert.def
+++ b/gcc/m2/gm2-gcc/m2convert.def
@@ -53,6 +53,20 @@ PROCEDURE ToInteger (location: location_t; expr: tree) : tree ;
PROCEDURE ToBitset (location: location_t; expr: tree) : tree ;
+(*
+ ToLoc - convert an expression, expr, to a LOC.
+*)
+
+PROCEDURE ToLoc (location: location_t; expr: tree) : tree ;
+
+
+(*
+ ToPIMByte - convert an expression expr to a PIM BYTE.
+*)
+
+PROCEDURE ToPIMByte (location: location_t; expr: tree) : tree ;
+
+
(*
ConvertToPtr - convert an expression to a void *.
*)
diff --git a/gcc/m2/gm2-gcc/m2convert.h b/gcc/m2/gm2-gcc/m2convert.h
index 984faf19e4bb..37c8f9cff83c 100644
--- a/gcc/m2/gm2-gcc/m2convert.h
+++ b/gcc/m2/gm2-gcc/m2convert.h
@@ -47,6 +47,8 @@ EXTERN tree m2convert_ToInteger (location_t location, tree expr);
EXTERN tree m2convert_ToWord (location_t location, tree expr);
EXTERN tree m2convert_ToBitset (location_t location, tree expr);
EXTERN tree m2convert_ToLoc (location_t location, tree expr);
+EXTERN tree m2convert_ToPIMByte (location_t location, tree expr);
+
EXTERN tree m2convert_GenericToType (location_t location, tree type,
tree expr);
diff --git a/gcc/m2/gm2-gcc/m2decl.h b/gcc/m2/gm2-gcc/m2decl.h
index 127c9abafca6..eb6569face6b 100644
--- a/gcc/m2/gm2-gcc/m2decl.h
+++ b/gcc/m2/gm2-gcc/m2decl.h
@@ -51,7 +51,6 @@ EXTERN tree m2decl_BuildConstLiteralNumber (location_t location,
const char *str,
unsigned int base,
bool issueError);
-EXTERN void m2decl_RememberVariables (tree l);
EXTERN tree m2decl_BuildEndFunctionDeclaration (
location_t location_begin, location_t location_end, const char *name,
diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 42ea4fa9f5bd..8478e783c202 100644
--- a/gcc/m2/gm2-gcc/m2expr.cc
+++ b/gcc/m2/gm2-gcc/m2expr.cc
@@ -598,7 +598,7 @@ m2expr_BuildLogicalShift (location_t location, tree op1, tree op2, tree op3,
m2convert_ToInteger (location, op3),
m2expr_GetIntegerZero (location));
- m2statement_DoJump (location, is_less, NULL, labelElseName);
+ m2statement_IfExprJump (location, is_less, labelElseName);
op2 = m2convert_ToWord (location, op2);
op3 = m2convert_ToWord (location, op3);
res = m2expr_BuildLSL (location, op2, op3, needconvert);
@@ -673,7 +673,7 @@ m2expr_BuildLRotate (location_t location, tree op1, tree nBits,
op1 = m2expr_FoldAndStrip (op1);
nBits = m2expr_FoldAndStrip (nBits);
- nBits = m2convert_BuildConvert (location, TREE_TYPE (op1), nBits, needconvert);
+ nBits = m2convert_BuildConvert (location, TREE_TYPE (op1), nBits, needconvert);
t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, nBits, needconvert);
return m2expr_FoldAndStrip (t);
}
@@ -724,15 +724,15 @@ m2expr_BuildLRLn (location_t location, tree op1, tree op2, tree nBits,
/* Make absolutely sure there are no high order bits lying around. */
- op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
+ op1 = m2expr_BuildLogicalAnd (location, op1, mask);
left = m2expr_BuildLSL (location, op1, op2min, needconvert);
- left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
+ left = m2expr_BuildLogicalAnd (location, left, mask);
right = m2expr_BuildLSR (
location, op1,
m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
op2min, needconvert),
needconvert);
- return m2expr_BuildLogicalOr (location, left, right, needconvert);
+ return m2expr_BuildLogicalOr (location, left, right);
}
}
@@ -765,15 +765,15 @@ m2expr_BuildLRRn (location_t location, tree op1, tree op2, tree nBits,
/* Make absolutely sure there are no high order bits lying around. */
- op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
+ op1 = m2expr_BuildLogicalAnd (location, op1, mask);
right = m2expr_BuildLSR (location, op1, op2min, needconvert);
left = m2expr_BuildLSL (
location, op1,
m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
op2min, needconvert),
needconvert);
- left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
- return m2expr_BuildLogicalOr (location, left, right, needconvert);
+ left = m2expr_BuildLogicalAnd (location, left, mask);
+ return m2expr_BuildLogicalOr (location, left, right);
}
}
@@ -807,7 +807,7 @@ m2expr_BuildLogicalRotate (location_t location, tree op1, tree op2, tree op3,
tree is_less = m2expr_BuildLessThan (location, rotateCount,
m2expr_GetIntegerZero (location));
- m2statement_DoJump (location, is_less, NULL, labelElseName);
+ m2statement_IfExprJump (location, is_less, labelElseName);
res = m2expr_BuildLRLn (location, op2, rotateCount, nBits, needconvert);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_BuildGoto (location, labelEndName);
@@ -819,139 +819,43 @@ m2expr_BuildLogicalRotate (location_t location, tree op1, tree op2, tree op3,
}
}
-/* buildUnboundedArrayOf construct an unbounded struct and returns
- the gcc tree. The two fields of the structure are initialized to
- contentsPtr and high. */
+/* BuildIfBitInSetLower returns tree ((set >> bit) & 1). It converts set and bit to
+ type word prior to the bit test. */
static tree
-buildUnboundedArrayOf (tree unbounded, tree contentsPtr, tree high)
+BuildIfBitInSetLower (location_t location, enum tree_code code, tree set, tree bit)
{
- tree fields = TYPE_FIELDS (unbounded);
- tree field_list = NULL_TREE;
- tree constructor;
-
- field_list = tree_cons (fields, contentsPtr, field_list);
- fields = TREE_CHAIN (fields);
-
- field_list = tree_cons (fields, high, field_list);
-
- constructor = build_constructor_from_list (unbounded, nreverse (field_list));
- TREE_CONSTANT (constructor) = 0;
- TREE_STATIC (constructor) = 0;
-
- return constructor;
+ set = m2convert_ToWord (location, set);
+ bit = m2convert_ToWord (location, bit);
+ set = m2expr_BuildLSR (location, set, bit, false);
+ return m2expr_build_binary_op (location, code,
+ m2expr_build_binary_op (location,
+ BIT_AND_EXPR, set,
+ m2expr_GetWordOne (location), false),
+ m2expr_GetWordZero (location), FALSE);
}
-/* BuildBinarySetDo if the size of the set is <= TSIZE(WORD) then op1
- := binop(op2, op3) else call m2rtsprocedure(op1, op2, op3). */
+/* BuildIfInSet returns tree (bit IN set). */
-void
-m2expr_BuildBinarySetDo (location_t location, tree settype, tree op1, tree op2,
- tree op3, void (*binop) (location_t, tree, tree, tree,
- tree, bool),
- bool is_op1lvalue, bool is_op2lvalue, bool is_op3lvalue,
- tree nBits, tree unbounded, tree varproc,
- tree leftproc, tree rightproc)
+tree
+m2expr_BuildIfInSet (location_t location, tree set, tree bit)
{
- tree size = m2expr_GetSizeOf (location, settype);
- bool is_const = false;
- bool is_left = false;
-
m2assert_AssertLocation (location);
- ASSERT_BOOL (is_op1lvalue);
- ASSERT_BOOL (is_op2lvalue);
- ASSERT_BOOL (is_op3lvalue);
-
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- (*binop) (location,
- m2treelib_get_rvalue (location, op1, settype, is_op1lvalue),
- m2treelib_get_rvalue (location, op2, settype, is_op2lvalue),
- m2treelib_get_rvalue (location, op3, settype, is_op3lvalue),
- nBits, false);
- else
- {
- tree result;
- tree high = m2expr_BuildSub (
- location,
- m2convert_ToCardinal (
- location,
- m2expr_BuildDivTrunc (
- location, size,
- m2expr_GetSizeOf (location, m2type_GetBitsetType ()),
- false)),
- m2expr_GetCardinalOne (location), false);
-
- /* If op3 is constant then make op3 positive and remember which
- direction we are shifting. */
-
- op3 = m2tree_skip_const_decl (op3);
- if (TREE_CODE (op3) == INTEGER_CST)
- {
- is_const = true;
- if (tree_int_cst_sgn (op3) < 0)
- op3 = m2expr_BuildNegate (location, op3, false);
- else
- is_left = true;
- op3 = m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
- op3, false);
- }
-
- /* These parameters must match the prototypes of the procedures:
- ShiftLeft, ShiftRight, ShiftVal, RotateLeft, RotateRight, RotateVal
- inside gm2-iso/SYSTEM.mod. */
+ return BuildIfBitInSetLower (location, NE_EXPR, set, bit);
+}
- /* Remember we must build the parameters in reverse. */
+/* BuildIfInSet returns tree (NOT (bit IN set)). */
- /* Parameter 4 amount. */
- m2statement_BuildParam (
- location,
- m2convert_BuildConvert (
- location, m2type_GetM2IntegerType (),
- m2treelib_get_rvalue (location, op3,
- m2tree_skip_type_decl (TREE_TYPE (op3)),
- is_op3lvalue),
- false));
+tree
+m2expr_BuildIfNotInSet (location_t location, tree set, tree bit)
+{
+ m2assert_AssertLocation (location);
- /* Parameter 3 nBits. */
- m2statement_BuildParam (
- location,
- m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
- m2expr_FoldAndStrip (nBits), false));
-
- /* Parameter 2 destination set. */
- m2statement_BuildParam (
- location,
- buildUnboundedArrayOf (
- unbounded,
- m2treelib_get_set_address (location, op1, is_op1lvalue), high));
-
- /* Parameter 1 source set. */
- m2statement_BuildParam (
- location,
- buildUnboundedArrayOf (
- unbounded,
- m2treelib_get_set_address (location, op2, is_op2lvalue), high));
-
- /* Now call the appropriate procedure inside SYSTEM.mod. */
- if (is_const)
- if (is_left)
- result = m2statement_BuildProcedureCallTree (location, leftproc,
- NULL_TREE);
- else
- result = m2statement_BuildProcedureCallTree (location, rightproc,
- NULL_TREE);
- else
- result = m2statement_BuildProcedureCallTree (location, varproc,
- NULL_TREE);
- add_stmt (location, result);
- }
+ return BuildIfBitInSetLower (location, EQ_EXPR, set, bit);
}
-/* Print a warning if a constant expression had overflow in folding.
+/* Print a warning if a constant expression caused overflow in folding.
Invoke this function on every expression that the language requires
to be a constant expression. */
@@ -1463,11 +1367,11 @@ m2expr_Build4LogicalOr (location_t location, tree op1, tree op2, tree op3,
tree op4)
{
tree t1 = m2expr_FoldAndStrip (
- m2expr_BuildLogicalOr (location, op1, op2, false));
+ m2expr_BuildLogicalOr (location, op1, op2));
tree t2
- = m2expr_FoldAndStrip (m2expr_BuildLogicalOr (location, t1, op3, false));
+ = m2expr_FoldAndStrip (m2expr_BuildLogicalOr (location, t1, op3));
return m2expr_FoldAndStrip (
- m2expr_BuildLogicalOr (location, t2, op4, false));
+ m2expr_BuildLogicalOr (location, t2, op4));
}
/* checkWholeMultOverflow - check to see whether i * j will overflow
@@ -2697,15 +2601,15 @@ m2expr_BuildNegate (location_t location, tree op1, bool needconvert)
/* BuildSetNegate build a set negate expression and returns the tree. */
tree
-m2expr_BuildSetNegate (location_t location, tree op1, bool needconvert)
+m2expr_BuildSetNegate (location_t location, tree value)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_XOR_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (),
- m2expr_FoldAndStrip (op1), false),
- set_full_complement, needconvert);
+ m2expr_FoldAndStrip (value), false),
+ set_full_complement, false);
}
/* BuildMult build a multiplication tree. */
@@ -2984,73 +2888,67 @@ m2expr_BuildOffset (location_t location, tree record, tree field,
/* BuildLogicalOrAddress build a logical or expressions and return the tree. */
tree
-m2expr_BuildLogicalOrAddress (location_t location, tree op1, tree op2,
- bool needconvert)
+m2expr_BuildLogicalOrAddress (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
- return m2expr_build_binary_op (location, BIT_IOR_EXPR, op1, op2,
- needconvert);
+ return m2expr_build_binary_op (location, BIT_IOR_EXPR, op1, op2, false);
}
/* BuildLogicalOr build a logical or expressions and return the tree. */
tree
-m2expr_BuildLogicalOr (location_t location, tree op1, tree op2,
- bool needconvert)
+m2expr_BuildLogicalOr (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_IOR_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (), op1, false),
m2convert_BuildConvert (location, m2type_GetWordType (), op2, false),
- needconvert);
+ false);
}
/* BuildLogicalAnd build a logical and expression and return the tree. */
tree
-m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2,
- bool needconvert)
+m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_AND_EXPR,
m2convert_BuildConvert (location, m2type_GetWordType (), op1, false),
m2convert_BuildConvert (location, m2type_GetWordType (), op2, false),
- needconvert);
+ false);
}
/* BuildSymmetricalDifference build a logical xor expression and return the
- * tree. */
+ tree. */
tree
-m2expr_BuildSymmetricDifference (location_t location, tree op1, tree op2,
- bool needconvert)
+m2expr_BuildSymmetricDifference (location_t location, tree left, tree right)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_XOR_EXPR,
- m2convert_BuildConvert (location, m2type_GetWordType (), op1, false),
- m2convert_BuildConvert (location, m2type_GetWordType (), op2, false),
- needconvert);
+ m2convert_BuildConvert (location, m2type_GetWordType (), left, false),
+ m2convert_BuildConvert (location, m2type_GetWordType (), right, false),
+ false);
}
-/* BuildLogicalDifference build a logical difference expression and
-return the tree. (op1 and (not op2)). */
+/* BuildLogicalDifference build a logical difference expression tree.
+ Return (left and (not right)). */
tree
-m2expr_BuildLogicalDifference (location_t location, tree op1, tree op2,
- bool needconvert)
+m2expr_BuildLogicalDifference (location_t location, tree left, tree right)
{
m2assert_AssertLocation (location);
return m2expr_build_binary_op (
location, BIT_AND_EXPR,
- m2convert_BuildConvert (location, m2type_GetWordType (), op1, false),
- m2expr_BuildSetNegate (location, op2, needconvert), needconvert);
+ m2convert_BuildConvert (location, m2type_GetWordType (), left, false),
+ m2expr_BuildSetNegate (location, right), false);
}
/* base_type returns the base type of an ordinal subrange, or the
-type itself if it is not a subrange. */
+ type itself if it is not a subrange. */
static tree
base_type (tree type)
@@ -3064,20 +2962,20 @@ base_type (tree type)
return TYPE_MAIN_VARIANT (type);
}
-/* boolean_enum_to_unsigned convert a BOOLEAN_TYPE, t, or
+/* boolean_enum_to_unsigned convert a BOOLEAN_TYPE value or
ENUMERAL_TYPE to an unsigned type. */
static tree
-boolean_enum_to_unsigned (location_t location, tree t)
+boolean_enum_to_unsigned (location_t location, tree value)
{
- tree type = TREE_TYPE (t);
+ tree type = TREE_TYPE (value);
if (TREE_CODE (base_type (type)) == BOOLEAN_TYPE)
- return m2convert_BuildConvert (location, unsigned_type_node, t, false);
+ return m2convert_BuildConvert (location, unsigned_type_node, value, false);
else if (TREE_CODE (base_type (type)) == ENUMERAL_TYPE)
- return m2convert_BuildConvert (location, unsigned_type_node, t, false);
+ return m2convert_BuildConvert (location, unsigned_type_node, value, false);
else
- return t;
+ return value;
}
/* check_for_comparison check to see if, op, is of type, badType. If
@@ -3190,7 +3088,7 @@ m2expr_BuildIsSuperset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildEqualTo (
- location, op2, m2expr_BuildLogicalAnd (location, op1, op2, false));
+ location, op2, m2expr_BuildLogicalAnd (location, op1, op2));
}
/* BuildIsNotSuperset return a tree which computes: op1 & op2 != op2. */
@@ -3200,7 +3098,7 @@ m2expr_BuildIsNotSuperset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildNotEqualTo (
- location, op2, m2expr_BuildLogicalAnd (location, op1, op2, false));
+ location, op2, m2expr_BuildLogicalAnd (location, op1, op2));
}
/* BuildIsSubset return a tree which computes: op1 & op2 == op1. */
@@ -3210,7 +3108,7 @@ m2expr_BuildIsSubset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildEqualTo (
- location, op1, m2expr_BuildLogicalAnd (location, op1, op2, false));
+ location, op1, m2expr_BuildLogicalAnd (location, op1, op2));
}
/* BuildIsNotSubset return a tree which computes: op1 & op2 != op1. */
@@ -3220,224 +3118,22 @@ m2expr_BuildIsNotSubset (location_t location, tree op1, tree op2)
{
m2assert_AssertLocation (location);
return m2expr_BuildNotEqualTo (
- location, op1, m2expr_BuildLogicalAnd (location, op1, op2, false));
+ location, op1, m2expr_BuildLogicalAnd (location, op1, op2));
}
-/* BuildIfConstInVar generates: if constel in varset then goto label. */
+/* BuildIfBitInSetJump build and add a statement tree containing:
+ if (bit in setvalue) goto label. If invertCondition is true then
+ the tree created will take the form:
+ if not (bit in setvalue) goto label. */
void
-m2expr_BuildIfConstInVar (location_t location, tree type, tree varset,
- tree constel, bool is_lvalue, int fieldno,
- char *label)
+m2expr_BuildIfBitInSetJump (location_t location, bool invertCondition,
+ tree setvalue, tree bit, char *label)
{
- tree size = m2expr_GetSizeOf (location, type);
- m2assert_AssertLocation (location);
-
- ASSERT_BOOL (is_lvalue);
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2treelib_do_jump_if_bit (
- location, NE_EXPR,
- m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
- label);
- else
- {
- tree fieldlist = TYPE_FIELDS (type);
- tree field;
-
- for (field = fieldlist; (field != NULL) && (fieldno > 0);
- field = TREE_CHAIN (field))
- fieldno--;
-
- m2treelib_do_jump_if_bit (
- location, NE_EXPR,
- m2treelib_get_set_field_rhs (location, varset, field), constel,
- label);
- }
-}
-
-/* BuildIfConstInVar generates: if not (constel in varset) then goto label. */
-
-void
-m2expr_BuildIfNotConstInVar (location_t location, tree type, tree varset,
- tree constel, bool is_lvalue, int fieldno,
- char *label)
-{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
-
- ASSERT_BOOL (is_lvalue);
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2treelib_do_jump_if_bit (
- location, EQ_EXPR,
- m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
- label);
+ if (invertCondition)
+ m2treelib_do_jump_if_bit (location, NE_EXPR, setvalue, bit, label);
else
- {
- tree fieldlist = TYPE_FIELDS (type);
- tree field;
-
- for (field = fieldlist; (field != NULL) && (fieldno > 0);
- field = TREE_CHAIN (field))
- fieldno--;
-
- m2treelib_do_jump_if_bit (
- location, EQ_EXPR,
- m2treelib_get_set_field_rhs (location, varset, field), constel,
- label);
- }
-}
-
-/* BuildIfVarInVar generates: if varel in varset then goto label. */
-
-void
-m2expr_BuildIfVarInVar (location_t location, tree type, tree varset,
- tree varel, bool is_lvalue, tree low,
- tree high ATTRIBUTE_UNUSED, char *label)
-{
- tree size = m2expr_GetSizeOf (location, type);
- /* Calculate the index from the first bit, ie bit 0 represents low value. */
- tree index = m2expr_BuildSub (
- location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
- varel, false),
- m2convert_BuildConvert (location, m2type_GetIntegerType (), low, false),
- false);
-
- m2assert_AssertLocation (location);
-
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2treelib_do_jump_if_bit (
- location, NE_EXPR,
- m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
- label);
- else
- {
- tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
- /* Which word do we need to fetch? */
- tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
- false));
- /* Calculate the bit in this word. */
- tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
- false));
- tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
- location, word_index,
- m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), false));
-
- /* Calculate the address of the word we are interested in. */
- p1 = m2expr_BuildAddAddress (location,
- m2convert_convertToPtr (location, p1), p2);
-
- /* Fetch the word, extract the bit and test for != 0. */
- m2treelib_do_jump_if_bit (
- location, NE_EXPR,
- m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
- offset_into_word, label);
- }
-}
-
-/* BuildIfNotVarInVar generates: if not (varel in varset) then goto label. */
-
-void
-m2expr_BuildIfNotVarInVar (location_t location, tree type, tree varset,
- tree varel, bool is_lvalue, tree low,
- tree high ATTRIBUTE_UNUSED, char *label)
-{
- tree size = m2expr_GetSizeOf (location, type);
- /* Calculate the index from the first bit, ie bit 0 represents low value. */
- tree index = m2expr_BuildSub (
- location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
- m2expr_FoldAndStrip (varel), false),
- m2convert_BuildConvert (location, m2type_GetIntegerType (),
- m2expr_FoldAndStrip (low), false),
- false);
-
- index = m2expr_FoldAndStrip (index);
- m2assert_AssertLocation (location);
-
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2treelib_do_jump_if_bit (
- location, EQ_EXPR,
- m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
- label);
- else
- {
- tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
- /* Calculate the index from the first bit. */
-
- /* Which word do we need to fetch? */
- tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
- false));
- /* Calculate the bit in this word. */
- tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
- false));
- tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
- location, word_index,
- m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), false));
-
- /* Calculate the address of the word we are interested in. */
- p1 = m2expr_BuildAddAddress (location, p1, p2);
-
- /* Fetch the word, extract the bit and test for == 0. */
- m2treelib_do_jump_if_bit (
- location, EQ_EXPR,
- m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
- offset_into_word, label);
- }
-}
-
-/* BuildForeachWordInSetDoIfExpr foreach word in set, type, compute
- the expression, expr, and if true goto label. */
-
-void
-m2expr_BuildForeachWordInSetDoIfExpr (location_t location, tree type, tree op1,
- tree op2, bool is_op1lvalue,
- bool is_op2lvalue, bool is_op1const,
- bool is_op2const,
- tree (*expr) (location_t, tree, tree),
- char *label)
-{
- tree p1 = m2treelib_get_set_address_if_var (location, op1, is_op1lvalue,
- is_op1const);
- tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
- is_op2const);
- unsigned int fieldNo = 0;
- tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
- tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
-
- m2assert_AssertLocation (location);
- ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op1)) == RECORD_TYPE);
- ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op2)) == RECORD_TYPE);
-
- while (field1 != NULL && field2 != NULL)
- {
- m2statement_DoJump (
- location,
- (*expr) (location,
- m2treelib_get_set_value (location, p1, field1, is_op1const,
- is_op1lvalue, op1, fieldNo),
- m2treelib_get_set_value (location, p2, field2, is_op2const,
- is_op2lvalue, op2, fieldNo)),
- NULL, label);
- fieldNo++;
- field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
- field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
- }
+ m2treelib_do_jump_if_bit (location, EQ_EXPR, setvalue, bit, label);
}
/* BuildIfInRangeGoto returns a tree containing if var is in the
@@ -3450,16 +3146,16 @@ m2expr_BuildIfInRangeGoto (location_t location, tree var, tree low, tree high,
m2assert_AssertLocation (location);
if (m2expr_CompareTrees (low, high) == 0)
- m2statement_DoJump (location, m2expr_BuildEqualTo (location, var, low),
- NULL, label);
+ m2statement_IfExprJump (location, m2expr_BuildEqualTo (location, var, low),
+ label);
else
- m2statement_DoJump (
+ m2statement_IfExprJump (
location,
m2expr_build_binary_op (
location, TRUTH_ANDIF_EXPR,
m2expr_BuildGreaterThanOrEqual (location, var, low),
m2expr_BuildLessThanOrEqual (location, var, high), false),
- NULL, label);
+ label);
}
/* BuildIfNotInRangeGoto returns a tree containing if var is not in
@@ -3472,15 +3168,15 @@ m2expr_BuildIfNotInRangeGoto (location_t location, tree var, tree low,
m2assert_AssertLocation (location);
if (m2expr_CompareTrees (low, high) == 0)
- m2statement_DoJump (location, m2expr_BuildNotEqualTo (location, var, low),
- NULL, label);
+ m2statement_IfExprJump (location, m2expr_BuildNotEqualTo (location, var, low),
+ label);
else
- m2statement_DoJump (
+ m2statement_IfExprJump (
location, m2expr_build_binary_op (
location, TRUTH_ORIF_EXPR,
m2expr_BuildLessThan (location, var, low),
m2expr_BuildGreaterThan (location, var, high), false),
- NULL, label);
+ label);
}
/* BuildArray - returns a tree which accesses array[index] given,
@@ -3829,75 +3525,18 @@ m2expr_BuildCmplx (location_t location, tree type, tree real, tree imag)
return build2 (COMPLEX_EXPR, type, real, imag);
}
-/* BuildBinaryForeachWordDo implements the large set operators. Each
- word of the set can be calculated by binop. This function runs along
- each word of the large set invoking the binop. */
-
void
-m2expr_BuildBinaryForeachWordDo (location_t location, tree type, tree op1,
- tree op2, tree op3,
- tree (*binop) (location_t, tree, tree, bool),
- bool is_op1lvalue, bool is_op2lvalue,
- bool is_op3lvalue, bool is_op1const,
- bool is_op2const, bool is_op3const)
+m2expr_SetAndNarrow (location_t location, tree settype,
+ tree op1, tree op2, tree op3,
+ bool is_op1lvalue, bool is_op2lvalue, bool is_op3lvalue)
{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
-
- ASSERT_BOOL (is_op1lvalue);
- ASSERT_BOOL (is_op2lvalue);
- ASSERT_BOOL (is_op3lvalue);
- ASSERT_BOOL (is_op1const);
- ASSERT_BOOL (is_op2const);
- ASSERT_BOOL (is_op3const);
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_rvalue (location, op1, type, is_op1lvalue),
- (*binop) (
- location, m2treelib_get_rvalue (location, op2, type, is_op2lvalue),
- m2treelib_get_rvalue (location, op3, type, is_op3lvalue), false));
- else
- {
- /* Large set size > TSIZE(WORD). */
-
- tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
- is_op2const);
- tree p3 = m2treelib_get_set_address_if_var (location, op3, is_op3lvalue,
- is_op3const);
- unsigned int fieldNo = 0;
- tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
- tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
- tree field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
-
- if (is_op1const)
- m2linemap_internal_error_at (
- location,
- "not expecting operand1 to be a constant set");
-
- while (field1 != NULL && field2 != NULL && field3 != NULL)
- {
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_set_field_des (location, op1, field1),
- (*binop) (
- location,
- m2treelib_get_set_value (location, p2, field2, is_op2const,
- is_op2lvalue, op2, fieldNo),
- m2treelib_get_set_value (location, p3, field3, is_op3const,
- is_op3lvalue, op3, fieldNo),
- false));
- fieldNo++;
- field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
- field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
- field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
- }
- }
+ m2statement_BuildAssignmentTree (
+ location, m2expr_GetRValue (location, op1, settype, is_op1lvalue),
+ m2expr_BuildLogicalAnd (
+ location, m2expr_GetRValue (location, op2, settype, is_op2lvalue),
+ m2expr_GetRValue (location, op3, settype, is_op3lvalue)));
}
-
/* OverflowZType returns true if the ZTYPE str will exceed the
internal representation. This routine is much faster (at
least 2 orders of magnitude faster) than the char at a time overflow
@@ -4205,6 +3844,12 @@ m2expr_GetPointerOne (location_t location)
return m2convert_convertToPtr (location, integer_one_node);
}
+tree
+m2expr_GetBitsetZero (location_t location)
+{
+ return m2convert_ToBitset (location, integer_zero_node);
+}
+
/* build_set_full_complement return a word size value with all bits
set to one. */
@@ -4224,12 +3869,23 @@ build_set_full_complement (location_t location)
location, m2expr_GetWordOne (location),
m2convert_BuildConvert (location, m2type_GetWordType (),
m2decl_BuildIntegerConstant (i), false),
- false),
- false);
+ false));
}
return value;
}
+/* GetRValue returns the rvalue of expr. The type is the object
+ type to be copied upon indirection. */
+
+tree
+m2expr_GetRValue (location_t location, tree expr, tree type, bool islvalue)
+{
+ if (islvalue)
+ return m2expr_BuildIndirect (location, expr, type);
+ else
+ return expr;
+}
+
/* GetCstInteger return the integer value of the cst tree. */
diff --git a/gcc/m2/gm2-gcc/m2expr.def b/gcc/m2/gm2-gcc/m2expr.def
index a9f5f37280c2..6842724ef8c3 100644
--- a/gcc/m2/gm2-gcc/m2expr.def
+++ b/gcc/m2/gm2-gcc/m2expr.def
@@ -19,7 +19,7 @@ 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" m2expr ;
+DEFINITION MODULE m2expr ;
FROM gcctypes IMPORT location_t, tree ;
FROM CDataTypes IMPORT CharStar, ConstCharStar ;
@@ -92,6 +92,9 @@ PROCEDURE GetCardinalOne (location: location_t) : tree ;
PROCEDURE GetCardinalZero (location: location_t) : tree ;
+PROCEDURE GetBitsetZero (location: location_t) : tree ;
+
+
PROCEDURE GetSizeOfInBits (type: tree) : tree ;
@@ -365,7 +368,7 @@ PROCEDURE BuildNegateCheck (location: location_t; arg, lowest, min, max: tree) :
BuildSetNegate - builds a set negate expression and returns the tree.
*)
-PROCEDURE BuildSetNegate (location: location_t; op1: tree; needconvert: BOOLEAN) : tree ;
+PROCEDURE BuildSetNegate (location: location_t; op1: tree) : tree ;
(*
@@ -421,27 +424,32 @@ PROCEDURE BuildLogicalOrAddress (location: location_t; op1: tree; op2: tree; nee
BuildLogicalOr - build a logical or expressions and return the tree.
*)
-PROCEDURE BuildLogicalOr (location: location_t; op1: tree; op2: tree; needconvert: BOOLEAN) : tree ;
+PROCEDURE BuildLogicalOr (location: location_t; op1: tree; op2: tree) : tree ;
(*
BuildLogicalAnd - build a logical and expression and return the tree.
*)
-PROCEDURE BuildLogicalAnd (location: location_t; op1: tree; op2: tree; needconvert: BOOLEAN) : tree ;
-
+PROCEDURE BuildLogicalAnd (location: location_t; op1: tree; op2: tree) : tree ;
-PROCEDURE BuildSymmetricDifference (location: location_t; op1: tree; op2: tree; needconvert: BOOLEAN) : tree ;
+PROCEDURE BuildSymmetricDifference (location: location_t; op1: tree; op2: tree) : tree ;
(*
- BuildLogicalDifference - build a logical difference expression and
- return the tree.
- (op1 and (not op2))
+ BuildLogicalDifference - build a logical difference expression tree.
+ Return (left and (not right)).
*)
-PROCEDURE BuildLogicalDifference (location: location_t; op1: tree; op2: tree; needconvert: BOOLEAN) : tree ;
+PROCEDURE BuildLogicalDifference (location: location_t;
+ left, right: tree) : tree ;
+
+
+PROCEDURE BuildIfInSet (location: location_t; set, bit: tree) : tree ;
+
+
+PROCEDURE BuildIfNotInSet (location: location_t; set, bit: tree) : tree ;
(*
@@ -473,14 +481,17 @@ PROCEDURE BuildGreaterThanOrEqual (location: location_t; op1: tree; op2: tree) :
(*
- BuildEqualTo - return a tree which computes =
+ BuildEqualTo - return a tree which computes (left = right).
*)
-PROCEDURE BuildEqualTo (location: location_t; op1: tree; op2: tree) : tree ;
+PROCEDURE BuildEqualTo (location: location_t; left, right: tree) : tree ;
+(*
+ BuildNotEqualTo - return a tree which computes (left # right).
+*)
-PROCEDURE BuildNotEqualTo (location: location_t; op1: tree; op2: tree) : tree ;
+PROCEDURE BuildNotEqualTo (location: location_t; left, right: tree) : tree ;
(*
@@ -675,37 +686,6 @@ PROCEDURE BuildIm (op1: tree) : tree ;
PROCEDURE BuildCmplx (location: location_t; type: tree; real: tree; imag: tree) : tree ;
-(*
- BuildBinaryForeachWordDo - provides the large set operators. Each word
- (or less) of the set can be calculated by binop.
- This procedure runs along each word of the
- large set invoking the binop.
-*)
-
-PROCEDURE BuildBinaryForeachWordDo (location: location_t;
- type, op1, op2, op3: tree;
- binop: BuildBinProcedure;
- is_op1lvalue,
- is_op2lvalue,
- is_op3lvalue,
- is_op1_const,
- is_op2_const,
- is_op3_const: BOOLEAN) ;
-
-(*
- BuildBinarySetDo - if the size of the set is <= TSIZE(WORD) then
- op1 := binop(op2, op3)
- else
- call m2rtsprocedure(op1, op2, op3)
-*)
-
-PROCEDURE BuildBinarySetDo (location: location_t;
- settype, op1, op2, op3: tree;
- binop: BuildSetProcedure;
- is_op1lvalue, is_op2lvalue, is_op3lvalue: BOOLEAN;
- nBits, unbounded: tree;
- varproc, leftproc, rightproc: tree) ;
-
(*
ConstantExpressionWarning - issue a warning if the constant has overflowed.
*)
@@ -744,6 +724,14 @@ PROCEDURE OverflowZType (location: location_t;
PROCEDURE BuildCondIfExpression (condition, type, left, right: tree) : tree ;
+(*
+ GetRValue - returns the rvalue of expr. The type is the object
+ type to be copied upon indirection.
+*)
+
+PROCEDURE GetRValue (location: location_t; expr, type: tree;
+ islvalue: BOOLEAN) : tree ;
+
(*
BuildSystemTBitSize - return the minimum number of bits to represent type.
diff --git a/gcc/m2/gm2-gcc/m2expr.h b/gcc/m2/gm2-gcc/m2expr.h
index d4771e3266fd..20bfcea94553 100644
--- a/gcc/m2/gm2-gcc/m2expr.h
+++ b/gcc/m2/gm2-gcc/m2expr.h
@@ -40,11 +40,6 @@ EXTERN char m2expr_CSTIntToChar (tree t);
EXTERN char *m2expr_CSTIntToString (tree t);
EXTERN bool m2expr_StrToWideInt (location_t location, const char *str, unsigned int base,
widest_int &wval, bool issueError);
-EXTERN void m2expr_BuildBinaryForeachWordDo (
- location_t location, tree type, tree op1, tree op2, tree op3,
- tree (*binop) (location_t, tree, tree, bool), bool is_op1lvalue,
- bool is_op2lvalue, bool is_op3lvalue, bool is_op1const, bool is_op2const,
- bool is_op3const);
EXTERN tree m2expr_BuildCmplx (location_t location, tree type, tree real,
tree imag);
EXTERN tree m2expr_BuildIm (tree op1);
@@ -65,25 +60,6 @@ EXTERN void m2expr_BuildIfNotInRangeGoto (location_t location, tree var,
tree low, tree high, char *label);
EXTERN void m2expr_BuildIfInRangeGoto (location_t location, tree var, tree low,
tree high, char *label);
-EXTERN void m2expr_BuildForeachWordInSetDoIfExpr (
- location_t location, tree type, tree op1, tree op2, bool is_op1lvalue,
- bool is_op2lvalue, bool is_op1const, bool is_op2const,
- tree (*expr) (location_t, tree, tree), char *label);
-EXTERN void m2expr_BuildIfNotVarInVar (location_t location, tree type,
- tree varset, tree varel, bool is_lvalue,
- tree low, tree high ATTRIBUTE_UNUSED,
- char *label);
-EXTERN void m2expr_BuildIfVarInVar (location_t location, tree type,
- tree varset, tree varel, bool is_lvalue,
- tree low, tree high ATTRIBUTE_UNUSED,
- char *label);
-EXTERN void m2expr_BuildIfNotConstInVar (location_t location, tree type,
- tree varset, tree constel,
- bool is_lvalue, int fieldno,
- char *label);
-EXTERN void m2expr_BuildIfConstInVar (location_t location, tree type,
- tree varset, tree constel, bool is_lvalue,
- int fieldno, char *label);
EXTERN tree m2expr_BuildIsNotSubset (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildIsSubset (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildIsNotSuperset (location_t location, tree op1,
@@ -97,16 +73,11 @@ EXTERN tree m2expr_BuildLessThanOrEqual (location_t location, tree op1,
tree op2);
EXTERN tree m2expr_BuildGreaterThan (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildLessThan (location_t location, tree op1, tree op2);
-EXTERN tree m2expr_BuildLogicalDifference (location_t location, tree op1,
- tree op2, bool needconvert);
-EXTERN tree m2expr_BuildSymmetricDifference (location_t location, tree op1,
- tree op2, bool needconvert);
-EXTERN tree m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2,
- bool needconvert);
-EXTERN tree m2expr_BuildLogicalOr (location_t location, tree op1, tree op2,
- bool needconvert);
-EXTERN tree m2expr_BuildLogicalOrAddress (location_t location, tree op1,
- tree op2, bool needconvert);
+EXTERN tree m2expr_BuildLogicalDifference (location_t location, tree op1, tree op2);
+EXTERN tree m2expr_BuildSymmetricDifference (location_t location, tree op1, tree op2);
+EXTERN tree m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2);
+EXTERN tree m2expr_BuildLogicalOr (location_t location, tree op1, tree op2);
+EXTERN tree m2expr_BuildLogicalOrAddress (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildOffset (location_t location, tree record, tree field,
bool needconvert ATTRIBUTE_UNUSED);
EXTERN tree m2expr_BuildOffset1 (location_t location, tree field,
@@ -115,8 +86,7 @@ EXTERN tree m2expr_BuildAddr (location_t location, tree op1, bool needconvert);
EXTERN tree m2expr_BuildSize (location_t location, tree op1,
bool needconvert ATTRIBUTE_UNUSED);
EXTERN tree m2expr_BuildTBitSize (location_t location, tree type);
-EXTERN tree m2expr_BuildSetNegate (location_t location, tree op1,
- bool needconvert);
+EXTERN tree m2expr_BuildSetNegate (location_t location, tree value);
EXTERN tree m2expr_BuildNegate (location_t location, tree op1,
bool needconvert);
EXTERN tree m2expr_BuildNegateCheck (location_t location, tree arg,
@@ -224,6 +194,7 @@ EXTERN tree m2expr_GetWordZero (location_t location);
EXTERN tree m2expr_GetWordOne (location_t location);
EXTERN tree m2expr_GetPointerZero (location_t location);
EXTERN tree m2expr_GetPointerOne (location_t location);
+EXTERN tree m2expr_GetBitsetZero (location_t location);
EXTERN int m2expr_CompareTrees (tree e1, tree e2);
EXTERN tree m2expr_build_unary_op (location_t location ATTRIBUTE_UNUSED,
@@ -246,6 +217,10 @@ EXTERN tree m2expr_calcNbits (location_t location, tree min, tree max);
EXTERN bool m2expr_OverflowZType (location_t location, const char *str,
unsigned int base, bool issueError);
EXTERN tree m2expr_BuildSystemTBitSize (location_t location, tree type);
+EXTERN tree m2expr_GetRValue (location_t location, tree expr, tree type, bool islvalue);
+EXTERN tree m2expr_BuildIfInSet (location_t location, tree set, tree bit);
+EXTERN tree m2expr_BuildIfNotInSet (location_t location, tree set, tree bit);
+
EXTERN void m2expr_init (location_t location);
#undef EXTERN
diff --git a/gcc/m2/gm2-gcc/m2options.h b/gcc/m2/gm2-gcc/m2options.h
index 041de26cf8dd..273906baba66 100644
--- a/gcc/m2/gm2-gcc/m2options.h
+++ b/gcc/m2/gm2-gcc/m2options.h
@@ -168,6 +168,10 @@ EXTERN char *M2Options_GetM2DumpFilter (void);
EXTERN void M2Options_SetM2DebugTraceFilter (bool value, const char *arg);
EXTERN bool M2Options_SetM2Dump (bool value, const char *arg);
EXTERN bool M2Options_GetDumpGimple (void);
+EXTERN void M2Options_SetTimeReport (bool value);
+EXTERN void M2Options_SetMemReport (bool value);
+EXTERN void M2Options_SetWideset (bool value);
+EXTERN bool M2Options_GetWideset (void);
EXTERN void M2Options_SetStrictTypeAssignment (bool value);
EXTERN void M2Options_SetStrictTypeReason (bool value);
diff --git a/gcc/m2/gm2-gcc/m2pp.cc b/gcc/m2/gm2-gcc/m2pp.cc
index 7d4adb8ff71f..e23ad529ab31 100644
--- a/gcc/m2/gm2-gcc/m2pp.cc
+++ b/gcc/m2/gm2-gcc/m2pp.cc
@@ -1961,6 +1961,22 @@ m2pp_binary_function (pretty *s, tree t, const char *funcname)
m2pp_print (s, ")");
}
+static void
+m2pp_shiftrotate_expr (pretty *s, tree t, const char *op)
+{
+ tree left = TREE_OPERAND (t, 0);
+ tree right = TREE_OPERAND (t, 1);
+ m2pp_print (s, "(");
+ m2pp_expression (s, left);
+ m2pp_print (s, ")");
+ m2pp_needspace (s);
+ m2pp_print (s, op);
+ m2pp_needspace (s);
+ m2pp_print (s, "(");
+ m2pp_expression (s, right);
+ m2pp_print (s, ")");
+}
+
/* m2pp_simple_expression handle GCC expression tree. */
static void
@@ -2117,6 +2133,12 @@ m2pp_simple_expression (pretty *s, tree t)
case TRUTH_ORIF_EXPR:
m2pp_truth_expr (s, t, "OR");
break;
+ case LSHIFT_EXPR:
+ m2pp_shiftrotate_expr (s, t, "<<");
+ break;
+ case RSHIFT_EXPR:
+ m2pp_shiftrotate_expr (s, t, ">>");
+ break;
case LROTATE_EXPR:
m2pp_binary_function (s, t, "LROTATE");
break;
diff --git a/gcc/m2/gm2-gcc/m2statement.cc b/gcc/m2/gm2-gcc/m2statement.cc
index 795298435e72..8696bf80616b 100644
--- a/gcc/m2/gm2-gcc/m2statement.cc
+++ b/gcc/m2/gm2-gcc/m2statement.cc
@@ -44,7 +44,7 @@ static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we
static GTY (()) tree last_function = NULL_TREE;
-/* BuildStartFunctionCode - generate function entry code. */
+/* BuildStartFunctionCode generate function entry code. */
void
m2statement_BuildStartFunctionCode (location_t location, tree fndecl,
@@ -86,7 +86,7 @@ m2statement_BuildStartFunctionCode (location_t location, tree fndecl,
DECL_DECLARED_INLINE_P (fndecl) = 0; /* isinline; */
}
-/* BuildEndFunctionCode - generates the function epilogue. */
+/* BuildEndFunctionCode generates the function epilogue. */
void
m2statement_BuildEndFunctionCode (location_t location, tree fndecl, bool nested)
@@ -123,7 +123,7 @@ m2statement_BuildEndFunctionCode (location_t location, tree fndecl, bool nested)
current_function_decl = NULL;
}
-/* BuildPushFunctionContext - pushes the current function context.
+/* BuildPushFunctionContext pushes the current function context.
Maps onto push_function_context in ../function.cc. */
void
@@ -132,7 +132,7 @@ m2statement_BuildPushFunctionContext (void)
push_function_context ();
}
-/* BuildPopFunctionContext - pops the current function context. Maps
+/* BuildPopFunctionContext pops the current function context. Maps
onto pop_function_context in ../function.cc. */
void
@@ -194,7 +194,7 @@ copy_array (location_t location, tree left, tree right)
idx = m2convert_BuildConvert (location, index_type, idx, false);
tree array_ref = build4_loc (location, ARRAY_REF, elt_type, left,
idx, low_indice, NULL_TREE);
- m2statement_CopyByField (location, array_ref, value);
+ m2statement_CopyByField (location, array_ref, value);
}
}
@@ -253,7 +253,7 @@ CopyByField_Lower (location_t location,
else if (right_code == STRING_CST)
copy_strncpy (location, left, right);
else
- m2statement_BuildAssignmentStatement (location, left, right);
+ m2statement_BuildAssignmentStatement (location, left, right);
}
/* CopyByField recursively checks each field to ensure GCC
@@ -321,7 +321,7 @@ m2statement_BuildGoto (location_t location, char *name)
add_stmt (location, build1 (GOTO_EXPR, void_type_node, label));
}
-/* DeclareLabel - create a label, name. */
+/* DeclareLabel create a label, name. */
void
m2statement_DeclareLabel (location_t location, char *name)
@@ -332,7 +332,7 @@ m2statement_DeclareLabel (location_t location, char *name)
add_stmt (location, build1 (LABEL_EXPR, void_type_node, label));
}
-/* BuildParam - build a list of parameters, ready for a subsequent
+/* BuildParam build a list of parameters, ready for a subsequent
procedure call. */
void
@@ -347,7 +347,7 @@ m2statement_BuildParam (location_t location, tree param)
param_list = chainon (build_tree_list (NULL_TREE, param), param_list);
}
-/* nCount - return the number of chained tree nodes in list, t. */
+/* nCount return the number of chained tree nodes in list, t. */
static int
nCount (tree t)
@@ -362,7 +362,7 @@ nCount (tree t)
return i;
}
-/* BuildProcedureCallTree - creates a procedure call from a procedure
+/* BuildProcedureCallTree creates a procedure call from a procedure
and parameter list and the return type, rettype. */
tree
@@ -419,7 +419,7 @@ m2statement_BuildProcedureCallTree (location_t location, tree procedure,
}
}
-/* BuildIndirectProcedureCallTree - creates a procedure call from a
+/* BuildIndirectProcedureCallTree creates a procedure call from a
procedure and parameter list and the return type, rettype. */
tree
@@ -486,8 +486,8 @@ m2statement_BuildBuiltinCallTree (tree func)
}
-/* BuildFunctValue - generates code for value :=
- last_function(foobar); */
+/* BuildFunctValue generates code for
+ value := last_function (foobar). */
tree
m2statement_BuildFunctValue (location_t location, tree value)
@@ -505,10 +505,9 @@ m2statement_BuildFunctValue (location_t location, tree value)
TREE_USED (value) = true;
last_function = NULL_TREE;
return assign;
- // return m2statement_BuildAssignmentTree (location, value, assign);
}
-/* BuildCall2 - builds a tree representing: function (arg1, arg2). */
+/* BuildCall2 builds a tree representing: function (arg1, arg2). */
tree
m2statement_BuildCall2 (location_t location, tree function, tree rettype,
@@ -522,8 +521,7 @@ m2statement_BuildCall2 (location_t location, tree function, tree rettype,
return m2statement_BuildProcedureCallTree (location, function, rettype);
}
-/* BuildCall3 - builds a tree representing: function (arg1, arg2,
- arg3). */
+/* BuildCall3 builds a tree representing: function (arg1, arg2, arg3). */
tree
m2statement_BuildCall3 (location_t location, tree function, tree rettype,
@@ -538,7 +536,7 @@ m2statement_BuildCall3 (location_t location, tree function, tree rettype,
return m2statement_BuildProcedureCallTree (location, function, rettype);
}
-/* BuildFunctionCallTree - creates a procedure function call from
+/* BuildFunctionCallTree creates a procedure function call from
a procedure and parameter list and the return type, rettype.
No tree is returned as the tree is held in the last_function global
variable. It is expected the BuildFunctValue is to be called after
@@ -551,7 +549,7 @@ m2statement_BuildFunctionCallTree (location_t location, tree procedure,
m2statement_BuildProcedureCallTree (location, procedure, rettype);
}
-/* SetLastFunction - assigns last_function to, t. */
+/* SetLastFunction assigns last_function to, t. */
void
m2statement_SetLastFunction (tree t)
@@ -559,7 +557,7 @@ m2statement_SetLastFunction (tree t)
last_function = t;
}
-/* SetParamList - assigns param_list to, t. */
+/* SetParamList assigns param_list to, t. */
void
m2statement_SetParamList (tree t)
@@ -567,7 +565,7 @@ m2statement_SetParamList (tree t)
param_list = t;
}
-/* GetLastFunction - returns, last_function. */
+/* GetLastFunction returns, last_function. */
tree
m2statement_GetLastFunction (void)
@@ -575,7 +573,7 @@ m2statement_GetLastFunction (void)
return last_function;
}
-/* GetParamList - returns, param_list. */
+/* GetParamList returns, param_list. */
tree
m2statement_GetParamList (void)
@@ -583,7 +581,7 @@ m2statement_GetParamList (void)
return param_list;
}
-/* GetCurrentFunction - returns the current_function. */
+/* GetCurrentFunction returns the current_function. */
tree
m2statement_GetCurrentFunction (void)
@@ -591,7 +589,7 @@ m2statement_GetCurrentFunction (void)
return current_function_decl;
}
-/* GetParamTree - return parameter, i. */
+/* GetParamTree return parameter, i. */
tree
m2statement_GetParamTree (tree call, unsigned int i)
@@ -599,7 +597,7 @@ m2statement_GetParamTree (tree call, unsigned int i)
return CALL_EXPR_ARG (call, i);
}
-/* BuildTryFinally - returns a TRY_FINALL_EXPR with the call and
+/* BuildTryFinally returns a TRY_FINALL_EXPR with the call and
cleanups attached. */
tree
@@ -608,7 +606,7 @@ m2statement_BuildTryFinally (location_t location, tree call, tree cleanups)
return build_stmt (location, TRY_FINALLY_EXPR, call, cleanups);
}
-/* BuildCleanUp - return a CLEANUP_POINT_EXPR which will clobber,
+/* BuildCleanUp return a CLEANUP_POINT_EXPR which will clobber,
param. */
tree
@@ -619,7 +617,7 @@ m2statement_BuildCleanUp (tree param)
return build2 (MODIFY_EXPR, TREE_TYPE (param), param, clobber);
}
-/* BuildAsm - generates an inline assembler instruction. */
+/* BuildAsm generates an inline assembler instruction. */
void
m2statement_BuildAsm (location_t location, tree instr, bool isVolatile,
@@ -640,298 +638,7 @@ m2statement_BuildAsm (location_t location, tree instr, bool isVolatile,
add_stmt (location, args);
}
-/* BuildUnaryForeachWordDo - provides the large set operators. Each
- word (or less) of the set can be calculated by unop. This
- procedure runs along each word of the large set invoking the unop. */
-
-void
-m2statement_BuildUnaryForeachWordDo (location_t location, tree type, tree op1,
- tree op2,
- tree (*unop) (location_t, tree, bool),
- bool is_op1lvalue, bool is_op2lvalue,
- bool is_op1const, bool is_op2const)
-{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
- ASSERT_BOOL (is_op1lvalue);
- ASSERT_BOOL (is_op2lvalue);
- ASSERT_BOOL (is_op1const);
- ASSERT_BOOL (is_op2const);
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_rvalue (location, op1, type, is_op1lvalue),
- (*unop) (location,
- m2treelib_get_rvalue (location, op2, type, is_op2lvalue),
- false));
- else
- {
- /* Large set size > TSIZE(WORD). */
- unsigned int fieldNo = 0;
- tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
- tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
-
- if (is_op1const)
- error ("internal error: not expecting operand1 to be a constant set");
-
- while (field1 != NULL && field2 != NULL)
- {
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_set_field_des (location, op1, field1),
- (*unop) (location,
- m2treelib_get_set_field_rhs (location, op2, field2),
- false));
- fieldNo++;
- field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
- field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
- }
- }
-}
-
-/* BuildExcludeVarConst - builds the EXCL(op1, 1<<op2) operation for
- a small sets. Large sets call this routine to exclude the bit in
- the particular word. op2 is a constant. */
-
-void
-m2statement_BuildExcludeVarConst (location_t location, tree type, tree op1,
- tree op2, bool is_lvalue, int fieldno)
-{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
- ASSERT_BOOL (is_lvalue);
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- {
- /* Small set size <= TSIZE(WORD). */
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
- m2expr_BuildLogicalAnd (
- location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
- m2expr_BuildSetNegate (
- location,
- m2expr_BuildLSL (location, m2expr_GetWordOne (location), op2,
- false),
- false),
- false));
- }
- else
- {
- tree fieldlist = TYPE_FIELDS (type);
- tree field;
-
- for (field = fieldlist; (field != NULL) && (fieldno > 0);
- field = TREE_CHAIN (field))
- fieldno--;
-
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_set_field_des (location, op1, field),
- m2expr_BuildLogicalAnd (
- location, m2treelib_get_set_field_rhs (location, op1, field),
- m2expr_BuildSetNegate (
- location,
- m2expr_BuildLSL (location, m2expr_GetWordOne (location), op2,
- false),
- false),
- false));
- }
-}
-
-/* BuildExcludeVarVar - builds the EXCL(varset, 1<<varel) operation
- for a small and large sets. varel is a variable. */
-
-void
-m2statement_BuildExcludeVarVar (location_t location, tree type, tree varset,
- tree varel, bool is_lvalue, tree low)
-{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
- ASSERT_BOOL (is_lvalue);
- /* Calculate the index from the first bit, ie bit 0 represents low value. */
- tree index
- = m2expr_BuildSub (location, m2convert_ToInteger (location, varel),
- m2convert_ToInteger (location, low), false);
-
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_rvalue (location, varset, type, is_lvalue),
- m2expr_BuildLogicalAnd (
- location, m2treelib_get_rvalue (location, varset, type, is_lvalue),
- m2expr_BuildSetNegate (
- location,
- m2expr_BuildLSL (location, m2expr_GetWordOne (location),
- m2convert_ToWord (location, index), false),
- false),
- false));
- else
- {
- tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
- /* Calculate the index from the first bit. */
-
- /* Which word do we need to fetch? */
- tree word_index = m2expr_BuildDivTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE), false);
- /* Calculate the bit in this word. */
- tree offset_into_word = m2expr_BuildModTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE), false);
-
- tree v1;
-
- /* Calculate the address of the word we are interested in. */
- p1 = m2expr_BuildAddAddress (
- location, m2convert_convertToPtr (location, p1),
- m2expr_BuildMult (
- location, word_index,
- m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT),
- false));
-
- v1 = m2expr_BuildLogicalAnd (
- location,
- m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
- m2expr_BuildSetNegate (
- location,
- m2expr_BuildLSL (location, m2expr_GetWordOne (location),
- m2convert_ToWord (location, offset_into_word),
- false),
- false),
- false);
-
- /* Set bit offset_into_word within the word pointer at by p1. */
- m2statement_BuildAssignmentTree (
- location,
- m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
- m2convert_ToBitset (location, v1));
- }
-}
-
-/* BuildIncludeVarConst - builds the INCL(op1, 1<<op2) operation for
- a small sets. Large sets call this routine to include the bit in
- the particular word. op2 is a constant. */
-
-void
-m2statement_BuildIncludeVarConst (location_t location, tree type, tree op1,
- tree op2, bool is_lvalue, int fieldno)
-{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
- ASSERT_BOOL (is_lvalue);
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- {
- /* Small set size <= TSIZE(WORD). */
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
- m2expr_BuildLogicalOr (
- location, m2treelib_get_rvalue (location, op1, type, is_lvalue),
- m2expr_BuildLSL (location, m2expr_GetWordOne (location),
- m2convert_ToWord (location, op2), false),
- false));
- }
- else
- {
- tree fieldlist = TYPE_FIELDS (type);
- tree field;
-
- for (field = fieldlist; (field != NULL) && (fieldno > 0);
- field = TREE_CHAIN (field))
- fieldno--;
-
- m2statement_BuildAssignmentTree (
- location,
- /* Would like to use: m2expr_BuildComponentRef (location, p, field)
- but strangely we have to take the address of the field and
- dereference it to satify the gimplifier. See
- testsuite/gm2/pim/pass/timeio?.mod for testcases. */
- m2treelib_get_set_field_des (location, op1, field),
- m2expr_BuildLogicalOr (
- location, m2treelib_get_set_field_rhs (location, op1, field),
- m2expr_BuildLSL (location, m2expr_GetWordOne (location),
- m2convert_ToWord (location, op2), false),
- false));
- }
-}
-
-/* BuildIncludeVarVar - builds the INCL(varset, 1<<varel) operation
- for a small and large sets. op2 is a variable. */
-
-void
-m2statement_BuildIncludeVarVar (location_t location, tree type, tree varset,
- tree varel, bool is_lvalue, tree low)
-{
- tree size = m2expr_GetSizeOf (location, type);
-
- m2assert_AssertLocation (location);
- ASSERT_BOOL (is_lvalue);
- /* Calculate the index from the first bit, ie bit 0 represents low value. */
- tree index
- = m2expr_BuildSub (location, m2convert_ToInteger (location, varel),
- m2convert_ToInteger (location, low), false);
- tree indexw = m2convert_ToWord (location, index);
-
- if (m2expr_CompareTrees (
- size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
- <= 0)
- /* Small set size <= TSIZE(WORD). */
- m2statement_BuildAssignmentTree (
- location, m2treelib_get_rvalue (location, varset, type, is_lvalue),
- m2convert_ToBitset (
- location,
- m2expr_BuildLogicalOr (
- location,
- m2treelib_get_rvalue (location, varset, type, is_lvalue),
- m2expr_BuildLSL (location, m2expr_GetWordOne (location),
- indexw, false),
- false)));
- else
- {
- tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
- /* Which word do we need to fetch? */
- tree word_index = m2expr_BuildDivTrunc (
- location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE), false);
- /* Calculate the bit in this word. */
- tree offset_into_word = m2convert_BuildConvert (
- location, m2type_GetWordType (),
- m2expr_BuildModTrunc (location, index,
- m2decl_BuildIntegerConstant (SET_WORD_SIZE),
- false),
- false);
- tree v1;
-
- /* Calculate the address of the word we are interested in. */
- p1 = m2expr_BuildAddAddress (
- location, m2convert_convertToPtr (location, p1),
- m2expr_BuildMult (
- location, word_index,
- m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT),
- false));
- v1 = m2expr_BuildLogicalOr (
- location,
- m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
- m2convert_ToBitset (location,
- m2expr_BuildLSL (location,
- m2expr_GetWordOne (location),
- offset_into_word, false)),
- false);
-
- /* Set bit offset_into_word within the word pointer at by p1. */
- m2statement_BuildAssignmentTree (
- location,
- m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
- m2convert_ToBitset (location, v1));
- }
-}
-
-/* BuildStart - creates a module initialization function. We make
+/* BuildStart creates a module initialization function. We make
this function public if it is not an inner module. The linker
will create a call list for all linked modules which determines
the initialization sequence for all modules. */
@@ -967,7 +674,7 @@ m2statement_BuildStart (location_t location, char *name, bool inner_module)
return fndecl;
}
-/* BuildEnd - complete the initialization function for this module. */
+/* BuildEnd complete the initialization function for this module. */
void
m2statement_BuildEnd (location_t location, tree fndecl, bool nested)
@@ -977,7 +684,7 @@ m2statement_BuildEnd (location_t location, tree fndecl, bool nested)
set_cfun (NULL);
}
-/* BuildCallInner - call the inner module function. It has no
+/* BuildCallInner call the inner module function. It has no
parameters and no return value. */
void
@@ -990,7 +697,7 @@ m2statement_BuildCallInner (location_t location, tree fndecl)
}
-/* BuildIfThenDoEnd - returns a tree which will only execute
+/* BuildIfThenDoEnd returns a tree which will only execute
statement, s, if, condition, is true. */
tree
@@ -1003,7 +710,7 @@ m2statement_BuildIfThenDoEnd (tree condition, tree then_block)
alloc_stmt_list ());
}
-/* BuildIfThenElseEnd - returns a tree which will execute then_block
+/* BuildIfThenElseEnd returns a tree which will execute then_block
or else_block depending upon, condition. */
tree
@@ -1017,8 +724,8 @@ m2statement_BuildIfThenElseEnd (tree condition, tree then_block,
else_block);
}
-/* BuildReturnValueCode - generates the code associated with: RETURN(
- value ) */
+/* BuildReturnValueCode generates the code associated with:
+ RETURN ( value ). */
void
m2statement_BuildReturnValueCode (location_t location, tree fndecl, tree value)
@@ -1037,41 +744,45 @@ m2statement_BuildReturnValueCode (location_t location, tree fndecl, tree value)
add_stmt (location, ret_stmt);
}
-/* DoJump - jump to the appropriate label depending whether result of
- the expression is true or false. */
+/* IfExprJump if expr then jump to the label. */
void
-m2statement_DoJump (location_t location, tree exp, char *falselabel,
- char *truelabel)
+m2statement_IfExprJump (location_t location, tree exp, char *label)
{
- tree c = NULL_TREE;
+ tree if_jump;
m2assert_AssertLocation (location);
if (TREE_CODE (TREE_TYPE (exp)) != BOOLEAN_TYPE)
exp = convert_loc (location, m2type_GetBooleanType (), exp);
- if ((falselabel != NULL) && (truelabel == NULL))
- {
- m2block_push_statement_list (m2block_begin_statement_list ());
+ m2block_push_statement_list (m2block_begin_statement_list ());
+ m2statement_BuildGoto (location, label);
+ if_jump = build3 (COND_EXPR, void_type_node, exp,
+ m2block_pop_statement_list (),
+ alloc_stmt_list ());
+ add_stmt (location, if_jump);
+}
- m2statement_BuildGoto (location, falselabel);
- c = build3 (COND_EXPR, void_type_node, exp,
- m2block_pop_statement_list (),
- alloc_stmt_list ());
- }
- else if ((falselabel == NULL) && (truelabel != NULL))
- {
- m2block_push_statement_list (m2block_begin_statement_list ());
- m2statement_BuildGoto (location, truelabel);
- c = build3 (COND_EXPR, void_type_node, exp,
- m2block_pop_statement_list (),
- alloc_stmt_list ());
- }
- else
- error_at (location, "expecting one and only one label to be declared");
- if (c != NULL_TREE)
- add_stmt (location, c);
+/* IfBitInSetJump if bit in set jump to label. */
+
+void
+m2statement_IfBitInSetJump (location_t location, bool invertCondition,
+ tree setvalue, tree bit, char *label)
+{
+ tree condition;
+
+ condition = m2expr_BuildNotEqualTo (location,
+ m2expr_BuildLogicalAnd (location,
+ m2expr_BuildLSL (location,
+ m2expr_GetWordOne (location),
+ bit, false),
+ setvalue),
+ m2expr_GetWordZero (location)) ;
+ if (invertCondition)
+ condition = m2expr_BuildEqualTo (location, condition,
+ m2type_GetBooleanFalse ());
+ m2statement_IfExprJump (location, condition, label);
}
#include "gt-m2-m2statement.h"
diff --git a/gcc/m2/gm2-gcc/m2statement.def b/gcc/m2/gm2-gcc/m2statement.def
index ffaf69784eee..fbb578f40aa6 100644
--- a/gcc/m2/gm2-gcc/m2statement.def
+++ b/gcc/m2/gm2-gcc/m2statement.def
@@ -24,14 +24,14 @@ DEFINITION MODULE FOR "C" m2statement ;
FROM gcctypes IMPORT location_t, tree ;
FROM CDataTypes IMPORT CharStar ;
FROM m2expr IMPORT BuildUnarySetFunction ;
+FROM SYSTEM IMPORT ADDRESS ;
(*
- DoJump - jump to the appropriate label depending whether
- result of the expression is TRUE or FALSE.
+ IfExprJump - if expr then jump to the label.
*)
-PROCEDURE DoJump (location: location_t; exp: tree; falselabel, truelabel: CharStar) ;
+PROCEDURE IfExprJump (location: location_t; exp: tree; label: ADDRESS) ;
(*
@@ -221,19 +221,6 @@ PROCEDURE BuildAsm (location: location_t; instr: tree;
inputs: tree; outputs: tree; trash: tree; labels: tree) ;
-(*
- BuildUnaryForeachWordDo - provides the large set operators.
- Each word (or less) of the set can be
- calculated by unop.
- This procedure iterates over each word
- of the large set invoking the unop.
-*)
-
-PROCEDURE BuildUnaryForeachWordDo (location: location_t; type: tree; op1: tree; op2: tree;
- unop: BuildUnarySetFunction;
- is_op1lvalue, is_op2lvalue, is_op1const, is_op2const: BOOLEAN) ;
-
-
(*
BuildExcludeVarConst - builds the EXCL(op1, 1<<op2) operation for a small sets. Large
sets call this routine to exclude the bit in the particular word.
@@ -326,4 +313,12 @@ PROCEDURE BuildBuiltinCallTree (func: tree) : tree ;
PROCEDURE CopyByField (location: location_t; des, expr: tree) ;
+(*
+ IfBitInSetJump - if bit in set jump to label.
+*)
+
+PROCEDURE IfBitInSetJump (location: location_t; invertCondition: BOOLEAN;
+ setvalue, bit: tree; label: ADDRESS) ;
+
+
END m2statement.
diff --git a/gcc/m2/gm2-gcc/m2statement.h b/gcc/m2/gm2-gcc/m2statement.h
index 0076b32dc8ee..4cb6a67c6558 100644
--- a/gcc/m2/gm2-gcc/m2statement.h
+++ b/gcc/m2/gm2-gcc/m2statement.h
@@ -52,10 +52,6 @@ EXTERN void m2statement_BuildExcludeVarVar (location_t location, tree type,
EXTERN void m2statement_BuildExcludeVarConst (location_t location, tree type,
tree op1, tree op2,
bool is_lvalue, int fieldno);
-EXTERN void m2statement_BuildUnaryForeachWordDo (
- location_t location, tree type, tree op1, tree op2,
- tree (*unop) (location_t, tree, bool), bool is_op1lvalue, bool is_op2lvalue,
- bool is_op1const, bool is_op2const);
EXTERN void m2statement_BuildAsm (location_t location, tree instr,
bool isVolatile, bool isSimple, tree inputs,
tree outputs, tree trash, tree labels);
@@ -88,8 +84,7 @@ EXTERN void m2statement_BuildEndFunctionCode (location_t location, tree fndecl,
EXTERN void m2statement_BuildStartFunctionCode (location_t location,
tree fndecl, bool isexported,
bool isinline);
-EXTERN void m2statement_DoJump (location_t location, tree exp,
- char *falselabel, char *truelabel);
+EXTERN void m2statement_IfExprJump (location_t location, tree exp, char *label);
EXTERN tree m2statement_BuildCall2 (location_t location, tree function,
tree rettype, tree arg1, tree arg2);
EXTERN tree m2statement_BuildCall3 (location_t location, tree function,
@@ -108,6 +103,8 @@ EXTERN tree m2statement_BuildBuiltinCallTree (tree func);
EXTERN tree m2statement_BuildTryFinally (location_t location, tree call,
tree cleanups);
EXTERN tree m2statement_BuildCleanUp (tree param);
+EXTERN void m2statement_IfBitInSetJump (location_t location, bool invertCondition,
+ tree setvalue, tree bit, char *label);
EXTERN void m2statement_CopyByField (location_t location, tree des, tree expr);
#undef EXTERN
diff --git a/gcc/m2/gm2-gcc/m2treelib.cc b/gcc/m2/gm2-gcc/m2treelib.cc
index 7e542db7b76a..b054aa9fcbdb 100644
--- a/gcc/m2/gm2-gcc/m2treelib.cc
+++ b/gcc/m2/gm2-gcc/m2treelib.cc
@@ -45,7 +45,7 @@ m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word,
{
word = m2convert_ToWord (location, word);
bit = m2convert_ToWord (location, bit);
- m2statement_DoJump (
+ m2statement_IfExprJump (
location,
m2expr_build_binary_op (
location, code,
@@ -55,7 +55,7 @@ m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word,
FALSE),
FALSE),
m2expr_GetWordZero (location), FALSE),
- NULL, label);
+ label);
}
/* build_modify_expr - taken from c-typeck.cc and heavily pruned.
@@ -147,8 +147,8 @@ m2treelib_build_modify_expr (location_t location, tree des,
/* nCount - return the number of trees chained on, t. */
-static int
-nCount (tree t)
+int
+m2treelib_nCount (tree t)
{
int i = 0;
@@ -167,7 +167,7 @@ tree
m2treelib_DoCall (location_t location, tree rettype, tree funcptr,
tree param_list)
{
- int n = nCount (param_list);
+ int n = m2treelib_nCount (param_list);
tree *argarray = XALLOCAVEC (tree, n);
tree l = param_list;
int i;
@@ -229,18 +229,6 @@ m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr, tree arg0,
return build_call_array_loc (location, rettype, funcptr, 3, argarray);
}
-/* get_rvalue - returns the rvalue of t. The, type, is the object
- type to be copied upon indirection. */
-
-tree
-m2treelib_get_rvalue (location_t location, tree t, tree type, bool is_lvalue)
-{
- if (is_lvalue)
- return m2expr_BuildIndirect (location, t, type);
- else
- return t;
-}
-
/* get_field_no - returns the field no for, op. The, op, is either a
constructor or a variable of type record. If, op, is a
constructor (a set constant in GNU Modula-2) then this function is
diff --git a/gcc/m2/gm2-gcc/m2treelib.def b/gcc/m2/gm2-gcc/m2treelib.def
index 4b7c61ad950b..ae489a0c5afd 100644
--- a/gcc/m2/gm2-gcc/m2treelib.def
+++ b/gcc/m2/gm2-gcc/m2treelib.def
@@ -78,14 +78,6 @@ PROCEDURE get_set_value (location: location_t; p: tree; field: tree; is_const: B
PROCEDURE get_field_no (type: tree; op: tree; is_const: BOOLEAN; fieldNo: CARDINAL) : tree ;
-(*
- get_rvalue - returns the rvalue of t. The, type, is the object type to be
- copied upon indirection.
-*)
-
-PROCEDURE get_rvalue (location: location_t; t: tree; type: tree; is_lvalue: BOOLEAN) : tree ;
-
-
(*
DoCall - build a call tree arranging the parameter list as a vector.
*)
@@ -105,4 +97,11 @@ PROCEDURE build_modify_expr (location: location_t; des: tree; modifycode: tree_c
PROCEDURE do_jump_if_bit (location: location_t; code: tree_code; word: tree; bit: tree; label: ADDRESS) ;
+(*
+ nCount - return the number of trees chained.
+*)
+
+PROCEDURE nCount (t: tree) : INTEGER ;
+
+
END m2treelib.
diff --git a/gcc/m2/gm2-gcc/m2treelib.h b/gcc/m2/gm2-gcc/m2treelib.h
index d751fbb8c61d..a56df2566fbd 100644
--- a/gcc/m2/gm2-gcc/m2treelib.h
+++ b/gcc/m2/gm2-gcc/m2treelib.h
@@ -41,8 +41,6 @@ EXTERN tree m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr,
tree arg0, tree arg1);
EXTERN tree m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr,
tree arg0, tree arg1, tree arg2);
-EXTERN tree m2treelib_get_rvalue (location_t location, tree t, tree type,
- bool is_lvalue);
EXTERN tree m2treelib_get_field_no (tree type, tree op, bool is_const,
unsigned int fieldNo);
EXTERN tree m2treelib_get_set_value (location_t location, tree p, tree field,
@@ -61,6 +59,7 @@ EXTERN tree m2treelib_get_set_field_des (location_t location, tree p,
EXTERN tree add_stmt (location_t location, tree t);
EXTERN tree build_stmt (location_t loc, enum tree_code code, ...);
+EXTERN int m2treelib_nCount (tree t);
#undef EXTERN
#endif /* m2treelib_h. */
diff --git a/gcc/m2/gm2-gcc/m2type.cc b/gcc/m2/gm2-gcc/m2type.cc
index e486f12004fe..184b506aa693 100644
--- a/gcc/m2/gm2-gcc/m2type.cc
+++ b/gcc/m2/gm2-gcc/m2type.cc
@@ -50,12 +50,11 @@ struct GTY (()) struct_constructor
/* Constructor_fields, the list of fields belonging to
constructor_type. Used by SET and RECORD constructors. */
tree GTY ((skip (""))) constructor_fields;
- /* Constructor_element_list, the list of constants used by SET and
- RECORD constructors. */
- tree GTY ((skip (""))) constructor_element_list;
- /* Constructor_elements, used by an ARRAY initializer all elements
- are held in reverse order. */
+ /* Constructor_elements, used by an ARRAY, RECORD and SET initializer
+ all elements are held in reverse order. */
vec<constructor_elt, va_gc> *constructor_elements;
+ /* The next byte_index to be used when adding set bytes to an array. */
+ int byte_index;
/* Level, the next level down in the constructor stack. */
struct struct_constructor *level;
};
@@ -243,8 +242,9 @@ m2type_BuildEndArrayType (tree arraytype, tree elementtype, tree indextype,
return gm2_finish_build_array_type (arraytype, ptr_type_node, indextype,
type);
else
- return gm2_finish_build_array_type (
- arraytype, m2tree_skip_type_decl (elementtype), indextype, type);
+ return gm2_finish_build_array_type (arraytype,
+ m2tree_skip_type_decl (elementtype),
+ indextype, type);
}
/* gm2_build_array_type returns a type which is an array indexed by
@@ -330,7 +330,8 @@ static tree
build_m2_type_node_by_array (tree arrayType, tree low, tree high, int fetype)
{
return gm2_build_array_type (arrayType,
- m2type_BuildArrayIndexType (low, high), fetype);
+ m2type_BuildArrayIndexType (low, high),
+ fetype);
}
/* build_m2_word16_type_node build an ISO 16 bit word as an ARRAY
@@ -893,6 +894,17 @@ m2type_GetBooleanType (void)
#endif /* !USE_BOOLEAN */
}
+/* GetBooleanEnumList return a list containing boolean fields true and false. */
+
+tree
+m2type_GetBooleanEnumList (location_t location)
+{
+ tree list = NULL;
+ m2type_BuildEnumerator (location, "TRUE", m2type_GetBooleanTrue (), &list);
+ m2type_BuildEnumerator (location, "FALSE", m2type_GetBooleanTrue (), &list);
+ return list;
+}
+
/* GetCardinalAddressType returns the internal data type for
computing binary arithmetic upon the ADDRESS datatype. */
@@ -1892,7 +1904,7 @@ m2type_GetDefaultType (location_t location, char *name, tree type)
}
/* IsGccRealType return true if type is a GCC realtype. */
-
+
static
bool
IsGccRealType (tree type)
@@ -1935,7 +1947,7 @@ m2type_GetMinFrom (location_t location, tree type)
return TYPE_MIN_VALUE (m2tree_skip_type_decl (type));
}
-static
+static
tree
do_max_real (tree type)
{
@@ -2201,7 +2213,7 @@ gm2_build_enumerator (location_t location, tree name, tree value)
enumvalues, list. It returns a copy of the value. */
tree
-m2type_BuildEnumerator (location_t location, char *name, tree value,
+m2type_BuildEnumerator (location_t location, const char *name, tree value,
tree *enumvalues)
{
tree id = get_identifier (name);
@@ -2274,8 +2286,8 @@ pop_constructor (struct struct_constructor *p)
top_constructor = top_constructor->level;
}
-/* BuildStartSetConstructor starts to create a set constant.
- Remember that type is really a record type. */
+/* BuildStartSetConstructor starts to create a wide set constant.
+ A wide set type will be implemented as an array type (array [0..max] OF BYTE). */
void *
m2type_BuildStartSetConstructor (tree type)
@@ -2285,36 +2297,32 @@ m2type_BuildStartSetConstructor (tree type)
type = m2tree_skip_type_decl (type);
layout_type (type);
p->constructor_type = type;
- p->constructor_fields = TYPE_FIELDS (type);
- p->constructor_element_list = NULL_TREE;
+ p->constructor_fields = TREE_TYPE (type);
+ p->byte_index = 0;
vec_alloc (p->constructor_elements, 1);
return (void *)p;
}
-/* BuildSetConstructorElement adds, value, to the
- constructor_element_list. */
+/* BuildSetConstructorElement adds value to the constructor_elements. */
void
-m2type_BuildSetConstructorElement (void *p, tree value)
+m2type_BuildSetConstructorElement (location_t location, void *p, tree value)
{
struct struct_constructor *c = (struct struct_constructor *)p;
+ constructor_elt celt;
- if (value == NULL_TREE)
- {
- internal_error ("set type cannot be initialized with a %qs",
- "NULL_TREE");
- return;
- }
-
- if (c->constructor_fields == NULL)
+ if (c->constructor_fields == NULL_TREE)
{
- internal_error ("set type does not take another integer value");
+ internal_error ("set type must be initialized");
return;
}
- c->constructor_element_list
- = tree_cons (c->constructor_fields, value, c->constructor_element_list);
- c->constructor_fields = TREE_CHAIN (c->constructor_fields);
+ value = m2convert_BuildConvert (location, c->constructor_fields,
+ value, FALSE);
+ celt.index = m2decl_BuildIntegerConstant (c->byte_index);
+ celt.value = value;
+ c->byte_index++;
+ vec_safe_push (c->constructor_elements, celt);
}
/* BuildEndSetConstructor finishes building a set constant. */
@@ -2322,24 +2330,13 @@ m2type_BuildSetConstructorElement (void *p, tree value)
tree
m2type_BuildEndSetConstructor (void *p)
{
- tree constructor;
- tree link;
struct struct_constructor *c = (struct struct_constructor *)p;
+ tree constructor =
+ build_constructor (c->constructor_type, c->constructor_elements);
- for (link = c->constructor_element_list; link; link = TREE_CHAIN (link))
- {
- tree field = TREE_PURPOSE (link);
- DECL_SIZE (field) = bitsize_int (SET_WORD_SIZE);
- DECL_BIT_FIELD (field) = 1;
- }
-
- constructor = build_constructor_from_list (
- c->constructor_type, nreverse (c->constructor_element_list));
- TREE_CONSTANT (constructor) = 1;
- TREE_STATIC (constructor) = 1;
-
+ TREE_CONSTANT (constructor) = true;
+ TREE_STATIC (constructor) = true;
pop_constructor (c);
-
return constructor;
}
@@ -2355,11 +2352,30 @@ m2type_BuildStartRecordConstructor (tree type)
layout_type (type);
p->constructor_type = type;
p->constructor_fields = TYPE_FIELDS (type);
- p->constructor_element_list = NULL_TREE;
vec_alloc (p->constructor_elements, 1);
return (void *)p;
}
+/* build_record_constructor build and return a record constructor of type
+ record_type from the ordered values in vals. */
+
+static
+tree
+build_record_constructor (tree record_type, vec<constructor_elt, va_gc> *vals)
+{
+ tree field_init;
+ unsigned int i;
+ vec<constructor_elt, va_gc> *v = NULL;
+ tree field_type = first_field (record_type);
+ FOR_EACH_CONSTRUCTOR_VALUE (vals, i, field_init)
+ {
+ CONSTRUCTOR_APPEND_ELT (v, field_type, field_init);
+ field_type = DECL_CHAIN (field_type);
+ }
+ return build_constructor (record_type, v);
+}
+
+
/* BuildEndRecordConstructor returns a tree containing the record
compound literal. */
@@ -2367,23 +2383,32 @@ tree
m2type_BuildEndRecordConstructor (void *p)
{
struct struct_constructor *c = (struct struct_constructor *)p;
- tree constructor = build_constructor_from_list (
- c->constructor_type, nreverse (c->constructor_element_list));
- TREE_CONSTANT (constructor) = 1;
- TREE_STATIC (constructor) = 1;
-
+ tree constructor = build_record_constructor (c->constructor_type,
+ c->constructor_elements);
+ TREE_CONSTANT (constructor) = true;
+ TREE_STATIC (constructor) = true;
pop_constructor (c);
-
return constructor;
}
/* BuildRecordConstructorElement adds, value, to the
- constructor_element_list. */
+ constructor_elements. */
void
m2type_BuildRecordConstructorElement (void *p, tree value)
{
- m2type_BuildSetConstructorElement (p, value);
+ struct struct_constructor *c = (struct struct_constructor *)p;
+ constructor_elt celt;
+
+ if (c->constructor_fields == NULL_TREE)
+ {
+ internal_error ("record type must be initialized");
+ return;
+ }
+ celt.index = m2decl_BuildIntegerConstant (c->byte_index);
+ celt.value = value;
+ c->byte_index++;
+ vec_safe_push (c->constructor_elements, celt);
}
/* BuildStartArrayConstructor initializes an array compound
@@ -2398,7 +2423,6 @@ m2type_BuildStartArrayConstructor (tree type)
layout_type (type);
p->constructor_type = type;
p->constructor_fields = TREE_TYPE (type);
- p->constructor_element_list = NULL_TREE;
vec_alloc (p->constructor_elements, 1);
return (void *)p;
}
@@ -2416,14 +2440,12 @@ m2type_BuildEndArrayConstructor (void *p)
= build_constructor (c->constructor_type, c->constructor_elements);
TREE_CONSTANT (constructor) = true;
TREE_STATIC (constructor) = true;
-
pop_constructor (c);
-
return constructor;
}
/* BuildArrayConstructorElement adds, value, to the
- constructor_element_list. */
+ constructor_elements. */
void
m2type_BuildArrayConstructorElement (void *p, tree value, tree indice)
diff --git a/gcc/m2/gm2-gcc/m2type.def b/gcc/m2/gm2-gcc/m2type.def
index f74888e315ef..8a72652f22c8 100644
--- a/gcc/m2/gm2-gcc/m2type.def
+++ b/gcc/m2/gm2-gcc/m2type.def
@@ -136,7 +136,7 @@ PROCEDURE BuildEndSetConstructor (p: Constructor) : tree ;
BuildSetConstructorElement - adds, value, to the constructor_element_list.
*)
-PROCEDURE BuildSetConstructorElement (p: Constructor; value: tree) ;
+PROCEDURE BuildSetConstructorElement (location: location_t; p: Constructor; value: tree) ;
(*
@@ -796,7 +796,7 @@ PROCEDURE BuildArrayStringConstructor (location: location_t; arrayType: tree; st
(*
- RealToTree - convert a real number into a Tree.
+ RealToTree - convert a real number into a tree.
*)
PROCEDURE RealToTree (name: CharStar) : tree ;
@@ -962,7 +962,8 @@ PROCEDURE GetArrayNoOfElements (location: location_t; arraytype: tree) : tree ;
and which has ElementType elements.
*)
-PROCEDURE BuildEndArrayType (arraytype: tree; elementtype: tree; indextype: tree; type: INTEGER) : tree ;
+PROCEDURE BuildEndArrayType (arraytype: tree; elementtype: tree;
+ indextype: tree; type: INTEGER) : tree ;
(*
@@ -1004,4 +1005,11 @@ PROCEDURE SameRealType (a, b: tree) : BOOLEAN ;
PROCEDURE IsGccStrictTypeEquivalent (left, right: tree) : BOOLEAN ;
+(*
+ GetBooleanEnumList - return a list containing boolean fields true and false.
+*)
+
+PROCEDURE GetBooleanEnumList (location: location_t) : tree ;
+
+
END m2type.
diff --git a/gcc/m2/gm2-gcc/m2type.h b/gcc/m2/gm2-gcc/m2type.h
index 663af3ce7eb8..68015a01e145 100644
--- a/gcc/m2/gm2-gcc/m2type.h
+++ b/gcc/m2/gm2-gcc/m2type.h
@@ -183,14 +183,14 @@ EXTERN tree m2type_BuildStartEnumeration (location_t location, char *name,
bool ispacked);
EXTERN tree m2type_BuildEndEnumeration (location_t location, tree enumtype,
tree enumvalues);
-EXTERN tree m2type_BuildEnumerator (location_t location, char *name,
+EXTERN tree m2type_BuildEnumerator (location_t location, const char *name,
tree value, tree *enumvalues);
EXTERN tree m2type_BuildPointerType (tree totype);
EXTERN tree m2type_BuildConstPointerType (tree totype);
EXTERN tree m2type_BuildSetType (location_t location, char *name, tree type,
tree lowval, tree highval, bool ispacked);
EXTERN void *m2type_BuildStartSetConstructor (tree type);
-EXTERN void m2type_BuildSetConstructorElement (void *p, tree value);
+EXTERN void m2type_BuildSetConstructorElement (location_t location, void *p, tree value);
EXTERN tree m2type_BuildEndSetConstructor (void *p);
EXTERN void *m2type_BuildStartRecordConstructor (tree type);
EXTERN tree m2type_BuildEndRecordConstructor (void *p);
@@ -214,6 +214,7 @@ EXTERN bool m2type_IsAddress (tree type);
EXTERN tree m2type_GetCardinalAddressType (void);
EXTERN bool m2type_SameRealType (tree a, tree b);
EXTERN bool m2type_IsGccStrictTypeEquivalent (tree left, tree right);
+EXTERN tree m2type_GetBooleanEnumList (location_t location);
#undef EXTERN
#endif /* m2type_h */
diff --git a/gcc/m2/gm2-lang.cc b/gcc/m2/gm2-lang.cc
index cc074d550fc6..c90c71380991 100644
--- a/gcc/m2/gm2-lang.cc
+++ b/gcc/m2/gm2-lang.cc
@@ -692,6 +692,12 @@ gm2_langhook_handle_option (
case OPT_fgen_module_list_:
M2Options_SetGenModuleList (value, arg);
return 1;
+ case OPT_fmem_report:
+ M2Options_SetMemReport (value);
+ return 1;
+ case OPT_ftime_report:
+ M2Options_SetTimeReport (value);
+ return 1;
case OPT_fnil:
M2Options_SetNilCheck (value);
return 1;
@@ -915,6 +921,11 @@ gm2_langhook_handle_option (
case OPT_fm2_whole_program:
M2Options_SetWholeProgram (value);
return 1;
+ break;
+ case OPT_fwideset:
+ M2Options_SetWideset (value);
+ return 1;
+ break;
#ifdef OPT_mabi_ibmlongdouble
case OPT_mabi_ibmlongdouble:
M2Options_SetIBMLongDouble (value);
diff --git a/gcc/m2/gm2-libs-coroutines/SYSTEM.def b/gcc/m2/gm2-libs-coroutines/SYSTEM.def
index ea982e8ffa71..ea3ee93d7d77 100644
--- a/gcc/m2/gm2-libs-coroutines/SYSTEM.def
+++ b/gcc/m2/gm2-libs-coroutines/SYSTEM.def
@@ -41,10 +41,7 @@ EXPORT QUALIFIED (* the following are built into the compiler: *)
(* The rest are implemented in SYSTEM.mod. *)
PROCESS, TRANSFER, NEWPROCESS, IOTRANSFER,
LISTEN,
- ListenLoop, TurnInterrupts,
- (* Internal GM2 compiler functions. *)
- ShiftVal, ShiftLeft, ShiftRight,
- RotateVal, RotateLeft, RotateRight ;
+ ListenLoop, TurnInterrupts ;
TYPE
@@ -192,87 +189,4 @@ PROCEDURE TBITSIZE (<type>) : CARDINAL ;
*)
*)
-(* The following procedures are invoked by GNU Modula-2 to
- shift non word sized set types. They are not strictly part
- of the core PIM Modula-2, however they are used
- to implement the SHIFT procedure defined above,
- which are in turn used by the Logitech compatible libraries.
-
- Users will access these procedures by using the procedure
- SHIFT above and GNU Modula-2 will map SHIFT onto one of
- the following procedures.
-*)
-
-(*
- ShiftVal - is a runtime procedure whose job is to implement
- the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
- inline a SHIFT of a single WORD sized set and will
- only call this routine for larger sets.
-*)
-
-PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: INTEGER) ;
-
-
-(*
- ShiftLeft - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-
-(*
- ShiftRight - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-
-
-(*
- RotateVal - is a runtime procedure whose job is to implement
- the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
- inline a ROTATE of a single WORD (or less)
- sized set and will only call this routine for
- larger sets.
-*)
-
-PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: INTEGER) ;
-
-
-(*
- RotateLeft - performs the rotate left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known
- at compile time.
-*)
-
-PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-
-
-(*
- RotateRight - performs the rotate right for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-
-
END SYSTEM.
diff --git a/gcc/m2/gm2-libs-coroutines/SYSTEM.mod b/gcc/m2/gm2-libs-coroutines/SYSTEM.mod
index 63b4ecb3b488..6a71083dbd4d 100644
--- a/gcc/m2/gm2-libs-coroutines/SYSTEM.mod
+++ b/gcc/m2/gm2-libs-coroutines/SYSTEM.mod
@@ -27,9 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
IMPLEMENTATION MODULE SYSTEM ;
FROM RTco IMPORT init, initThread, transfer, currentThread, turnInterrupts ;
-
-FROM RTint IMPORT Listen, AttachVector,
- IncludeVector, ExcludeVector ;
+FROM RTint IMPORT Listen, AttachVector, IncludeVector, ExcludeVector ;
IMPORT RTint ;
@@ -60,8 +58,6 @@ VAR
*)
PROCEDURE TRANSFER (VAR p1: PROCESS; p2: PROCESS) ;
-VAR
- r: INTEGER ;
BEGIN
localMain (p1) ;
IF p1.context=p2.context
@@ -104,14 +100,13 @@ END NEWPROCESS ;
PROCEDURE IOTRANSFER (VAR First, Second: PROCESS; InterruptNo: CARDINAL) ;
VAR
- p: IOTransferState ;
- l: POINTER TO IOTransferState ;
+ iots: IOTransferState ;
BEGIN
localMain (First) ;
- WITH p DO
+ WITH iots DO
ptrToFirst := ADR (First) ;
ptrToSecond := ADR (Second) ;
- next := AttachVector (InterruptNo, ADR (p))
+ next := AttachVector (InterruptNo, ADR (iots))
END ;
IncludeVector (InterruptNo) ;
TRANSFER (First, Second)
@@ -124,18 +119,18 @@ END IOTRANSFER ;
PROCEDURE IOTransferHandler (InterruptNo: CARDINAL;
Priority: CARDINAL ;
- l: PtrToIOTransferState) ;
+ piots: PtrToIOTransferState) ;
VAR
old: PtrToIOTransferState ;
BEGIN
- IF l=NIL
+ IF piots = NIL
THEN
Halt ('no processes attached to this interrupt vector which is associated with IOTRANSFER',
__FILE__, __FUNCTION__, __LINE__)
ELSE
- WITH l^ DO
+ WITH piots^ DO
old := AttachVector (InterruptNo, next) ;
- IF old#l
+ IF old # piots
THEN
Halt ('inconsistancy of return result',
__FILE__, __FUNCTION__, __LINE__)
@@ -250,236 +245,6 @@ BEGIN
END localMain ;
-(*
- Max - returns the maximum of a and b.
-*)
-
-PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
-BEGIN
- IF a > b
- THEN
- RETURN a
- ELSE
- RETURN b
- END
-END Max ;
-
-
-(*
- Min - returns the minimum of a and b.
-*)
-
-PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
-BEGIN
- IF a < b
- THEN
- RETURN a
- ELSE
- RETURN b
- END
-END Min ;
-
-
-(*
- ShiftVal - is a runtime procedure whose job is to implement
- the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
- inline a SHIFT of a single WORD sized set and will only
- call this routine for larger sets.
-*)
-
-PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: INTEGER) ;
-VAR
- a: ADDRESS ;
-BEGIN
- IF ShiftCount>0
- THEN
- ShiftCount := ShiftCount MOD VAL(INTEGER, SetSizeInBits) ;
- ShiftLeft (s, d, SetSizeInBits, ShiftCount)
- ELSIF ShiftCount<0
- THEN
- ShiftCount := (-ShiftCount) MOD VAL(INTEGER, SetSizeInBits) ;
- ShiftRight (s, d, SetSizeInBits, ShiftCount)
- ELSE
- a := memcpy (ADR (d), ADR (s), (HIGH (d) + 1) * SIZE (BITSET))
- END
-END ShiftVal ;
-
-
-(*
- ShiftLeft - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- i, j, h: CARDINAL ;
- a : ADDRESS ;
-BEGIN
- h := HIGH(s)+1 ;
- IF ShiftCount MOD BitsPerBitset=0
- THEN
- i := ShiftCount DIV BitsPerBitset ;
- a := ADR (d[i]) ;
- a := memcpy (a, ADR (s), (h-i) * SIZE (BITSET)) ;
- a := memset (ADR (d), 0, i * SIZE (BITSET))
- ELSE
- i := h ;
- WHILE i>0 DO
- DEC (i) ;
- lo := SHIFT (s[i], ShiftCount MOD BitsPerBitset) ;
- hi := SHIFT (s[i], -(BitsPerBitset - (ShiftCount MOD BitsPerBitset))) ;
- d[i] := BITSET{} ;
- j := i + ShiftCount DIV BitsPerBitset ;
- IF j<h
- THEN
- d[j] := d[j] + lo ;
- INC(j) ;
- IF j<h
- THEN
- d[j] := d[j] + hi
- END
- END
- END
- END
-END ShiftLeft ;
-
-
-(*
- ShiftRight - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- j, i, h: INTEGER ;
- a : ADDRESS ;
-BEGIN
- h := HIGH (s) + 1 ;
- IF ShiftCount MOD BitsPerBitset=0
- THEN
- i := ShiftCount DIV BitsPerBitset ;
- a := ADR (s[i]) ;
- j := h-i ;
- a := memcpy (ADR (d), a, j * VAL (INTEGER, SIZE(BITSET))) ;
- a := ADR (d[j]) ;
- a := memset (a, 0, i * VAL (INTEGER, SIZE(BITSET)))
- ELSE
- i := 0 ;
- WHILE i<h DO
- lo := SHIFT(s[i], BitsPerBitset - (ShiftCount MOD BitsPerBitset)) ;
- hi := SHIFT(s[i], -(ShiftCount MOD BitsPerBitset)) ;
- d[i] := BITSET{} ;
- j := i - VAL(INTEGER, ShiftCount DIV BitsPerBitset) ;
- IF j>=0
- THEN
- d[j] := d[j] + hi ;
- DEC(j) ;
- IF j>=0
- THEN
- d[j] := d[j] + lo
- END
- END ;
- INC(i)
- END
- END
-END ShiftRight ;
-
-
-(*
- RotateVal - is a runtime procedure whose job is to implement
- the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
- inline a ROTATE of a single WORD (or less)
- sized set and will only call this routine for larger sets.
-*)
-
-PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: INTEGER) ;
-VAR
- a: ADDRESS ;
-BEGIN
- IF RotateCount>0
- THEN
- RotateLeft(s, d, SetSizeInBits, RotateCount)
- ELSIF RotateCount<0
- THEN
- RotateRight(s, d, SetSizeInBits, -RotateCount)
- ELSE
- a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
- END
-END RotateVal ;
-
-
-(*
- RotateLeft - performs the rotate left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- b, i, j, h: CARDINAL ;
-BEGIN
- h := HIGH(s) ;
- (* firstly we set d := {} *)
- i := 0 ;
- WHILE i<=h DO
- d[i] := BITSET{} ;
- INC(i)
- END ;
- i := h+1 ;
- RotateCount := RotateCount MOD SetSizeInBits ;
- b := SetSizeInBits MOD BitsPerBitset ;
- IF b=0
- THEN
- b := BitsPerBitset
- END ;
- WHILE i>0 DO
- DEC(i) ;
- lo := SHIFT(s[i], RotateCount MOD BitsPerBitset) ;
- hi := SHIFT(s[i], -(b - (RotateCount MOD BitsPerBitset))) ;
- j := ((i*BitsPerBitset + RotateCount) MOD
- SetSizeInBits) DIV BitsPerBitset ;
- d[j] := d[j] + lo ;
- j := (((i+1)*BitsPerBitset + RotateCount) MOD
- SetSizeInBits) DIV BitsPerBitset ;
- d[j] := d[j] + hi ;
- b := BitsPerBitset
- END
-END RotateLeft ;
-
-
-(*
- RotateRight - performs the rotate right for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-BEGIN
- RotateLeft(s, d, SetSizeInBits, SetSizeInBits-RotateCount)
-END RotateRight ;
-
-
BEGIN
initGTh := FALSE ;
initMain := FALSE
diff --git a/gcc/m2/gm2-libs-iso/SYSTEM.def b/gcc/m2/gm2-libs-iso/SYSTEM.def
index b99b2afdccce..75d19ea2e620 100644
--- a/gcc/m2/gm2-libs-iso/SYSTEM.def
+++ b/gcc/m2/gm2-libs-iso/SYSTEM.def
@@ -20,10 +20,7 @@ EXPORT QUALIFIED BITSPERLOC, LOCSPERWORD,
LOC, BYTE, WORD, ADDRESS, CSIZE_T, CSSIZE_T, COFF_T, (* @SYSTEM_DATATYPES@ *)
ADDADR, SUBADR, DIFADR, MAKEADR, ADR, ROTATE,
SHIFT, CAST, TSIZE,
-
(* Internal GM2 compiler functions *)
- ShiftVal, ShiftLeft, ShiftRight,
- RotateVal, RotateLeft, RotateRight,
THROW, TBITSIZE ;
CONST
@@ -155,81 +152,4 @@ PROCEDURE TBITSIZE (<type>) : CARDINAL ;
*)
*)
-
-(* The following procedures are invoked by GNU Modula-2 to
- shift non word set types. They are not part of ISO Modula-2
- but are used to implement the SHIFT procedure defined above. *)
-
-(*
- ShiftVal - is a runtime procedure whose job is to implement
- the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
- inline a SHIFT of a single WORD sized set and will only
- call this routine for larger sets.
-*)
-
-PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: INTEGER) ;
-
-
-(*
- ShiftLeft - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-
-(*
- ShiftRight - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-
-
-(*
- RotateVal - is a runtime procedure whose job is to implement
- the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
- inline a ROTATE of a single WORD (or less)
- sized set and will only call this routine for larger
- sets.
-*)
-
-PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: INTEGER) ;
-
-
-(*
- RotateLeft - performs the rotate left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-
-
-(*
- RotateRight - performs the rotate right for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-
-
END SYSTEM.
diff --git a/gcc/m2/gm2-libs-iso/SYSTEM.mod b/gcc/m2/gm2-libs-iso/SYSTEM.mod
index cd28b1d7b082..5e146f59abbb 100644
--- a/gcc/m2/gm2-libs-iso/SYSTEM.mod
+++ b/gcc/m2/gm2-libs-iso/SYSTEM.mod
@@ -26,248 +26,4 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
IMPLEMENTATION MODULE SYSTEM ;
-FROM libc IMPORT memcpy, memset ;
-
-CONST
- BitsPerBitset = MAX(BITSET)+1 ;
-
-
-(*
- Max - returns the maximum of a and b.
-*)
-
-PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
-BEGIN
- IF a>b
- THEN
- RETURN a
- ELSE
- RETURN b
- END
-END Max ;
-
-
-(*
- Min - returns the minimum of a and b.
-*)
-
-PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
-BEGIN
- IF a<b
- THEN
- RETURN a
- ELSE
- RETURN b
- END
-END Min ;
-
-
-(*
- ShiftVal - is a runtime procedure whose job is to implement
- the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
- inline a SHIFT of a single WORD sized set and will only
- call this routine for larger sets.
-*)
-
-PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: INTEGER) ;
-VAR
- a: ADDRESS ;
-BEGIN
- IF ShiftCount>0
- THEN
- ShiftCount := ShiftCount MOD VAL(INTEGER, SetSizeInBits) ;
- ShiftLeft(s, d, SetSizeInBits, ShiftCount)
- ELSIF ShiftCount<0
- THEN
- ShiftCount := (-ShiftCount) MOD VAL(INTEGER, SetSizeInBits) ;
- ShiftRight(s, d, SetSizeInBits, ShiftCount)
- ELSE
- a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
- END
-END ShiftVal ;
-
-
-(*
- ShiftLeft - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- i, j, h: CARDINAL ;
- a : ADDRESS ;
-BEGIN
- h := HIGH(s)+1 ;
- IF ShiftCount MOD BitsPerBitset=0
- THEN
- i := ShiftCount DIV BitsPerBitset ;
- a := ADR(d[i]) ;
- a := memcpy(a, ADR(s), (h-i)*SIZE(BITSET)) ;
- a := memset(ADR(d), 0, i*SIZE(BITSET))
- ELSE
- i := h ;
- WHILE i>0 DO
- DEC(i) ;
- lo := SHIFT(s[i], ShiftCount MOD BitsPerBitset) ;
- hi := SHIFT(s[i], -(BitsPerBitset - (ShiftCount MOD BitsPerBitset))) ;
- d[i] := BITSET{} ;
- j := i + ShiftCount DIV BitsPerBitset ;
- IF j<h
- THEN
- d[j] := d[j] + lo ;
- INC(j) ;
- IF j<h
- THEN
- d[j] := d[j] + hi
- END
- END
- END
- END
-END ShiftLeft ;
-
-
-(*
- ShiftRight - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- j, i, h: INTEGER ;
- a : ADDRESS ;
-BEGIN
- h := HIGH(s)+1 ;
- IF ShiftCount MOD BitsPerBitset=0
- THEN
- i := ShiftCount DIV BitsPerBitset ;
- a := ADR(s[i]) ;
- j := h-i ;
- a := memcpy(ADR(d), a, j * VAL (INTEGER, SIZE (BITSET))) ;
- a := ADR(d[j]) ;
- a := memset(a, 0, i * VAL (INTEGER, SIZE (BITSET)))
- ELSE
- i := 0 ;
- WHILE i<h DO
- lo := SHIFT(s[i], BitsPerBitset - (ShiftCount MOD BitsPerBitset)) ;
- hi := SHIFT(s[i], -(ShiftCount MOD BitsPerBitset)) ;
- d[i] := BITSET{} ;
- j := i - VAL(INTEGER, ShiftCount DIV BitsPerBitset) ;
- IF j>=0
- THEN
- d[j] := d[j] + hi ;
- DEC(j) ;
- IF j>=0
- THEN
- d[j] := d[j] + lo
- END
- END ;
- INC(i)
- END
- END
-END ShiftRight ;
-
-
-(*
- RotateVal - is a runtime procedure whose job is to implement
- the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
- inline a ROTATE of a single WORD (or less)
- sized set and will only call this routine for larger sets.
-*)
-
-PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: INTEGER) ;
-VAR
- a: ADDRESS ;
-BEGIN
- IF RotateCount>0
- THEN
- RotateCount := RotateCount MOD VAL(INTEGER, SetSizeInBits)
- ELSIF RotateCount<0
- THEN
- RotateCount := -VAL(INTEGER, VAL(CARDINAL, -RotateCount) MOD SetSizeInBits)
- END ;
- IF RotateCount>0
- THEN
- RotateLeft(s, d, SetSizeInBits, RotateCount)
- ELSIF RotateCount<0
- THEN
- RotateRight(s, d, SetSizeInBits, -RotateCount)
- ELSE
- (* no rotate required, but we must copy source to dest. *)
- a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
- END
-END RotateVal ;
-
-
-(*
- RotateLeft - performs the rotate left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- b, i, j, h: CARDINAL ;
-BEGIN
- h := HIGH(s) ;
- (* firstly we set d := {} *)
- i := 0 ;
- WHILE i<=h DO
- d[i] := BITSET{} ;
- INC(i)
- END ;
- i := h+1 ;
- RotateCount := RotateCount MOD SetSizeInBits ;
- b := SetSizeInBits MOD BitsPerBitset ;
- IF b=0
- THEN
- b := BitsPerBitset
- END ;
- WHILE i>0 DO
- DEC(i) ;
- lo := SHIFT(s[i], RotateCount MOD BitsPerBitset) ;
- hi := SHIFT(s[i], -(b - (RotateCount MOD BitsPerBitset))) ;
- j := ((i*BitsPerBitset + RotateCount) MOD
- SetSizeInBits) DIV BitsPerBitset ;
- d[j] := d[j] + lo ;
- j := (((i+1)*BitsPerBitset + RotateCount) MOD
- SetSizeInBits) DIV BitsPerBitset ;
- d[j] := d[j] + hi ;
- b := BitsPerBitset
- END
-END RotateLeft ;
-
-
-(*
- RotateRight - performs the rotate right for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-BEGIN
- RotateLeft(s, d, SetSizeInBits, SetSizeInBits-RotateCount)
-END RotateRight ;
-
-
END SYSTEM.
diff --git a/gcc/m2/gm2-libs/M2Diagnostic.def b/gcc/m2/gm2-libs/M2Diagnostic.def
new file mode 100644
index 000000000000..77a2d62364a9
--- /dev/null
+++ b/gcc/m2/gm2-libs/M2Diagnostic.def
@@ -0,0 +1,182 @@
+(* M2Diagnotic provides memory and time diagnosics to the user.
+
+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 M2Diagnostic ; (*!m2iso+gm2*)
+
+(*
+ Title : M2Diagnotic
+ Author : Gaius Mulley
+ System : GNU Modula-2
+ Date : Thu Jan 4 10:38:53 2024
+ Revision : $Version$
+ Description: provides memory and time diagnosics to the user.
+*)
+
+FROM DynamicStrings IMPORT String ;
+
+TYPE
+ Diagnostic ;
+ DiagProc = PROCEDURE (Diagnostic) ;
+
+
+(*
+ InitTimeDiagnostic - create and return a time diagnostic.
+ The format string can be free form and may
+ contain {1T}, {1C} or {1P}.
+ {1T} will contain the time and
+ {1C} the count of the number of times the
+ code enters the time diagnostic code region.
+ {1P} generates the time as a percentage.
+ {0T} is the total time for the application.
+ {{ is rendered as a single {.
+*)
+
+PROCEDURE InitTimeDiagnostic (name, format: ARRAY OF CHAR) : Diagnostic ;
+
+
+(*
+ EnterDiagnostic - attribute all execution time from now to TimeDiag.
+*)
+
+PROCEDURE EnterDiagnostic (TimeDiag: Diagnostic) ;
+
+
+(*
+ ExitDiagnostic - stop attributing execution time to TimeDiag.
+*)
+
+PROCEDURE ExitDiagnostic (TimeDiag: Diagnostic) ;
+
+
+(*
+ InitMemDiagnostic - create and return a memory diagnostic.
+ The format string can be free form and may
+ contain {1M} {1d} {1x} {1P}.
+ {1M} is replaced by the value of the first parameter
+ with memory size units.
+ {1d} unsigned decimal. {1x} unsigned hexadecimal.
+ {0M} is the global allocation (Storage.mod:ALLOCATE).
+ {1P} is the percentage of param 1 relative
+ to global memory.
+*)
+
+PROCEDURE InitMemDiagnostic (name, format: ARRAY OF CHAR) : Diagnostic ;
+
+
+(*
+ MemIncr - allow the appropriate parameter to be incremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*)
+
+PROCEDURE MemIncr (MemDiag: Diagnostic; paramno: CARDINAL; incr: CARDINAL) ;
+
+
+(*
+ MemDecr - allow the appropriate parameter to be decremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*)
+
+PROCEDURE MemDecr (MemDiag: Diagnostic; paramno: CARDINAL; decr: CARDINAL) ;
+
+
+(*
+ MemSet - allow the appropriate parameter to be set to value.
+ All parameters are initially set to zero.
+*)
+
+PROCEDURE MemSet (MemDiag: Diagnostic; paramno: CARDINAL; value: CARDINAL) ;
+
+
+(*
+ TotalHeapIncr - increments the total heap used.
+*)
+
+PROCEDURE TotalHeapIncr (incr: CARDINAL) ;
+
+
+(*
+ TotalHeapDecr - decrements the total heap used.
+*)
+
+PROCEDURE TotalHeapDecr (incr: CARDINAL) ;
+
+
+(*
+ SetEnable - set the enable flag in Diag to value.
+*)
+
+PROCEDURE SetEnable (Diag: Diagnostic; value: BOOLEAN) ;
+
+
+(*
+ Lookup - returns the Diagnostic containing name or NIL
+ if it does not exist.
+*)
+
+PROCEDURE Lookup (name: ARRAY OF CHAR) : Diagnostic ;
+
+
+(*
+ GetName - returns the name of Diag.
+*)
+
+PROCEDURE GetName (Diag: Diagnostic) : String ;
+
+
+(*
+ ForeachDiagDo - for diag in global diag list do
+ dp (diag);
+ end
+*)
+
+PROCEDURE ForeachDiagDo (dp: DiagProc) ;
+
+
+(*
+ SetDefaultConfig - force the Diag enable flag to the
+ time or mem global default.
+*)
+
+PROCEDURE SetDefaultConfig (Diag: Diagnostic) ;
+
+
+(*
+ Configure - will turn on or off all the memory or time
+ instrumentation diagnostics and set the defaults
+ time and mem values.
+*)
+
+PROCEDURE Configure (time, mem: BOOLEAN) ;
+
+
+(*
+ Generate - return a string containing the output from
+ all the diagnostics enabled. If hierarchical is TRUE
+ then the output is displayed in a hierarchical format
+ using the name and ':' separators to signify grouping.
+*)
+
+PROCEDURE Generate (hierarchical: BOOLEAN) : String ;
+
+
+END M2Diagnostic.
diff --git a/gcc/m2/gm2-libs/M2Diagnostic.mod b/gcc/m2/gm2-libs/M2Diagnostic.mod
new file mode 100644
index 000000000000..25988602d3e5
--- /dev/null
+++ b/gcc/m2/gm2-libs/M2Diagnostic.mod
@@ -0,0 +1,1049 @@
+(* M2Diagnotic provides memory and time diagnosics to the user.
+
+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 M2Diagnostic ; (*!m2iso+gm2*)
+
+FROM ASCII IMPORT nl ;
+FROM Selective IMPORT Timeval, GetTimeOfDay, InitTime, GetTime, SetTime ;
+FROM StringConvert IMPORT LongCardinalToString, ctos ;
+FROM Storage IMPORT ALLOCATE ;
+FROM Indexing IMPORT Index ;
+
+FROM DynamicStrings IMPORT InitString, ConCat, KillString, ConCatChar,
+ Equal, Mark, Length, char, RIndex ;
+
+IMPORT DynamicStrings, Indexing ;
+
+
+CONST
+ EnableDiagnostics = TRUE ; (* If set to FALSE then it will ensure
+ this module has minimal impact upon
+ the rest of the application. *)
+ DefaultTimeEnableValue = FALSE ; (* Should the diagnostics be
+ enabled by default. *)
+ DefaultMemEnableValue = FALSE ; (* Should the diagnostics be
+ enabled by default. *)
+
+ MaxParam = 4 ; (* The maximum number of parameters for a mem
+ diag. *)
+ MICROSEC = 1000 * 1000 ; (* The number of microseconds in a second. *)
+
+TYPE
+ Diagnostic = POINTER TO RECORD
+ name, format: String ;
+ enable : BOOLEAN ;
+ next : Diagnostic ;
+ CASE type: DiagType OF
+
+ timediag: tdiag: timeDiag |
+ memdiag : mdiag: memDiag
+
+ END
+ END ;
+
+ DiagType = (timediag, memdiag) ;
+
+ timeDiag = RECORD
+ count: CARDINAL ;
+ total,
+ enter,
+ exit : Timeval ;
+ END ;
+
+ memDiag = RECORD
+ param: ARRAY [1..MaxParam] OF LONGCARD ;
+ END ;
+
+VAR
+ Output : String ;
+ TotalHeap : LONGCARD ;
+ Head : Diagnostic ;
+ EnableHierarchical,
+ DefaultTimeEnable,
+ DefaultMemEnable : BOOLEAN ;
+ StartTime,
+ TotalTime : Timeval ;
+
+
+(*
+ Assert - halt if b is false.
+*)
+
+PROCEDURE Assert (b: BOOLEAN) ;
+BEGIN
+ IF NOT b
+ THEN
+ HALT
+ END
+END Assert ;
+
+
+(*
+ Error - generate a error simple message with indicating the
+ format specifier ch is incorrect.
+*)
+
+PROCEDURE Error (msg: ARRAY OF CHAR; ch: CHAR) ;
+BEGIN
+ HALT
+END Error ;
+
+
+(*
+ InitTimeDiagnostic - create and return a time diagnostic.
+ The format string can be free form and may
+ contain {1T}, {1C} or {1P}.
+ {1T} will contain the time and
+ {1C} the count of the number of times the
+ code enters the time diagnostic code region.
+ {1P} generates the time as a percentage.
+ {0T} is the total time for the application.
+ {{ is rendered as a single {.
+*)
+
+PROCEDURE InitTimeDiagnostic (name, format: ARRAY OF CHAR) : Diagnostic ;
+VAR
+ d: Diagnostic ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ NEW (d) ;
+ d^.name := InitString (name) ;
+ d^.format := InitString (format) ;
+ WITH d^ DO
+ enable := DefaultTimeEnable ;
+ next := Head ;
+ type := timediag ;
+ CASE type OF
+
+ timediag: tdiag.count := 0 ;
+ tdiag.total := InitTime (0, 0) ;
+ tdiag.enter := InitTime (0, 0) ;
+ tdiag.exit := InitTime (0, 0)
+
+ ELSE
+ HALT
+ END
+ END ;
+ Head := d ;
+ RETURN d
+ ELSE
+ RETURN NIL
+ END
+END InitTimeDiagnostic ;
+
+
+(*
+ EnterDiagnostic - attribute all execution time from now to TimeDiag.
+*)
+
+PROCEDURE EnterDiagnostic (TimeDiag: Diagnostic) ;
+BEGIN
+ IF EnableDiagnostics AND (TimeDiag # NIL)
+ THEN
+ Assert (TimeDiag^.type = timediag) ;
+ Assert (GetTimeOfDay (TimeDiag^.tdiag.enter) = 0) ;
+ INC (TimeDiag^.tdiag.count)
+ END
+END EnterDiagnostic ;
+
+
+(*
+ ExitDiagnostic - stop attributing execution time to TimeDiag.
+*)
+
+PROCEDURE ExitDiagnostic (TimeDiag: Diagnostic) ;
+BEGIN
+ IF EnableDiagnostics AND (TimeDiag # NIL)
+ THEN
+ Assert (TimeDiag^.tdiag.enter # NIL) ;
+ Assert (TimeDiag^.tdiag.exit # NIL) ;
+ Assert (TimeDiag^.tdiag.total # NIL) ;
+ Assert (TimeDiag^.type = timediag) ;
+ Assert (GetTimeOfDay (TimeDiag^.tdiag.exit) = 0) ;
+ Accumulate (TimeDiag^.tdiag.total, TimeDiag^.tdiag.enter, TimeDiag^.tdiag.exit)
+ END
+END ExitDiagnostic ;
+
+
+(*
+ Accumulate - total := total + exit - enter
+*)
+
+PROCEDURE Accumulate (total, enter, exit: Timeval) ;
+BEGIN
+ IncTime (total, exit) ;
+ DecTime (total, enter)
+END Accumulate ;
+
+
+(*
+ IncTime - left := left + right.
+*)
+
+PROCEDURE IncTime (left, right: Timeval) ;
+VAR
+ lsec, lusec,
+ rsec, rusec: CARDINAL ;
+BEGIN
+ GetTime (left, lsec, lusec) ;
+ GetTime (right, rsec, rusec) ;
+ IF lusec + rusec < MICROSEC
+ THEN
+ (* No carry *)
+ INC (lusec, rusec) ;
+ INC (lsec, rsec)
+ ELSE
+ INC (lusec, rusec) ;
+ DEC (lusec, MICROSEC) ;
+ INC (lsec, rsec + 1)
+ END ;
+ SetTime (left, lsec, lusec)
+END IncTime ;
+
+
+(*
+ DecTime - left := left - right.
+*)
+
+PROCEDURE DecTime (left, right: Timeval) ;
+VAR
+ lsec, lusec,
+ rsec, rusec: CARDINAL ;
+BEGIN
+ GetTime (left, lsec, lusec) ;
+ GetTime (right, rsec, rusec) ;
+ IF lusec >= rusec
+ THEN
+ (* No borrow. *)
+ DEC (lusec, rusec) ;
+ IF lsec >= rsec
+ THEN
+ DEC (lsec, rsec)
+ ELSE
+ lsec := 0
+ END
+ ELSE
+ IF lsec > 0
+ THEN
+ INC (lusec, MICROSEC) ;
+ DEC (lusec, rusec) ;
+ DEC (lsec) ;
+ IF lsec >= rsec
+ THEN
+ DEC (lsec, rsec)
+ ELSE
+ lsec := 0
+ END
+ ELSE
+ lsec := 0 ;
+ lusec := 0
+ END
+ END ;
+ SetTime (left, lsec, lusec)
+END DecTime ;
+
+
+(*
+ InitMemDiagnostic - create and return a memory diagnostic.
+ The format string can be free form and may
+ contain {1M} {1d} {1x} {1P}.
+ {1M} is replaced by the value of the first parameter
+ with memory size units.
+ {1d} unsigned decimal. {1x} unsigned hexadecimal.
+ {0M} is the global allocation (Storage.mod:ALLOCATE).
+ {1P} is the percentage of param 1 relative
+ to global memory.
+*)
+
+PROCEDURE InitMemDiagnostic (name, format: ARRAY OF CHAR) : Diagnostic ;
+VAR
+ i: CARDINAL ;
+ d: Diagnostic ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ NEW (d) ;
+ d^.name := InitString (name) ;
+ d^.format := InitString (format) ;
+ WITH d^ DO
+ enable := DefaultMemEnable ;
+ next := Head ;
+ type := memdiag ;
+ CASE type OF
+
+ memdiag: FOR i := 1 TO MaxParam DO
+ mdiag.param[i] := 0
+ END
+
+ ELSE
+ HALT
+ END
+ END ;
+ Head := d ;
+ RETURN d
+ ELSE
+ RETURN NIL
+ END
+END InitMemDiagnostic ;
+
+
+(*
+ CheckParam -
+*)
+
+PROCEDURE CheckParam (paramno: CARDINAL) ;
+BEGIN
+ IF (paramno < 1) OR (paramno > MaxParam)
+ THEN
+ HALT
+ END
+END CheckParam ;
+
+
+(*
+ MemIncr - allow the appropriate parameter to be incremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*)
+
+PROCEDURE MemIncr (MemDiag: Diagnostic; paramno: CARDINAL; incr: CARDINAL) ;
+BEGIN
+ IF EnableDiagnostics AND (MemDiag # NIL)
+ THEN
+ CheckParam (paramno) ;
+ CASE MemDiag^.type OF
+
+ memdiag: INC (MemDiag^.mdiag.param[paramno], VAL (LONGCARD, incr))
+
+ ELSE
+ HALT
+ END
+ END
+END MemIncr ;
+
+
+(*
+ MemDecr - allow the appropriate parameter to be decremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*)
+
+PROCEDURE MemDecr (MemDiag: Diagnostic; paramno: CARDINAL; decr: CARDINAL) ;
+BEGIN
+ IF EnableDiagnostics AND (MemDiag # NIL)
+ THEN
+ CheckParam (paramno) ;
+ CASE MemDiag^.type OF
+
+ memdiag: DEC (MemDiag^.mdiag.param[paramno], VAL (LONGCARD, decr))
+
+ ELSE
+ HALT
+ END
+ END
+END MemDecr ;
+
+
+(*
+ MemSet - allow the appropriate parameter to be set to value.
+ All parameters are initially set to zero.
+*)
+
+PROCEDURE MemSet (MemDiag: Diagnostic; paramno: CARDINAL; value: CARDINAL) ;
+BEGIN
+ IF EnableDiagnostics AND (MemDiag # NIL)
+ THEN
+ CheckParam (paramno) ;
+ CASE MemDiag^.type OF
+
+ memdiag: MemDiag^.mdiag.param[paramno] := VAL (LONGCARD, value)
+
+ ELSE
+ HALT
+ END
+ END
+END MemSet ;
+
+
+(*
+ TotalHeapIncr - increments the total heap used.
+*)
+
+PROCEDURE TotalHeapIncr (incr: CARDINAL) ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ TotalHeap := TotalHeap + VAL (LONGCARD, incr)
+ END
+END TotalHeapIncr ;
+
+
+(*
+ TotalHeapDecr - decrements the total heap used.
+*)
+
+PROCEDURE TotalHeapDecr (incr: CARDINAL) ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ TotalHeap := TotalHeap - VAL (LONGCARD, incr)
+ END
+END TotalHeapDecr ;
+
+
+(*
+ SetEnable - set the enable flag in Diag to value.
+*)
+
+PROCEDURE SetEnable (Diag: Diagnostic; value: BOOLEAN) ;
+BEGIN
+ IF EnableDiagnostics AND (Diag # NIL)
+ THEN
+ Diag^.enable := value
+ END
+END SetEnable ;
+
+
+(*
+ Lookup - returns the Diagnostic containing name or NIL
+ if it does not exist.
+*)
+
+PROCEDURE Lookup (name: ARRAY OF CHAR) : Diagnostic ;
+VAR
+ ptr: Diagnostic ;
+ s : String ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ s := InitString (name) ;
+ ptr := Head ;
+ WHILE ptr # NIL DO
+ IF Equal (ptr^.name, s)
+ THEN
+ s := KillString (s) ;
+ RETURN ptr
+ END ;
+ ptr := ptr^.next
+ END ;
+ s := KillString (s) ;
+ RETURN NIL
+ ELSE
+ RETURN NIL
+ END
+END Lookup ;
+
+
+(*
+ ForeachDiagDo - for diag in global diag list do
+ dp (diag);
+ end
+*)
+
+PROCEDURE ForeachDiagDo (dp: DiagProc) ;
+VAR
+ ptr: Diagnostic ;
+BEGIN
+ ptr := Head ;
+ WHILE ptr # NIL DO
+ dp (ptr) ;
+ ptr := ptr^.next
+ END
+END ForeachDiagDo ;
+
+
+(*
+ SetDefaultConfig - force the Diag enable flag to the
+ time or mem global default.
+*)
+
+PROCEDURE SetDefaultConfig (Diag: Diagnostic) ;
+BEGIN
+ IF Diag^.type = timediag
+ THEN
+ Diag^.enable := DefaultTimeEnable
+ ELSE
+ Diag^.enable := DefaultMemEnable
+ END
+END SetDefaultConfig ;
+
+
+(*
+ Configure - will turn on or off all the memory or time
+ instrumentation diagnostics and set the defaults
+ time and mem values.
+*)
+
+PROCEDURE Configure (time, mem: BOOLEAN) ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ DefaultTimeEnable := time ;
+ DefaultMemEnable := mem ;
+ ForeachDiagDo (SetDefaultConfig)
+ END
+END Configure ;
+
+
+(*
+ CreateStartTime -
+*)
+
+PROCEDURE CreateStartTime ;
+BEGIN
+ IF EnableDiagnostics
+ THEN
+ IF StartTime = NIL
+ THEN
+ StartTime := InitTime (0, 0) ;
+ IF GetTimeOfDay (StartTime) = 0
+ THEN
+ END
+ END ;
+ IF TotalTime = NIL
+ THEN
+ TotalTime := InitTime (0, 0)
+ END
+ ELSE
+ StartTime := NIL ;
+ TotalTime := NIL
+ END
+END CreateStartTime ;
+
+
+(*
+ UpdateTotalTime -
+*)
+
+PROCEDURE UpdateTotalTime ;
+BEGIN
+ IF GetTimeOfDay (TotalTime) = 0
+ THEN
+ END ;
+ DecTime (TotalTime, StartTime)
+END UpdateTotalTime ;
+
+
+(*
+ GetTimeParam - a paramno of 0 will return the total time so far
+ whereas a paramno > 0 will return the time associated
+ with Diag.
+*)
+
+PROCEDURE GetTimeParam (Diag: Diagnostic; paramno: CARDINAL) : Timeval ;
+VAR
+ sec, usec: CARDINAL ;
+BEGIN
+ IF paramno = 0
+ THEN
+ UpdateTotalTime ;
+ RETURN TotalTime
+ ELSE
+ RETURN Diag^.tdiag.total
+ END
+END GetTimeParam ;
+
+
+(*
+ GetMemParam - return the mem paramno from within Diag. A paramno of 0
+ will return the total heap.
+*)
+
+PROCEDURE GetMemParam (Diag: Diagnostic; paramno: CARDINAL) : LONGCARD ;
+BEGIN
+ IF paramno = 0
+ THEN
+ RETURN TotalHeap
+ ELSE
+ RETURN Diag^.mdiag.param[paramno]
+ END
+END GetMemParam ;
+
+
+(*
+ CreateDecimalMem - converts c to a decimal string.
+*)
+
+PROCEDURE CreateDecimalMem (c: LONGCARD) : String ;
+BEGIN
+ RETURN LongCardinalToString (c, 0, ' ', 10, TRUE)
+END CreateDecimalMem ;
+
+
+(*
+ CreateHexadecimalMem - converts c to a hexadecimal string.
+*)
+
+PROCEDURE CreateHexadecimalMem (c: LONGCARD) : String ;
+BEGIN
+ RETURN ConCat (InitString ('0x'),
+ Mark (LongCardinalToString (c, 0, ' ', 16, TRUE)))
+END CreateHexadecimalMem ;
+
+
+(*
+ CreateDecimalTime - return timeval as a decimal seconds.usecs string.
+*)
+
+PROCEDURE CreateDecimalTime (timeval: Timeval) : String ;
+VAR
+ sec, usec: CARDINAL ;
+BEGIN
+ GetTime (timeval, sec, usec) ;
+ RETURN ConCat (ConCat (LongCardinalToString (sec, 0, ' ', 10, TRUE),
+ Mark (InitString ('.'))),
+ LongCardinalToString (usec, 6, '0', 10, TRUE))
+END CreateDecimalTime ;
+
+
+(*
+ CreateHexadecimalTime - return timeval as a hexadecimal seconds.usecs string.
+*)
+
+PROCEDURE CreateHexadecimalTime (timeval: Timeval) : String ;
+VAR
+ sec, usec: CARDINAL ;
+BEGIN
+ GetTime (timeval, sec, usec) ;
+ RETURN ConCat (ConCat (LongCardinalToString (sec, 0, ' ', 16, TRUE),
+ Mark (InitString ('.'))),
+ LongCardinalToString (usec, 5, '0', 16, TRUE))
+END CreateHexadecimalTime ;
+
+
+(*
+ Decimal - convert paramno in Diag to a string.
+*)
+
+PROCEDURE Decimal (Diag: Diagnostic; paramno: CARDINAL) : String ;
+BEGIN
+ CASE Diag^.type OF
+
+ memdiag : RETURN CreateDecimalMem (GetMemParam (Diag, paramno)) |
+ timediag: RETURN CreateDecimalTime (GetTimeParam (Diag, paramno))
+
+ END ;
+ RETURN NIL
+END Decimal ;
+
+
+(*
+ Hexadecimal - convert paramno in Diag to a hex string.
+*)
+
+PROCEDURE Hexadecimal (Diag: Diagnostic; paramno: CARDINAL) : String ;
+BEGIN
+ CASE Diag^.type OF
+
+ memdiag : RETURN CreateHexadecimalMem (GetMemParam (Diag, paramno)) |
+ timediag: RETURN CreateHexadecimalTime (GetTimeParam (Diag, paramno))
+
+ END ;
+ RETURN NIL
+END Hexadecimal ;
+
+
+(*
+ Count - return the count field for a time diag or return the decimal
+ value for a paramno in a mem diag.
+*)
+
+PROCEDURE Count (Diag: Diagnostic; paramno: CARDINAL) : String ;
+BEGIN
+ CASE Diag^.type OF
+
+ memdiag : RETURN CreateDecimalMem (GetMemParam (Diag, paramno)) |
+ timediag: RETURN ctos (Diag^.tdiag.count, 0, ' ')
+
+ END ;
+ RETURN NIL
+END Count ;
+
+
+(*
+ Microsec - convert timeval into microseconds and return the value as
+ a longcard.
+*)
+
+PROCEDURE Microsec (timeval: Timeval) : LONGCARD ;
+VAR
+ sec, usec: CARDINAL ;
+ microsec : LONGCARD ;
+BEGIN
+ GetTime (timeval, sec, usec) ;
+ microsec := VAL (LONGCARD, sec) * MICROSEC + VAL (LONGCARD, usec) ;
+ RETURN microsec
+END Microsec ;
+
+
+(*
+ CreateTimePercent - return timeval as a percentage of the TotalTime.
+*)
+
+PROCEDURE CreateTimePercent (timeval: Timeval) : String ;
+VAR
+ total, param: LONGCARD ;
+BEGIN
+ IF timeval = TotalTime
+ THEN
+ param := 100
+ ELSE
+ UpdateTotalTime ;
+ param := Microsec (timeval) * 100 ;
+ total := Microsec (TotalTime) ;
+ IF total = 0
+ THEN
+ param := 0
+ ELSE
+ param := param DIV total
+ END
+ END ;
+ RETURN ConCatChar (ctos (VAL (CARDINAL, param), 3, ' '), '%')
+END CreateTimePercent ;
+
+
+(*
+ CreateMemPercent - return memval as a percentage of TotalHeap.
+*)
+
+PROCEDURE CreateMemPercent (memval: LONGCARD) : String ;
+VAR
+ param: LONGCARD ;
+BEGIN
+ IF memval = TotalHeap
+ THEN
+ param := 100
+ ELSE
+ param := memval * 100 ;
+ IF TotalHeap = 0
+ THEN
+ param := 0
+ ELSE
+ param := param DIV TotalHeap
+ END
+ END ;
+ RETURN ConCatChar (ctos (VAL (CARDINAL, param), 3, ' '), '%')
+END CreateMemPercent ;
+
+
+(*
+ DescribePercent - call the appropriate mem or time percentage procedure.
+*)
+
+PROCEDURE DescribePercent (Diag: Diagnostic; paramno: CARDINAL) : String ;
+BEGIN
+ CASE Diag^.type OF
+
+ memdiag : RETURN CreateMemPercent (GetMemParam (Diag, paramno)) |
+ timediag: RETURN CreateTimePercent (GetTimeParam (Diag, paramno))
+
+ END ;
+ RETURN NIL
+END DescribePercent ;
+
+
+(*
+ DescribeMemory - return the memory diagnostic
+*)
+
+PROCEDURE DescribeMemory (Diag: Diagnostic; paramno: CARDINAL) : String ;
+CONST
+ kilo = 1024 ;
+ mega = kilo * kilo ;
+ giga = mega * kilo ;
+VAR
+ param: LONGCARD ;
+ s : String ;
+BEGIN
+ param := GetMemParam (Diag, paramno) ;
+ IF param < kilo
+ THEN
+ s := ConCat (LongCardinalToString (param, 0, ' ', 10, FALSE),
+ Mark (InitString (' Bytes')))
+ ELSIF param < mega
+ THEN
+ param := param DIV kilo ;
+ s := ConCat (LongCardinalToString (param, 0, ' ', 10, FALSE),
+ Mark (InitString ('KB')))
+ ELSIF param < giga
+ THEN
+ param := param DIV mega ;
+ s := ConCat (LongCardinalToString (param, 0, ' ', 10, FALSE),
+ Mark (InitString ('MB')))
+ ELSE
+ param := param DIV giga ;
+ s := ConCat (LongCardinalToString (param, 0, ' ', 10, FALSE),
+ Mark (InitString ('GB')))
+ END ;
+ RETURN s
+END DescribeMemory ;
+
+
+(*
+ DescribeTime - returns the time diagnostic in seconds.
+*)
+
+PROCEDURE DescribeTime (Diag: Diagnostic; paramno: CARDINAL) : String ;
+VAR
+ sec, usec: CARDINAL ;
+BEGIN
+ CASE Diag^.type OF
+
+ memdiag : HALT |
+ timediag: GetTime (GetTimeParam (Diag, paramno), sec, usec) ;
+ RETURN ConCat (ConCat (LongCardinalToString (sec, 0, ' ', 10, TRUE),
+ Mark (InitString ('.'))),
+ ConCat (LongCardinalToString (usec, 6, '0', 10, TRUE),
+ Mark (InitString (' sec'))))
+
+ END ;
+ RETURN NIL
+END DescribeTime ;
+
+
+(*
+ ParamSpec - ebnf:
+
+ ( '{' | '0' | '1' | '2' | '3' | '4' )
+ ( 'd' | 'x' | 'C' | 'H' | 'T' | 'M' | 'N' | 'P' )
+ '}'
+*)
+
+PROCEDURE ParamSpec (Diag: Diagnostic; i: CARDINAL) : CARDINAL ;
+VAR
+ paramno,
+ length : CARDINAL ;
+ ch : CHAR ;
+BEGIN
+ length := Length (Diag^.format) ;
+ paramno := 0 ;
+ IF i < length
+ THEN
+ ch := char (Diag^.format, i) ;
+ CASE ch OF
+
+ '{': Output := ConCatChar (Output, '{') ;
+ RETURN i + 1 |
+ '0': paramno := 0 |
+ '1': paramno := 1 |
+ '2': paramno := 2 |
+ '3': paramno := 3 |
+ '4': paramno := 4
+
+ ELSE
+ Error ('unexpected character: ', ch)
+ END ;
+ INC (i) ;
+ IF i < length
+ THEN
+ ch := char (Diag^.format, i) ;
+ CASE ch OF
+
+ 'd': Output := ConCat (Output, Decimal (Diag, paramno)) |
+ 'x': Output := ConCat (Output, Hexadecimal (Diag, paramno)) |
+ 'C': Output := ConCat (Output, Count (Diag, paramno)) |
+ 'H': Output := ConCat (Output, HierarchicalName (Diag, i)) |
+ 'M': Output := ConCat (Output, DescribeMemory (Diag, paramno)) |
+ 'N': Output := ConCat (Output, Diag^.name) |
+ 'P': Output := ConCat (Output, DescribePercent (Diag, paramno)) |
+ 'T': Output := ConCat (Output, DescribeTime (Diag, paramno))
+
+ ELSE
+ Error ('unexpected character: ', ch)
+ END ;
+ INC (i) ;
+ IF i < length
+ THEN
+ ch := char (Diag^.format, i) ;
+ IF ch # '}'
+ THEN
+ Error ('expected } character, seen ', ch)
+ END
+ END
+ END
+ END ;
+ RETURN i + 1
+END ParamSpec ;
+
+
+(*
+ HierarchicalName - if the hierarchical formatting of output
+ has been enabled use the last component
+ of the name separated by ':' else
+ output full name.
+*)
+
+PROCEDURE HierarchicalName (Diag: Diagnostic; pos: CARDINAL) : String ;
+VAR
+ i, j: INTEGER ;
+BEGIN
+ IF EnableHierarchical
+ THEN
+ i := DynamicStrings.Index (Diag^.name, '}', pos) ;
+ IF i > 0
+ THEN
+ j := i - 1 ;
+ i := RIndex (Diag^.name, ':', j) ;
+ IF (i >= 0) AND (i < j)
+ THEN
+ RETURN DynamicStrings.Slice (Diag^.name, i, j)
+ END
+ END
+ END ;
+ RETURN Diag^.name
+END HierarchicalName ;
+
+
+(*
+ FormatDiag - ebnf:
+
+ { ( '{' ParamSpec ) | any }
+*)
+
+PROCEDURE FormatDiag (Diag: Diagnostic) ;
+VAR
+ i, length: CARDINAL ;
+ ch : CHAR ;
+BEGIN
+ i := 0 ;
+ length := Length (Diag^.format) ;
+ WHILE i < length DO
+ ch := char (Diag^.format, i) ;
+ IF ch = '{'
+ THEN
+ INC (i) ;
+ i := ParamSpec (Diag, i)
+ ELSE
+ Output := ConCatChar (Output, ch) ;
+ INC (i)
+ END
+ END ;
+ Output := ConCatChar (Output, nl)
+END FormatDiag ;
+
+
+(*
+ GetName - returns the name of Diag.
+*)
+
+PROCEDURE GetName (Diag: Diagnostic) : String ;
+BEGIN
+ IF EnableDiagnostics AND (Diag # NIL)
+ THEN
+ RETURN Diag^.name
+ ELSE
+ RETURN NIL
+ END
+END GetName ;
+
+
+(*
+ Match -
+*)
+
+PROCEDURE Match (stem, name: String) : BOOLEAN ;
+BEGIN
+ RETURN TRUE
+END Match ;
+
+
+(*
+ HierarchicalDiag - iterate over every diagnostic using a depth first search
+ for each component of the diagnostic name.
+*)
+
+PROCEDURE HierarchicalDiag (stem: String; visited: Index) : String ;
+VAR
+ diag: Diagnostic ;
+BEGIN
+ diag := Head ;
+ WHILE diag # NIL DO
+ IF NOT Indexing.IsIndiceInIndex (visited, diag)
+ THEN
+ IF Match (stem, diag^.name)
+ THEN
+ Indexing.IncludeIndiceIntoIndex (visited, diag)
+ END
+ END ;
+ diag := diag^.next
+ END ;
+ RETURN Output
+END HierarchicalDiag ;
+
+
+(*
+ GenerateRaw - return the output string after calling FormatDiag on
+ every diagnostic rule.
+*)
+
+PROCEDURE GenerateRaw () : String ;
+BEGIN
+ ForeachDiagDo (FormatDiag) ;
+ RETURN Output
+END GenerateRaw ;
+
+
+(*
+ GenerateHierarchical -
+*)
+
+PROCEDURE GenerateHierarchical () : String ;
+BEGIN
+ RETURN HierarchicalDiag (InitString (''), Indexing.InitIndex (1))
+END GenerateHierarchical ;
+
+
+(*
+ Generate - return a string containing the output from
+ all the diagnostics enabled.
+*)
+
+PROCEDURE Generate (hierarchical: BOOLEAN) : String ;
+BEGIN
+ EnableHierarchical := hierarchical ;
+ IF EnableDiagnostics
+ THEN
+ Output := KillString (Output) ;
+ Output := InitString ('') ;
+ IF hierarchical
+ THEN
+ RETURN GenerateHierarchical ()
+ ELSE
+ RETURN GenerateRaw ()
+ END
+ ELSE
+ RETURN NIL
+ END
+END Generate ;
+
+
+BEGIN
+ TotalHeap := 0 ;
+ StartTime := NIL ;
+ TotalTime := NIL ;
+ CreateStartTime ;
+ Head := NIL ;
+ Output := NIL ;
+ EnableHierarchical := FALSE ;
+ DefaultTimeEnable := DefaultTimeEnableValue ;
+ DefaultMemEnable := DefaultMemEnableValue ;
+END M2Diagnostic.
diff --git a/gcc/m2/gm2-libs/M2WIDESET.def b/gcc/m2/gm2-libs/M2WIDESET.def
new file mode 100644
index 000000000000..5369d7baddd8
--- /dev/null
+++ b/gcc/m2/gm2-libs/M2WIDESET.def
@@ -0,0 +1,210 @@
+(* M2WIDESET.def runtime support procedures for wide sets.
+
+Copyright (C) 2025 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. *)
+
+DEFINITION MODULE M2WIDESET ;
+
+(*
+ Title : M2WIDESET
+ Author : Gaius Mulley
+ System : GNU Modula-2
+ Date : Thu Nov 16 19:57:31 2023
+ Description: provides runtime capability for wide sets.
+*)
+
+FROM SYSTEM IMPORT BYTE ;
+
+
+(*
+ Or - dest = left | right
+ implement OR for a wide set type.
+*)
+
+PROCEDURE Or (VAR dest: ARRAY OF BYTE; left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+
+
+(*
+ And - dest = left & right
+ implement AND for a wide set type.
+*)
+
+PROCEDURE And (VAR dest: ARRAY OF BYTE; left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+
+
+(*
+ Not - dest = ~ operand
+ implement AND for a wide set type.
+*)
+
+PROCEDURE Not (VAR dest: ARRAY OF BYTE; expr: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+
+
+(*
+ Incl - dest |= bit
+ implement INCL for a wide set type.
+*)
+
+PROCEDURE Incl (VAR dest: ARRAY OF BYTE; bit: CARDINAL) ;
+
+
+(*
+ Excl - dest &= (~ bit)
+ implement EXCL for a wide set type.
+*)
+
+PROCEDURE Excl (VAR dest: ARRAY OF BYTE; bit: CARDINAL) ;
+
+
+(*
+ In - return bit IN expr.
+*)
+
+PROCEDURE In (VAR expr: ARRAY OF BYTE; bit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ Equal - return left = right.
+*)
+
+PROCEDURE Equal (VAR left, right: ARRAY OF BYTE; highbit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ Clear - dest = {}.
+*)
+
+PROCEDURE Clear (VAR dest: ARRAY OF BYTE; highbit: CARDINAL) ;
+
+
+(*
+ Shift - dest := SHIFT (src, ShiftCount). This is a logical shift
+ all the new bit values will be zero.
+*)
+
+PROCEDURE Shift (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL; ShiftCount: INTEGER) ;
+
+
+(*
+ ArithShift - dest := ArithShift (dest, ShiftCount, carry). This is an
+ arithmetic shift all the new bit values will
+ be set to carry.
+*)
+
+PROCEDURE ArithShift (VAR dest: ARRAY OF BYTE;
+ highbit: CARDINAL; ShiftCount: INTEGER;
+ carry: BOOLEAN) ;
+
+
+(*
+ Rotate - is a runtime procedure whose job is to implement
+ the ROTATE procedure of ISO SYSTEM.
+*)
+
+PROCEDURE Rotate (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL; RotateCount: INTEGER) ;
+
+(*
+ Less - performs the set comparison for a wide set.
+ Less returns ProperSubset (left, right, highbit).
+*)
+
+PROCEDURE Less (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ LessEqu - performs the set comparison for a wide set.
+ LessEqu returns Equal (left, right, highbit) OR
+ ProperSubset (left, right, highbit).
+*)
+
+PROCEDURE LessEqu (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ Gre - performs the set comparison for a wide set.
+ Gre returns the result of
+ ProperSuperet (left, right, highbit).
+*)
+
+PROCEDURE Gre (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ GreEqu - performs the set comparison for a wide set.
+ GreEqu returns Equal (left, right, highbit) OR
+ ProperSuperet (left, right, highbit).
+*)
+
+PROCEDURE GreEqu (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+(*
+ ProperSubset - return TRUE if left is a proper subset of right.
+ If true the left set will have at least one element
+ less than set right.
+*)
+
+PROCEDURE ProperSubset (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ ProperSuperset - return TRUE if left is a proper superset of right.
+ If true the left set will have at least one element
+ more than set right.
+*)
+
+PROCEDURE ProperSuperset (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+
+(*
+ LogicalDifference - build a logical difference expression tree.
+ dest := left and (not right).
+*)
+
+PROCEDURE LogicalDifference (VAR dest: ARRAY OF BYTE;
+ left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+
+
+(*
+ SymmetricDifference - build a logical difference expression tree.
+ dest := left xor right.
+*)
+
+PROCEDURE SymmetricDifference (VAR dest: ARRAY OF BYTE;
+ left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+
+
+END M2WIDESET.
diff --git a/gcc/m2/gm2-libs/M2WIDESET.mod b/gcc/m2/gm2-libs/M2WIDESET.mod
new file mode 100644
index 000000000000..f1b1bed3b3f3
--- /dev/null
+++ b/gcc/m2/gm2-libs/M2WIDESET.mod
@@ -0,0 +1,1259 @@
+(* M2WIDESET.mod runtime support procedures for wide sets.
+
+Copyright (C) 2023 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. *)
+
+IMPLEMENTATION MODULE M2WIDESET ;
+
+FROM SYSTEM IMPORT TBITSIZE, ADDRESS, ADR, SHIFT ;
+FROM Builtins IMPORT memcpy, memset ;
+FROM libc IMPORT printf ;
+
+TYPE
+ BYTESET = PACKEDSET OF [0..7] ;
+ PtrToByteset = POINTER TO BYTESET ;
+ PtrToBitset = POINTER TO BITSET ;
+
+
+CONST
+ EnableOptimizeBitset = TRUE ;
+ EnableDebugging = FALSE ;
+
+
+(*
+ BitsPerByteset = TSIZE (BYTESET) * 8 ;
+*)
+
+
+(*
+ DumpSet -
+*)
+
+PROCEDURE DumpSet (set: ARRAY OF BYTE; highbit: CARDINAL) ;
+VAR
+ count,
+ i, high: CARDINAL ;
+ last : BYTE ;
+BEGIN
+ high := HIGH (set) ;
+ printf ("set highbit = %d, high indice = %d\n", highbit, high) ;
+ printf ("{ ") ;
+ last := set[0] ;
+ i := 1 ;
+ count := 1 ;
+ printf (" 0: 0x%02x", VAL (CARDINAL, last)) ;
+ WHILE i <= high DO
+ IF last = set[i]
+ THEN
+ INC (count)
+ ELSE
+ IF count > 1
+ THEN
+ printf (" x %d, %d: 0x%02x", count, i, VAL (CARDINAL, set[i]))
+ ELSE
+ IF i > 0
+ THEN
+ printf (",")
+ END ;
+ printf (" %d: 0x%02x", i, VAL (CARDINAL, set[i]))
+ END ;
+ last := set[i] ;
+ count := 1
+ END ;
+ INC (i)
+ END ;
+ IF count > 1
+ THEN
+ printf (" x %d ", count)
+ END ;
+ printf (" }\n")
+END DumpSet ;
+
+
+(*
+ Or - dest = left | right
+ implement OR for a wide set type.
+*)
+
+PROCEDURE Or (VAR dest: ARRAY OF BYTE; left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+ byteset: BYTESET ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("left\n");
+ DumpSet (left, highbit) ;
+ printf ("right\n");
+ DumpSet (right, highbit)
+ END ;
+ high := HIGH (dest) ;
+ i := 0 ;
+ WHILE i < high DO
+ IF EnableDebugging
+ THEN
+ printf ("%02x or %02x", left[i], right[i])
+ END ;
+ dest[i] := BYTESET (left[i]) + BYTESET (right[i]) ;
+ IF EnableDebugging
+ THEN
+ printf (" -> %02x\n", dest[i])
+ END ;
+ INC (i)
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ dest[i] := BYTESET (left[i]) + BYTESET (right[i])
+ ELSE
+ byteset := dest[i] ;
+ FOR bit := 0 TO lastbit DO
+ IF (bit IN BYTESET (left[i])) OR (bit IN BYTESET (right[i]))
+ THEN
+ INCL (byteset, bit)
+ ELSE
+ EXCL (byteset, bit)
+ END
+ END ;
+ dest[i] := byteset
+ END
+ ELSE
+ HALT
+ END
+END Or ;
+
+
+(*
+ And - dest = left & right
+ implement AND for a wide set type.
+*)
+
+PROCEDURE And (VAR dest: ARRAY OF BYTE; left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+ byteset: BYTESET ;
+BEGIN
+ high := HIGH (dest) ;
+ i := 0 ;
+ WHILE i < high DO
+ dest[i] := BYTESET (left[i]) * BYTESET (right[i]) ;
+ INC (i)
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ dest[i] := BYTESET (left[i]) * BYTESET (right[i])
+ ELSE
+ byteset := dest[i] ;
+ FOR bit := 0 TO lastbit DO
+ IF (bit IN BYTESET (left[i])) AND (bit IN BYTESET (right[i]))
+ THEN
+ INCL (byteset, bit)
+ ELSE
+ EXCL (byteset, bit)
+ END
+ END ;
+ dest[i] := byteset
+ END
+ ELSE
+ HALT
+ END
+END And ;
+
+
+(*
+ Not - dest = ~ expr
+ implement NOT for a wide set type.
+*)
+
+PROCEDURE Not (VAR dest: ARRAY OF BYTE; expr: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+ byteset: BYTESET ;
+BEGIN
+ high := HIGH (dest) ;
+ i := 0 ;
+ WHILE i < high DO
+ dest[i] := - BYTESET (expr[i]) ;
+ INC (i)
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ dest[i] := - BYTESET (expr[i])
+ ELSE
+ byteset := dest[i] ;
+ FOR bit := 0 TO lastbit DO
+ IF bit IN BYTESET (expr[i])
+ THEN
+ EXCL (byteset, bit)
+ ELSE
+ INCL (byteset, bit)
+ END
+ END ;
+ dest[i] := byteset
+ END
+ ELSE
+ HALT
+ END
+END Not ;
+
+
+(*
+ Incl - dest |= bit
+ implement INCL for a wide set type.
+*)
+
+PROCEDURE Incl (VAR dest: ARRAY OF BYTE; bit: CARDINAL) ;
+VAR
+ byteset: BYTESET ;
+ byteno,
+ bitno,
+ high : CARDINAL ;
+BEGIN
+ high := HIGH (dest) ;
+ byteno := bit DIV TBITSIZE (BYTE) ;
+ bitno := bit MOD TBITSIZE (BYTE) ;
+ IF byteno <= high
+ THEN
+ byteset := BYTESET (dest[byteno]) ;
+ INCL (byteset, bitno) ;
+ dest[byteno] := byteset
+ ELSE
+ HALT
+ END
+END Incl ;
+
+
+(*
+ Excl - dest &= (~ bit)
+ implement EXCL for a wide set type.
+*)
+
+PROCEDURE Excl (VAR dest: ARRAY OF BYTE; bit: CARDINAL) ;
+VAR
+ byteset: BYTESET ;
+ byteno,
+ bitno,
+ high : CARDINAL ;
+BEGIN
+ high := HIGH (dest) ;
+ byteno := bit DIV TBITSIZE (BYTE) ;
+ bitno := bit MOD TBITSIZE (BYTE) ;
+ IF byteno <= high
+ THEN
+ byteset := BYTESET (dest[byteno]) ;
+ EXCL (byteset, bitno) ;
+ dest[byteno] := byteset
+ ELSE
+ HALT
+ END
+END Excl ;
+
+
+(*
+ In - return bit IN expr.
+*)
+
+PROCEDURE In (VAR expr: ARRAY OF BYTE; bit: CARDINAL) : BOOLEAN ;
+VAR
+ byteno,
+ bitno,
+ high : CARDINAL ;
+BEGIN
+ high := HIGH (expr) ;
+ byteno := bit DIV TBITSIZE (BYTE) ;
+ bitno := bit MOD TBITSIZE (BYTE) ;
+ IF byteno <= high
+ THEN
+ RETURN bitno IN BYTESET (expr[byteno])
+ ELSE
+ HALT
+ END
+END In ;
+
+
+(*
+ Empty - return TRUE if expr = {}.
+*)
+
+PROCEDURE Empty (expr: ARRAY OF BYTE; highbit: CARDINAL) : BOOLEAN ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+BEGIN
+ high := HIGH (expr) ;
+ i := 0 ;
+ WHILE i < high DO
+ IF expr[i] # BYTE (0)
+ THEN
+ RETURN FALSE
+ END ;
+ INC (i)
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ RETURN expr[i] = BYTE (0)
+ ELSE
+ FOR bit := 0 TO lastbit DO
+ IF bit IN BYTESET (expr[i])
+ THEN
+ RETURN FALSE
+ END
+ END
+ END
+ ELSE
+ HALT
+ END ;
+ RETURN TRUE
+END Empty ;
+
+
+(*
+ Clear - set dest := {}.
+*)
+
+PROCEDURE Clear (VAR dest: ARRAY OF BYTE; highbit: CARDINAL) ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+ byteset: BYTESET ;
+BEGIN
+ high := HIGH (dest) ;
+ IF EnableOptimizeBitset
+ THEN
+ IF memset (ADR (dest), 0, high) = NIL
+ THEN
+ END ;
+ i := high
+ ELSE
+ i := 0 ;
+ WHILE i < high DO
+ dest[i] := BYTE (0) ;
+ INC (i)
+ END
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ dest[i] := BYTE (0)
+ ELSE
+ byteset := dest[i] ;
+ FOR bit := 0 TO lastbit DO
+ EXCL (byteset, bit)
+ END ;
+ dest[i] := byteset
+ END
+ ELSE
+ HALT
+ END
+END Clear ;
+
+
+(*
+ Equal - return left = right.
+*)
+
+PROCEDURE Equal (VAR left, right: ARRAY OF BYTE; highbit: CARDINAL) : BOOLEAN ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit : CARDINAL ;
+ rptr, lptr: PtrToByteset ;
+ lb, rb : BOOLEAN ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("Equal left : ");
+ DumpSet (left, highbit) ;
+ printf (" right: ");
+ DumpSet (right, highbit) ;
+ END ;
+
+ high := HIGH (left) ;
+ IF high = HIGH (right)
+ THEN
+ i := 0 ;
+ WHILE i < high DO
+ IF left[i] # right[i]
+ THEN
+ RETURN FALSE
+ END ;
+ INC (i)
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 7
+ THEN
+ (* All bits 0..7 inclusive can be tested. *)
+ RETURN left[i] = right[i]
+ END ;
+ rptr := ADR (right[i]) ;
+ lptr := ADR (left[i]) ;
+ (* Only check the bits in the set which are used in the last byte. *)
+ FOR bit := 0 TO lastbit DO
+ (*
+ IF (bit IN rptr^) # (bit IN lptr^)
+ THEN
+ RETURN FALSE
+ END
+ *)
+ lb := bit IN lptr^ ; (* Replace with the above - when the bug is fixed. *)
+ rb := bit IN rptr^ ;
+ IF lb # rb
+ THEN
+ RETURN FALSE
+ END
+ END
+ END
+ ELSE
+ HALT
+ END ;
+ RETURN TRUE
+END Equal ;
+
+
+(*
+ ShiftLeft - performs the shift left for a multi word set.
+*)
+
+PROCEDURE ShiftLeft (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL;
+ ShiftCount: CARDINAL) ;
+VAR
+ byteshift,
+ bitshift : CARDINAL ;
+BEGIN
+ byteshift := ShiftCount DIV TBITSIZE (BYTESET) ;
+ bitshift := ShiftCount MOD TBITSIZE (BYTESET) ;
+ ShiftLeftByteBit (dest, src, highbit, byteshift, bitshift)
+END ShiftLeft ;
+
+
+(*
+ ShiftLeftByteBit - shifts src left by byteshift and bitshift. It
+ moves the bottom bitshift bits from lo into the
+ first byte.
+*)
+
+PROCEDURE ShiftLeftByteBit (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL;
+ byteshift, bitshift: CARDINAL) ;
+VAR
+ top, bot, mid : BYTESET ;
+ i, h, from, to: CARDINAL ;
+BEGIN
+ (* Copy the bytes into dest at the mostly correct position
+ (modulo byte position). *)
+ to := 0 ;
+ from := 0 ;
+ WHILE to < byteshift DO
+ dest[to] := BYTE (0) ;
+ INC (to)
+ END ;
+ WHILE to <= HIGH (dest) DO
+ dest[to] := src[from] ;
+ INC (to) ;
+ INC (from)
+ END ;
+ (* And adjust by bit shifting. *)
+ IF bitshift > 0
+ THEN
+ bot := BYTE (0) ;
+ h := HIGH (dest) ;
+ i := 0 ;
+ WHILE i < h DO
+ mid := dest[i] ;
+ (* Shift right by TBITSIZE (BYTE) - bitshift. *)
+ top := SHIFT (mid, - INTEGER ((TBITSIZE (BYTE) - bitshift))) ; (* Right must be negative. *)
+ mid := SHIFT (mid, bitshift) ; (* Shift left. *)
+ dest[i] := mid + bot ;
+ bot := top ;
+ INC (i)
+ END ;
+ mid := dest[h] ;
+ mid := SHIFT (mid, bitshift) ; (* Shift left. *)
+ dest[h] := mid + bot
+ END
+END ShiftLeftByteBit ;
+
+
+(*
+ ShiftRight - performs the shift rightt for a multi word set.
+*)
+
+PROCEDURE ShiftRight (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL;
+ ShiftCount: CARDINAL) ;
+VAR
+ byteshift,
+ bitshift : CARDINAL ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("highbit = %d, ShiftCount = %d\n",
+ highbit, ShiftCount)
+ END ;
+ byteshift := ShiftCount DIV TBITSIZE (BYTESET) ;
+ bitshift := ShiftCount MOD TBITSIZE (BYTESET) ;
+ IF EnableDebugging
+ THEN
+ printf ("SIZE (byteset) = %d, TBITSIZE (byteset) = %d\n",
+ SIZE (BYTESET), TBITSIZE (BYTESET));
+ printf (" byteshift = %d, bitshift = %d\n",
+ byteshift, bitshift)
+ END ;
+ ShiftRightByteBit (dest, src, highbit, byteshift, bitshift)
+END ShiftRight ;
+
+
+(*
+ ShiftRightByteBit - shifts src left by byteshift and bitshift. It
+ moves the bottom bitshift bits from lo into the
+ first byte.
+*)
+
+PROCEDURE ShiftRightByteBit (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL;
+ byteshift, bitshift: CARDINAL) ;
+VAR
+ top, bot, mid : BYTESET ;
+ i, h, to, from: CARDINAL ;
+BEGIN
+ (* Copy the bytes. *)
+ to := 0 ;
+ from := byteshift ;
+ IF EnableDebugging
+ THEN
+ printf ("HIGH (dest) = %d\n", HIGH (dest))
+ END ;
+ IF byteshift <= HIGH (dest)
+ THEN
+ h := HIGH (dest) - byteshift ;
+ WHILE to <= h DO
+ dest[to] := src[from] ;
+ INC (to) ;
+ INC (from)
+ END
+ END ;
+ WHILE to <= HIGH (dest) DO
+ dest[to] := BYTE (0) ;
+ INC (to)
+ END ;
+ (* And bit shift the remainder. *)
+ IF EnableDebugging
+ THEN
+ printf ("bitshift = %d\n", bitshift)
+ END ;
+ IF bitshift > 0
+ THEN
+ top := BYTE (0) ;
+ i := HIGH (dest) ;
+ WHILE i > 0 DO
+ mid := dest[i] ;
+ bot := SHIFT (mid, TBITSIZE (BYTE) - bitshift) ; (* Shift left. *)
+ mid := SHIFT (mid, - INTEGER (bitshift)) ; (* Shift right by bitshift. *)
+ dest[i] := top + mid ;
+ top := bot ;
+ DEC (i)
+ END ;
+ mid := dest[0] ;
+ mid := SHIFT (mid, - INTEGER (bitshift)) ; (* Shift right by bitshift. *)
+ dest[0] := top + mid
+ END
+END ShiftRightByteBit ;
+
+
+(*
+ Shift - dest := SHIFT (src, ShiftCount).
+*)
+
+PROCEDURE Shift (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL; ShiftCount: INTEGER) ;
+BEGIN
+ IF ShiftCount > 0
+ THEN
+ IF EnableDebugging
+ THEN
+ printf ("Shift Left: ") ;
+ DumpSet (src, highbit)
+ END ;
+ ShiftCount := ShiftCount MOD VAL (INTEGER, (highbit + 1)) ;
+ ShiftLeft (dest, src, highbit, ShiftCount) ;
+ IF EnableDebugging
+ THEN
+ printf (" Result of shift Left: ") ;
+ DumpSet (dest, highbit)
+ END
+ ELSIF ShiftCount < 0
+ THEN
+ IF EnableDebugging
+ THEN
+ printf ("Shift Right: ") ;
+ DumpSet (src, highbit)
+ END ;
+ ShiftCount := (-ShiftCount) MOD VAL (INTEGER, (highbit + 1)) ;
+ ShiftRight (dest, src, highbit, ShiftCount) ;
+ IF EnableDebugging
+ THEN
+ printf (" Result of shift right: ") ;
+ DumpSet (dest, highbit)
+ END
+ ELSE
+ IF memcpy (ADR (dest), ADR (src), (HIGH (dest) + 1) * SIZE (BYTE)) = NIL
+ THEN
+ END
+ END
+END Shift ;
+
+
+(*
+ ArithShift - dest := ArithShift (dest, ShiftCount, carry). This is an
+ arithmetic shift all the new bit values will
+ be set to carry.
+*)
+
+PROCEDURE ArithShiftLeft (VAR dest: ARRAY OF BYTE;
+ highbit: CARDINAL; ShiftCount: CARDINAL;
+ carry: BOOLEAN) ;
+BEGIN
+ WHILE ShiftCount > 0 DO
+ ArithShiftLeftBit (dest, highbit, carry) ;
+ DEC (ShiftCount)
+ END
+END ArithShiftLeft ;
+
+
+(*
+ ArithShiftLeftBit - shift set left by one bit. Carry will appear at
+ bit position 0. Any unused bits on the high byte
+ are unaffected.
+*)
+
+PROCEDURE ArithShiftLeftBit (VAR dest: ARRAY OF BYTE; highbit: CARDINAL;
+ carry: BOOLEAN) ;
+CONST
+ MSB = TBITSIZE (BYTE) - 1 ;
+VAR
+ topbit,
+ i,
+ high : CARDINAL ;
+ next : BOOLEAN ;
+ mask,
+ unused,
+ set : BYTESET ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("ArithShiftLeft enter\n");
+ DumpSet (dest, highbit)
+ END ;
+
+ high := HIGH (dest) ;
+ (* We ripple through the bytes 0..high-1, propagating local carry between
+ bytes. *)
+ i := 0 ;
+ WHILE i < high DO
+ set := dest[i] ;
+ next := MSB IN set ;
+ set := SHIFT (set, 1) ; (* Shift left. *)
+ IF carry
+ THEN
+ INCL (set, 0) (* Set bit 0. *)
+ END ;
+ dest[i] := set ;
+ carry := next ;
+ IF EnableDebugging
+ THEN
+ printf ("ArithShiftLeft shifted byte dest[%d]\n", i);
+ DumpSet (dest, highbit)
+ END ;
+ INC (i)
+ END ;
+ (* Last byte special case as there may be some unused bits which must be
+ preserved. *)
+ set := dest[high] ;
+ unused := BYTESET {} ; (* Will contain all top unused bits of dest[high]. *)
+ mask := - BYTESET {} ;
+ topbit := (highbit+1) MOD TBITSIZE (BYTE) ;
+ WHILE topbit # 0 DO
+ EXCL (mask, topbit) ;
+ IF topbit IN set
+ THEN
+ EXCL (set, topbit) ;
+ INCL (unused, topbit)
+ END ;
+ topbit := (topbit+1) MOD TBITSIZE (BYTE)
+ END ;
+ set := SHIFT (set, 1) ; (* Left shift. *)
+ IF carry
+ THEN
+ INCL (set, 0) (* Set bit 0. *)
+ END ;
+ set := set * mask ; (* Remove all unused bits. *)
+ set := set + unused ; (* Restore original unused bits. *)
+ dest[high] := set ;
+ IF EnableDebugging
+ THEN
+ printf ("ArithShiftLeft shifted byte dest[%d]\n", high);
+ DumpSet (dest, highbit)
+ END
+END ArithShiftLeftBit ;
+
+
+(*
+ ArithShiftRight - dest := ArithShiftRight (dest, ShiftCount, carry).
+ This is an arithmetic shift all the new bit values
+ will be set to carry.
+*)
+
+PROCEDURE ArithShiftRight (VAR dest: ARRAY OF BYTE;
+ highbit: CARDINAL; ShiftCount: CARDINAL;
+ carry: BOOLEAN) ;
+BEGIN
+ WHILE ShiftCount > 0 DO
+ ArithShiftRightBit (dest, highbit, carry) ;
+ DEC (ShiftCount)
+ END
+END ArithShiftRight ;
+
+
+(*
+ ArithShiftRightBit - shift set right by one bit and place carry in the
+ top most bit.
+*)
+
+PROCEDURE ArithShiftRightBit (VAR dest: ARRAY OF BYTE; highbit: CARDINAL;
+ carry: BOOLEAN) ;
+CONST
+ MSB = TBITSIZE (BYTE) - 1 ;
+VAR
+ topbit,
+ i,
+ high : CARDINAL ;
+ prev,
+ next : BOOLEAN ;
+ mask,
+ unused,
+ set : BYTESET ;
+BEGIN
+ high := HIGH (dest) ;
+ (* Clear any unused bits in the highest byte, but save them into unused. *)
+ set := dest[high] ;
+ unused := BYTESET {} ;
+ topbit := (highbit+1) MOD TBITSIZE (BYTE) ;
+ mask := - BYTESET {} ;
+ WHILE topbit # 0 DO
+ EXCL (mask, topbit) ;
+ IF topbit IN set
+ THEN
+ EXCL (set, topbit) ;
+ INCL (unused, topbit)
+ END ;
+ topbit := (topbit+1) MOD TBITSIZE (BYTE)
+ END ;
+ (* Start at the top and work down to byte 0. *)
+ set := set * mask ; (* Ignore unused bits. *)
+ next := 0 IN set ; (* Next carry. *)
+ set := SHIFT (set, -1) ; (* Shift right by 1 bit. *)
+ IF carry
+ THEN
+ INCL (set, highbit MOD TBITSIZE (BYTE))
+ END ;
+ dest[high] := set + unused ; (* First byte is a special case as we
+ have to preserve the unused bits. *)
+ (* Now we ripple through the remaining bytes, propagating local
+ carry between bytes. *)
+ i := high ;
+ WHILE i > 0 DO
+ prev := next ;
+ DEC (i) ;
+ set := dest[i] ;
+ next := 0 IN set ;
+ set := SHIFT (set, -1) ;
+ IF prev
+ THEN
+ INCL (set, MSB)
+ END ;
+ dest[i] := set
+ END
+END ArithShiftRightBit ;
+
+
+(*
+ ArithShift - dest := ArithShift (dest, ShiftCount, carry). This is an
+ arithmetic shift all the new bit values will
+ be set to carry.
+*)
+
+PROCEDURE ArithShift (VAR dest: ARRAY OF BYTE;
+ highbit: CARDINAL; ShiftCount: INTEGER;
+ carry: BOOLEAN) ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("Arith enter\n");
+ DumpSet (dest, highbit)
+ END ;
+ IF ShiftCount > 0
+ THEN
+ ShiftCount := ShiftCount MOD VAL (INTEGER, (highbit + 1)) ;
+ ArithShiftLeft (dest, highbit, ShiftCount, carry)
+ ELSIF ShiftCount < 0
+ THEN
+ ShiftCount := (-ShiftCount) MOD VAL (INTEGER, (highbit + 1)) ;
+ ArithShiftRight (dest, highbit, ShiftCount, carry)
+ END ;
+ IF EnableDebugging
+ THEN
+ printf ("Arith exit\n");
+ DumpSet (dest, highbit)
+ END
+END ArithShift ;
+
+
+(*
+ Rotate - is a runtime procedure whose job is to implement
+ the ROTATE procedure of ISO SYSTEM.
+*)
+
+PROCEDURE Rotate (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL; RotateCount: INTEGER) ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("Rotate enter\n");
+ DumpSet (src, highbit)
+ END ;
+ IF RotateCount > 0
+ THEN
+ RotateCount := RotateCount MOD VAL (INTEGER, highbit + 1)
+ ELSIF RotateCount < 0
+ THEN
+ RotateCount := -VAL (INTEGER, VAL (CARDINAL, -RotateCount) MOD (highbit + 1))
+ END ;
+ IF RotateCount > 0
+ THEN
+ RotateLeft (dest, src, highbit, RotateCount)
+ ELSIF RotateCount < 0
+ THEN
+ RotateRight (dest, src, highbit, -RotateCount)
+ ELSE
+ (* No rotate required, but we must copy source to dest. *)
+ IF memcpy (ADR (dest), ADR (src), (HIGH (dest) + 1) * SIZE (BYTE)) = NIL
+ THEN
+ END
+ END ;
+ IF EnableDebugging
+ THEN
+ printf ("Rotate exit\n");
+ DumpSet (dest, highbit)
+ END
+END Rotate ;
+
+
+(*
+ RotateLeft - performs the rotate left for a multi word set.
+*)
+
+PROCEDURE RotateLeft (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL; RotateCount: CARDINAL) ;
+VAR
+ bit, carry : BOOLEAN ;
+ count,
+ high,
+ highplus1,
+ highbitplus1,
+ from, to : CARDINAL ;
+BEGIN
+ IF EnableDebugging
+ THEN
+ printf ("RotateLeft enter\n");
+ DumpSet (src, highbit)
+ END ;
+
+ (* Copy the contents rotating on byte granularity, then
+ arithmetically shift the remaining number of bits. *)
+ high := HIGH (dest) ;
+ from := 0 ;
+ highplus1 := high + 1 ;
+ highbitplus1 := highbit + 1 ;
+ to := RotateCount DIV TBITSIZE (BYTE) ; (* Byte level granularity. *)
+ REPEAT
+ dest[to] := src[from] ;
+ IF EnableDebugging
+ THEN
+ printf ("RotateLeft after partial byte movement: dest[%d] := src[%d]\n",
+ to, from);
+ DumpSet (dest, highbit)
+ END ;
+ from := (from + 1) MOD highplus1 ;
+ to := (to + 1) MOD highplus1 ;
+ UNTIL from = 0 ;
+
+ IF EnableDebugging
+ THEN
+ printf ("RotateLeft after byte placement\n");
+ DumpSet (dest, highbit)
+ END ;
+
+ (* Now ArithShiftLeft the remainder number of bits. *)
+ count := RotateCount MOD (TBITSIZE (BYTE)) ;
+ WHILE count > 0 DO
+ (* Get last bit. *)
+ bit := (highbit MOD TBITSIZE (BYTE)) IN BYTESET (dest[high]) ;
+ (* Shift everything left wards and the last bit goes to bit
+ position 0. *)
+ ArithShiftLeft (dest, highbit, 1, bit) ;
+ DEC (count)
+ END ;
+ IF EnableDebugging
+ THEN
+ printf ("RotateLeft after bit shifting final placement\n");
+ DumpSet (dest, highbit)
+ END
+END RotateLeft ;
+
+
+(*
+ RotateRight - performs the rotate right for a multi word set.
+*)
+
+PROCEDURE RotateRight (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE;
+ highbit: CARDINAL; RotateCount: CARDINAL) ;
+BEGIN
+ RotateLeft (dest, src, highbit, (highbit + 1) - RotateCount)
+END RotateRight ;
+
+
+(*
+ Less - performs the set comparison for a wide set.
+ Less returns ProperSubset (left, right, highbit).
+*)
+
+PROCEDURE Less (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+
+BEGIN
+ RETURN ProperSubset (left, right, highbit)
+END Less ;
+
+
+(*
+ LessEqu - performs the set comparison for a wide set.
+ LessEqu returns Equal (left, right, highbit) OR
+ ProperSubset (left, right, highbit).
+*)
+
+PROCEDURE LessEqu (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN Equal (left, right, highbit) OR
+ ProperSubset (left, right, highbit)
+END LessEqu ;
+
+
+(*
+ Gre - performs the set comparison for a wide set.
+ Gre returns the result of
+ ProperSuperet (left, right, highbit).
+*)
+
+PROCEDURE Gre (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN ProperSuperset (left, right, highbit)
+END Gre ;
+
+
+(*
+ GreEqu - performs the set comparison for a wide set.
+ GreEqu returns Equal (left, right, highbit) OR
+ ProperSuperet (left, right, highbit).
+*)
+
+PROCEDURE GreEqu (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN Equal (left, right, highbit) OR
+ ProperSuperset (left, right, highbit)
+END GreEqu ;
+
+
+(*
+ ProperSubset - return TRUE if left is a proper subset of right.
+ If true the left set will have at least one element
+ less than set right.
+*)
+
+PROCEDURE ProperSubset (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+VAR
+ diffbits,
+ diffright,
+ diffleft : BYTESET ;
+ rightmore: BOOLEAN ;
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+ lptr,
+ rptr : PtrToByteset ;
+BEGIN
+ high := HIGH (left) ;
+ lptr := ADR (left) ;
+ rptr := ADR (right) ;
+ i := 0 ;
+ rightmore := FALSE ;
+ WHILE i < high DO
+ diffbits := lptr^ / rptr^ ; (* / in M2 is xor. *)
+ diffright := diffbits * rptr^ ; (* * in M2 is and. *)
+ IF diffright # BYTESET {}
+ THEN
+ rightmore := TRUE
+ END ;
+ diffleft := diffbits * lptr^ ;
+ IF diffleft # BYTESET {}
+ THEN
+ (* Not a subset, so we early return. *)
+ RETURN FALSE
+ END ;
+ INC (rptr) ;
+ INC (lptr) ;
+ INC (i)
+ END ;
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit > 0
+ THEN
+ FOR bit := 0 TO lastbit DO
+ IF (NOT (bit IN lptr^)) AND (bit IN rptr^)
+ THEN
+ rightmore := TRUE
+ ELSIF (bit IN lptr^) AND (NOT (bit IN rptr^))
+ THEN
+ (* Not a subset, so we early return. *)
+ RETURN FALSE
+ END
+ END
+ END ;
+ RETURN rightmore
+END ProperSubset ;
+
+
+(*
+ ProperSuperset - return TRUE if left is a proper superset of right.
+ If true the left set will have at least one element
+ more than set right.
+*)
+
+PROCEDURE ProperSuperset (VAR left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) : BOOLEAN ;
+VAR
+ diffbits,
+ diffleft,
+ diffright: BYTESET ;
+ leftmore : BOOLEAN ;
+ i,
+ bit,
+ high,
+ lastbit : CARDINAL ;
+ lptr,
+ rptr : PtrToByteset ;
+BEGIN
+ high := HIGH (left) ;
+ lptr := ADR (left) ;
+ rptr := ADR (right) ;
+ i := 0 ;
+ leftmore := FALSE ;
+ WHILE i < high DO
+ diffbits := lptr^ / rptr^ ; (* / in M2 is xor. *)
+ diffleft := diffbits * lptr^ ; (* * in M2 is and. *)
+ IF diffleft # BYTESET {}
+ THEN
+ leftmore := TRUE
+ END ;
+ diffright := diffbits * rptr^ ;
+ IF diffright # BYTESET {}
+ THEN
+ (* Not a superset, so we early return. *)
+ RETURN FALSE
+ END ;
+ INC (rptr) ;
+ INC (lptr) ;
+ INC (i)
+ END ;
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit > 0
+ THEN
+ FOR bit := 0 TO lastbit DO
+ IF (bit IN lptr^) AND (NOT (bit IN rptr^))
+ THEN
+ leftmore := TRUE
+ ELSIF (NOT (bit IN lptr^)) AND (bit IN rptr^)
+ THEN
+ (* Not a superset, so we early return. *)
+ RETURN FALSE
+ END
+ END
+ END ;
+ RETURN leftmore
+END ProperSuperset ;
+
+
+(*
+ LogicalDifference - build a logical difference expression tree.
+ dest := left and (not right).
+*)
+
+PROCEDURE LogicalDifference (VAR dest: ARRAY OF BYTE;
+ left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+BEGIN
+ Not (right, right, highbit) ;
+ And (dest, left, right, highbit)
+END LogicalDifference ;
+
+
+(*
+ SymmetricDifference - build a logical difference expression tree.
+ dest := left xor right.
+*)
+
+PROCEDURE SymmetricDifference (VAR dest: ARRAY OF BYTE;
+ left, right: ARRAY OF BYTE;
+ highbit: CARDINAL) ;
+VAR
+ i,
+ bit,
+ high,
+ lastbit: CARDINAL ;
+ byteset: BYTESET ;
+BEGIN
+ high := HIGH (dest) ;
+ i := 0 ;
+ WHILE i < high DO
+ dest[i] := BYTESET (left[i]) / BYTESET (right[i]) ;
+ INC (i)
+ END ;
+ IF i = high
+ THEN
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ dest[i] := BYTESET (left[i]) / BYTESET (right[i])
+ ELSE
+ byteset := dest[i] ;
+ FOR bit := 0 TO lastbit DO
+ IF (bit IN BYTESET (left[i])) = (bit IN BYTESET (right[i]))
+ THEN
+ EXCL (byteset, bit)
+ ELSE
+ INCL (byteset, bit)
+ END
+ END ;
+ dest[i] := byteset
+ END
+ ELSE
+ HALT
+ END
+END SymmetricDifference ;
+
+
+(*
+ AssignBits - copy bits [0..highbit] from src to dest.
+*)
+
+PROCEDURE AssignBits (VAR dest: BYTESET; src: BYTESET; highbit: CARDINAL) ;
+VAR
+ bit,
+ lastbit: CARDINAL ;
+BEGIN
+ (* Last byte. *)
+ lastbit := highbit MOD TBITSIZE (BYTE) ;
+ IF lastbit = 0
+ THEN
+ (* Copy all bits. *)
+ dest := src
+ ELSE
+ (* Copy only required bits. *)
+ FOR bit := 0 TO lastbit DO
+ IF bit IN src
+ THEN
+ INCL (dest, bit)
+ ELSE
+ EXCL (dest, bit)
+ END
+ END
+ END
+END AssignBits ;
+
+
+(*
+ Assign -
+*)
+
+PROCEDURE Assign (VAR dest: ARRAY OF BYTE; src: ARRAY OF BYTE; highbit: CARDINAL) ;
+VAR
+ i, high: CARDINAL ;
+BEGIN
+ high := HIGH (dest) ;
+ i := 0 ;
+ WHILE i < high DO
+ dest[i] := src[i] ;
+ INC (i)
+ END ;
+ AssignBits (dest[i], src[i], highbit)
+END Assign ;
+
+
+END M2WIDESET.
diff --git a/gcc/m2/gm2-libs/SYSTEM.def b/gcc/m2/gm2-libs/SYSTEM.def
index 1b2949eebb0b..9d043999cfe4 100644
--- a/gcc/m2/gm2-libs/SYSTEM.def
+++ b/gcc/m2/gm2-libs/SYSTEM.def
@@ -111,87 +111,4 @@ PROCEDURE TBITSIZE (<type>) : CARDINAL ;
*)
*)
-(* The following procedures are invoked by GNU Modula-2 to
- shift non word sized set types. They are not strictly part
- of the core PIM Modula-2, however they are used
- to implement the SHIFT procedure defined above,
- which are in turn used by the Logitech compatible libraries.
-
- Users will access these procedures by using the procedure
- SHIFT above and GNU Modula-2 will map SHIFT onto one of
- the following procedures.
-*)
-
-(*
- ShiftVal - is a runtime procedure whose job is to implement
- the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
- inline a SHIFT of a single WORD sized set and will only
- call this routine for larger sets.
-*)
-
-PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: INTEGER) ;
-
-
-(*
- ShiftLeft - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-
-(*
- ShiftRight - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-
-
-(*
- RotateVal - is a runtime procedure whose job is to implement
- the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
- inline a ROTATE of a single WORD (or less)
- sized set and will only call this routine for larger
- sets.
-*)
-
-PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: INTEGER) ;
-
-
-(*
- RotateLeft - performs the rotate left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-
-
-(*
- RotateRight - performs the rotate right for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at
- compile time.
-*)
-
-PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-
-
END SYSTEM.
diff --git a/gcc/m2/gm2-libs/SYSTEM.mod b/gcc/m2/gm2-libs/SYSTEM.mod
index 72b22cdf06db..7ee5a043dc2d 100644
--- a/gcc/m2/gm2-libs/SYSTEM.mod
+++ b/gcc/m2/gm2-libs/SYSTEM.mod
@@ -26,248 +26,4 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
IMPLEMENTATION MODULE SYSTEM ;
-FROM libc IMPORT memcpy, memset ;
-
-CONST
- BitsPerBitset = MAX(BITSET)+1 ;
-
-
-(*
- Max - returns the maximum of a and b.
-*)
-
-PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
-BEGIN
- IF a>b
- THEN
- RETURN( a )
- ELSE
- RETURN( b )
- END
-END Max ;
-
-
-(*
- Min - returns the minimum of a and b.
-*)
-
-PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
-BEGIN
- IF a<b
- THEN
- RETURN( a )
- ELSE
- RETURN( b )
- END
-END Min ;
-
-
-(*
- ShiftVal - is a runtime procedure whose job is to implement
- the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
- inline a SHIFT of a single WORD sized set and will only
- call this routine for larger sets.
-*)
-
-PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: INTEGER) ;
-VAR
- a: ADDRESS ;
-BEGIN
- IF ShiftCount>0
- THEN
- ShiftCount := ShiftCount MOD VAL(INTEGER, SetSizeInBits) ;
- ShiftLeft(s, d, SetSizeInBits, ShiftCount)
- ELSIF ShiftCount<0
- THEN
- ShiftCount := (-ShiftCount) MOD VAL(INTEGER, SetSizeInBits) ;
- ShiftRight(s, d, SetSizeInBits, ShiftCount)
- ELSE
- a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
- END
-END ShiftVal ;
-
-
-(*
- ShiftLeft - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- i, j, h: CARDINAL ;
- a : ADDRESS ;
-BEGIN
- h := HIGH(s)+1 ;
- IF ShiftCount MOD BitsPerBitset=0
- THEN
- i := ShiftCount DIV BitsPerBitset ;
- a := ADR(d[i]) ;
- a := memcpy(a, ADR(s), (h-i)*SIZE(BITSET)) ;
- a := memset(ADR(d), 0, i*SIZE(BITSET))
- ELSE
- i := h ;
- WHILE i>0 DO
- DEC(i) ;
- lo := SHIFT(s[i], ShiftCount MOD BitsPerBitset) ;
- hi := SHIFT(s[i], -(BitsPerBitset - (ShiftCount MOD BitsPerBitset))) ;
- d[i] := BITSET{} ;
- j := i + ShiftCount DIV BitsPerBitset ;
- IF j<h
- THEN
- d[j] := d[j] + lo ;
- INC(j) ;
- IF j<h
- THEN
- d[j] := d[j] + hi
- END
- END
- END
- END
-END ShiftLeft ;
-
-
-(*
- ShiftRight - performs the shift left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- ShiftCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- j, i, h: INTEGER ;
- a : ADDRESS ;
-BEGIN
- h := HIGH (s) + 1 ;
- IF ShiftCount MOD BitsPerBitset = 0
- THEN
- i := ShiftCount DIV BitsPerBitset ;
- a := ADR (s[i]) ;
- j := h-i ;
- a := memcpy (ADR (d), a, j * VAL (INTEGER, SIZE (BITSET))) ;
- a := ADR (d[j]) ;
- a := memset (a, 0, i * VAL (INTEGER, SIZE (BITSET)))
- ELSE
- i := 0 ;
- WHILE i<h DO
- lo := SHIFT(s[i], BitsPerBitset - (ShiftCount MOD BitsPerBitset)) ;
- hi := SHIFT(s[i], -(ShiftCount MOD BitsPerBitset)) ;
- d[i] := BITSET{} ;
- j := i - VAL (INTEGER, ShiftCount DIV BitsPerBitset) ;
- IF j>=0
- THEN
- d[j] := d[j] + hi ;
- DEC(j) ;
- IF j>=0
- THEN
- d[j] := d[j] + lo
- END
- END ;
- INC(i)
- END
- END
-END ShiftRight ;
-
-
-(*
- RotateVal - is a runtime procedure whose job is to implement
- the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
- inline a ROTATE of a single WORD (or less)
- sized set and will only call this routine for larger sets.
-*)
-
-PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: INTEGER) ;
-VAR
- a: ADDRESS ;
-BEGIN
- IF RotateCount>0
- THEN
- RotateCount := RotateCount MOD VAL(INTEGER, SetSizeInBits)
- ELSIF RotateCount<0
- THEN
- RotateCount := -VAL(INTEGER, VAL(CARDINAL, -RotateCount) MOD SetSizeInBits)
- END ;
- IF RotateCount>0
- THEN
- RotateLeft(s, d, SetSizeInBits, RotateCount)
- ELSIF RotateCount<0
- THEN
- RotateRight(s, d, SetSizeInBits, -RotateCount)
- ELSE
- (* no rotate required, but we must copy source to dest. *)
- a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
- END
-END RotateVal ;
-
-
-(*
- RotateLeft - performs the rotate left for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-VAR
- lo, hi : BITSET ;
- b, i, j, h: CARDINAL ;
-BEGIN
- h := HIGH(s) ;
- (* firstly we set d := {} *)
- i := 0 ;
- WHILE i<=h DO
- d[i] := BITSET{} ;
- INC(i)
- END ;
- i := h+1 ;
- RotateCount := RotateCount MOD SetSizeInBits ;
- b := SetSizeInBits MOD BitsPerBitset ;
- IF b=0
- THEN
- b := BitsPerBitset
- END ;
- WHILE i>0 DO
- DEC(i) ;
- lo := SHIFT(s[i], RotateCount MOD BitsPerBitset) ;
- hi := SHIFT(s[i], -(b - (RotateCount MOD BitsPerBitset))) ;
- j := ((i*BitsPerBitset + RotateCount) MOD
- SetSizeInBits) DIV BitsPerBitset ;
- d[j] := d[j] + lo ;
- j := (((i+1)*BitsPerBitset + RotateCount) MOD
- SetSizeInBits) DIV BitsPerBitset ;
- d[j] := d[j] + hi ;
- b := BitsPerBitset
- END
-END RotateLeft ;
-
-
-(*
- RotateRight - performs the rotate right for a multi word set.
- This procedure might be called by the back end of
- GNU Modula-2 depending whether amount is known at compile
- time.
-*)
-
-PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
- SetSizeInBits: CARDINAL;
- RotateCount: CARDINAL) ;
-BEGIN
- RotateLeft(s, d, SetSizeInBits, SetSizeInBits-RotateCount)
-END RotateRight ;
-
-
END SYSTEM.
diff --git a/gcc/m2/gm2-libs/SysStorage.def b/gcc/m2/gm2-libs/SysStorage.def
index 1d2baacec965..4a27495c6c0b 100644
--- a/gcc/m2/gm2-libs/SysStorage.def
+++ b/gcc/m2/gm2-libs/SysStorage.def
@@ -28,7 +28,9 @@ DEFINITION MODULE SysStorage ;
(* Provides dynamic allocation for the system components.
This allows the application to use the traditional Storage module
- which can be handled differently. *)
+ which can be handled differently.
+ ALLOCATE and DEALLOCATE will call M2Diagnostic to adjust the
+ global tracking of the application heap. *)
FROM SYSTEM IMPORT ADDRESS ;
EXPORT QUALIFIED ALLOCATE, DEALLOCATE, REALLOCATE, Available, Init ;
@@ -56,6 +58,11 @@ PROCEDURE DEALLOCATE (VAR a: ADDRESS ; size: CARDINAL) ;
is called, or alternatively it should have already
been initialized by ALLOCATE. The allocated storage
is resized accordingly.
+ Note that this procedure does not adjust the
+ M2Diagnostic.TotalHeap it is expected that the caller
+ must track the reallocation differences and call
+ M2Diagnostic.TotalHeapIncr or M2Diagnostic.TotalHeapDecr
+ as appropriate.
*)
PROCEDURE REALLOCATE (VAR a: ADDRESS; size: CARDINAL) ;
diff --git a/gcc/m2/gm2-libs/SysStorage.mod b/gcc/m2/gm2-libs/SysStorage.mod
index 4558b579fabc..3f9fab6d6978 100644
--- a/gcc/m2/gm2-libs/SysStorage.mod
+++ b/gcc/m2/gm2-libs/SysStorage.mod
@@ -30,6 +30,8 @@ FROM libc IMPORT malloc, free, realloc, memset, getenv, printf ;
FROM Debug IMPORT Halt ;
FROM SYSTEM IMPORT ADR ;
+IMPORT M2Diagnostic ;
+
CONST
enableDeallocation = TRUE ;
@@ -55,7 +57,8 @@ BEGIN
printf ("<DEBUG-CALL> %d SysStorage.ALLOCATE (0x%x, %d bytes)\n", callno, a, size) ;
printf ("<MEM-ALLOC> %ld %d\n", a, size);
INC (callno)
- END
+ END ;
+ M2Diagnostic.TotalHeapIncr (size)
END ALLOCATE ;
@@ -87,6 +90,7 @@ BEGIN
END ;
free (a)
END ;
+ M2Diagnostic.TotalHeapDecr (size) ;
a := NIL
END DEALLOCATE ;
@@ -97,6 +101,11 @@ END DEALLOCATE ;
is called, or alternatively it should have already
been initialized by ALLOCATE. The allocated storage
is resized accordingly.
+ Note that this procedure does not adjust the
+ M2Diagnostic.TotalHeap it is expected that the caller
+ must track the reallocation differences and call
+ M2Diagnostic.TotalHeapIncr or M2Diagnostic.TotalHeapDecr
+ as appropriate.
*)
PROCEDURE REALLOCATE (VAR a: ADDRESS; size: CARDINAL) ;
diff --git a/gcc/m2/init/ppginit b/gcc/m2/init/ppginit
index 5094c4e2364b..33014b33018c 100644
--- a/gcc/m2/init/ppginit
+++ b/gcc/m2/init/ppginit
@@ -25,6 +25,7 @@ RTExceptions
M2EXCEPTION
M2RTS
SysExceptions
+M2Diagnostic
StrLib
errno
termios
@@ -45,6 +46,7 @@ UnixArgs
FIO
SFIO
StrCase
+StringConvert
bnflex
Lists
Args
diff --git a/gcc/m2/lang.opt b/gcc/m2/lang.opt
index 2aea4ccb77eb..dc6abb1b6778 100644
--- a/gcc/m2/lang.opt
+++ b/gcc/m2/lang.opt
@@ -206,6 +206,10 @@ fm2-whole-program
Modula-2
compile all implementation modules and program module at once
+fmem-report
+Modula-2
+; Documented in c.opt
+
fmod=
Modula-2 Joined
recognize the specified suffix as implementation and module filenames
@@ -290,6 +294,10 @@ fswig
Modula-2
create a swig interface file for the module
+ftime-report
+Modula-2
+; Documented in c.opt
+
funbounded-by-reference
Modula-2
optimize non var unbounded parameters by passing it by reference, providing it is not written to within the callee procedure.
@@ -302,6 +310,10 @@ fversion
Modula-2
; Documented in common.opt
+fwideset
+Modula-2
+link against the module M2WIDESET to perform the wideset operator, the negative version of this option will generate a warning if this module is required
+
fwholediv
Modula-2
turns on all division and modulus by zero checking for ordinal values
diff --git a/gcc/m2/mc-boot/GM2Diagnostic.cc b/gcc/m2/mc-boot/GM2Diagnostic.cc
new file mode 100644
index 000000000000..ee26359eee79
--- /dev/null
+++ b/gcc/m2/mc-boot/GM2Diagnostic.cc
@@ -0,0 +1,1484 @@
+/* do not edit automatically generated by mc from M2Diagnostic. */
+/* M2Diagnotic provides memory and time diagnosics to the user.
+
+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/>. */
+
+#include "config.h"
+#include "system.h"
+#include <stdbool.h>
+# if !defined (PROC_D)
+# define PROC_D
+ typedef void (*PROC_t) (void);
+ typedef struct { PROC_t proc; } PROC;
+# endif
+
+# if !defined (TRUE)
+# define TRUE (1==1)
+# endif
+
+# if !defined (FALSE)
+# define FALSE (1==0)
+# endif
+
+# include "GStorage.h"
+# include "Gmcrts.h"
+#if defined(__cplusplus)
+# undef NULL
+# define NULL 0
+#endif
+#define _M2Diagnostic_H
+#define _M2Diagnostic_C
+
+# include "GASCII.h"
+# include "GSelective.h"
+# include "GStringConvert.h"
+# include "GStorage.h"
+# include "GDynamicStrings.h"
+# include "GM2RTS.h"
+
+typedef struct M2Diagnostic_DiagProc_p M2Diagnostic_DiagProc;
+
+# define EnableDiagnostics true
+# define DefaultTimeEnableValue false
+# define DefaultMemEnableValue false
+# define MaxParam 4
+# define MICROSEC 100000
+typedef struct M2Diagnostic_timeDiag_r M2Diagnostic_timeDiag;
+
+typedef struct M2Diagnostic_memDiag_r M2Diagnostic_memDiag;
+
+typedef struct M2Diagnostic__T1_r M2Diagnostic__T1;
+
+typedef struct M2Diagnostic__T2_a M2Diagnostic__T2;
+
+typedef enum {M2Diagnostic_timediag, M2Diagnostic_memdiag} M2Diagnostic_DiagType;
+
+# define kilo 1024
+# define mega (kilo*kilo)
+# define giga (mega*kilo)
+typedef M2Diagnostic__T1 *M2Diagnostic_Diagnostic;
+
+typedef void (*M2Diagnostic_DiagProc_t) (M2Diagnostic_Diagnostic);
+struct M2Diagnostic_DiagProc_p { M2Diagnostic_DiagProc_t proc; };
+
+struct M2Diagnostic_timeDiag_r {
+ unsigned int count;
+ Selective_Timeval total;
+ Selective_Timeval enter;
+ Selective_Timeval exit_;
+ };
+
+struct M2Diagnostic__T2_a { long unsigned int array[MaxParam-1+1]; };
+struct M2Diagnostic_memDiag_r {
+ M2Diagnostic__T2 param;
+ };
+
+struct M2Diagnostic__T1_r {
+ DynamicStrings_String name;
+ DynamicStrings_String format;
+ bool enable;
+ M2Diagnostic_Diagnostic next;
+ M2Diagnostic_DiagType type; /* case tag */
+ union {
+ M2Diagnostic_timeDiag tdiag;
+ M2Diagnostic_memDiag mdiag;
+ };
+ };
+
+static DynamicStrings_String Output;
+static long unsigned int TotalHeap;
+static M2Diagnostic_Diagnostic Head;
+static bool DefaultTimeEnable;
+static bool DefaultMemEnable;
+static Selective_Timeval StartTime;
+static Selective_Timeval TotalTime;
+
+/*
+ InitTimeDiagnostic - create and return a time diagnostic.
+ The format string can be free form and may
+ contain {1T}, {1C} or {1P}.
+ {1T} will contain the time and
+ {1C} the count of the number of times the
+ code enters the time diagnostic code region.
+ {1P} generates the time as a percentage.
+ {0T} is the total time for the application.
+ {{ is rendered as a single {.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_InitTimeDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high);
+
+/*
+ EnterDiagnostic - attribute all execution time from now to TimeDiag.
+*/
+
+extern "C" void M2Diagnostic_EnterDiagnostic (M2Diagnostic_Diagnostic TimeDiag);
+
+/*
+ ExitDiagnostic - stop attributing execution time to TimeDiag.
+*/
+
+extern "C" void M2Diagnostic_ExitDiagnostic (M2Diagnostic_Diagnostic TimeDiag);
+
+/*
+ InitMemDiagnostic - create and return a memory diagnostic.
+ The format string can be free form and may
+ contain {1M} {1d} {1x} {1P}.
+ {1M} is replaced by the value of the first parameter
+ with memory size units.
+ {1d} unsigned decimal. {1x} unsigned hexadecimal.
+ {0M} is the global allocation (Storage.mod:ALLOCATE).
+ {1P} is the percentage of param 1 relative
+ to global memory.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_InitMemDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high);
+
+/*
+ MemIncr - allow the appropriate parameter to be incremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*/
+
+extern "C" void M2Diagnostic_MemIncr (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int incr);
+
+/*
+ MemDecr - allow the appropriate parameter to be decremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*/
+
+extern "C" void M2Diagnostic_MemDecr (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int decr);
+
+/*
+ MemSet - allow the appropriate parameter to be set to value.
+ All parameters are initially set to zero.
+*/
+
+extern "C" void M2Diagnostic_MemSet (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int value);
+
+/*
+ TotalHeapIncr - increments the total heap used.
+*/
+
+extern "C" void M2Diagnostic_TotalHeapIncr (unsigned int incr);
+
+/*
+ TotalHeapDecr - decrements the total heap used.
+*/
+
+extern "C" void M2Diagnostic_TotalHeapDecr (unsigned int incr);
+
+/*
+ SetEnable - set the enable flag in Diag to value.
+*/
+
+extern "C" void M2Diagnostic_SetEnable (M2Diagnostic_Diagnostic Diag, bool value);
+
+/*
+ Lookup - returns the Diagnostic containing name or NIL
+ if it does not exist.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_Lookup (const char *name_, unsigned int _name_high);
+
+/*
+ GetName - returns the name of Diag.
+*/
+
+extern "C" DynamicStrings_String M2Diagnostic_GetName (M2Diagnostic_Diagnostic Diag);
+
+/*
+ ForeachDiagDo - for diag in global diag list do
+ dp (diag);
+ end
+*/
+
+extern "C" void M2Diagnostic_ForeachDiagDo (M2Diagnostic_DiagProc dp);
+
+/*
+ SetDefaultConfig - force the Diag enable flag to the
+ time or mem global default.
+*/
+
+extern "C" void M2Diagnostic_SetDefaultConfig (M2Diagnostic_Diagnostic Diag);
+
+/*
+ Configure - will turn on or off all the memory or time
+ instrumentation diagnostics and set the defaults
+ time and mem values.
+*/
+
+extern "C" void M2Diagnostic_Configure (bool time_, bool mem);
+
+/*
+ Generate - return a string containing the output from
+ all the diagnostics enabled.
+*/
+
+extern "C" DynamicStrings_String M2Diagnostic_Generate (void);
+
+/*
+ Assert - halt if b is false.
+*/
+
+static void Assert (bool b);
+
+/*
+ Error - generate a error simple message with indicating the
+ format specifier ch is incorrect.
+*/
+
+static void Error (const char *msg_, unsigned int _msg_high, char ch);
+
+/*
+ Accumulate - total := total + exit - enter
+*/
+
+static void Accumulate (Selective_Timeval total, Selective_Timeval enter, Selective_Timeval exit_);
+
+/*
+ IncTime - left := left + right.
+*/
+
+static void IncTime (Selective_Timeval left, Selective_Timeval right);
+
+/*
+ DecTime - left := left - right.
+*/
+
+static void DecTime (Selective_Timeval left, Selective_Timeval right);
+
+/*
+ CheckParam -
+*/
+
+static void CheckParam (unsigned int paramno);
+
+/*
+ CreateStartTime -
+*/
+
+static void CreateStartTime (void);
+
+/*
+ UpdateTotalTime -
+*/
+
+static void UpdateTotalTime (void);
+
+/*
+ GetTimeParam - a paramno of 0 will return the total time so far
+ whereas a paramno > 0 will return the time associated
+ with Diag.
+*/
+
+static Selective_Timeval GetTimeParam (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ GetMemParam - return the mem paramno from within Diag. A paramno of 0
+ will return the total heap.
+*/
+
+static long unsigned int GetMemParam (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ CreateDecimalMem - converts c to a decimal string.
+*/
+
+static DynamicStrings_String CreateDecimalMem (long unsigned int c);
+
+/*
+ CreateHexadecimalMem - converts c to a hexadecimal string.
+*/
+
+static DynamicStrings_String CreateHexadecimalMem (long unsigned int c);
+
+/*
+ CreateDecimalTime - return timeval as a decimal seconds.usecs string.
+*/
+
+static DynamicStrings_String CreateDecimalTime (Selective_Timeval timeval);
+
+/*
+ CreateHexadecimalTime - return timeval as a hexadecimal seconds.usecs string.
+*/
+
+static DynamicStrings_String CreateHexadecimalTime (Selective_Timeval timeval);
+
+/*
+ Decimal - convert paramno in Diag to a string.
+*/
+
+static DynamicStrings_String Decimal (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ Hexadecimal - convert paramno in Diag to a hex string.
+*/
+
+static DynamicStrings_String Hexadecimal (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ Count - return the count field for a time diag or return the decimal
+ value for a paramno in a mem diag.
+*/
+
+static DynamicStrings_String Count (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ Microsec - convert timeval into microseconds and return the value as
+ a longcard.
+*/
+
+static long unsigned int Microsec (Selective_Timeval timeval);
+
+/*
+ CreateTimePercent - return timeval as a percentage of the TotalTime.
+*/
+
+static DynamicStrings_String CreateTimePercent (Selective_Timeval timeval);
+
+/*
+ CreateMemPercent - return memval as a percentage of TotalHeap.
+*/
+
+static DynamicStrings_String CreateMemPercent (long unsigned int memval);
+
+/*
+ DescribePercent - call the appropriate mem or time percentage procedure.
+*/
+
+static DynamicStrings_String DescribePercent (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ DescribeMemory - return the memory diagnostic
+*/
+
+static DynamicStrings_String DescribeMemory (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ DescribeTime - returns the time diagnostic in seconds.
+*/
+
+static DynamicStrings_String DescribeTime (M2Diagnostic_Diagnostic Diag, unsigned int paramno);
+
+/*
+ ParamSpec - ebnf:
+
+ ( '{' | '0' | '1' | '2' | '3' | '4' )
+ ( 'd' | 'x' | 'C' | 'T' | 'M' | 'N' | 'P' )
+ '}'
+*/
+
+static unsigned int ParamSpec (M2Diagnostic_Diagnostic Diag, unsigned int i);
+
+/*
+ FormatDiag - ebnf:
+
+ { ( '{' ParamSpec ) | any }
+*/
+
+static void FormatDiag (M2Diagnostic_Diagnostic Diag);
+
+
+/*
+ Assert - halt if b is false.
+*/
+
+static void Assert (bool b)
+{
+ if (! b)
+ {
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ }
+}
+
+
+/*
+ Error - generate a error simple message with indicating the
+ format specifier ch is incorrect.
+*/
+
+static void Error (const char *msg_, unsigned int _msg_high, char ch)
+{
+ char msg[_msg_high+1];
+
+ /* make a local copy of each unbounded array. */
+ memcpy (msg, msg_, _msg_high+1);
+
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+}
+
+
+/*
+ Accumulate - total := total + exit - enter
+*/
+
+static void Accumulate (Selective_Timeval total, Selective_Timeval enter, Selective_Timeval exit_)
+{
+ IncTime (total, exit_);
+ DecTime (total, enter);
+}
+
+
+/*
+ IncTime - left := left + right.
+*/
+
+static void IncTime (Selective_Timeval left, Selective_Timeval right)
+{
+ unsigned int lsec;
+ unsigned int lusec;
+ unsigned int rsec;
+ unsigned int rusec;
+
+ Selective_GetTime (left, &lsec, &lusec);
+ Selective_GetTime (right, &rsec, &rusec);
+ if ((lusec+rusec) < MICROSEC)
+ {
+ /* No carry */
+ lusec += rusec;
+ lsec += rsec;
+ }
+ else
+ {
+ lusec += rusec;
+ lusec -= MICROSEC;
+ lsec += rsec+1;
+ }
+ Selective_SetTime (left, lsec, lusec);
+}
+
+
+/*
+ DecTime - left := left - right.
+*/
+
+static void DecTime (Selective_Timeval left, Selective_Timeval right)
+{
+ unsigned int lsec;
+ unsigned int lusec;
+ unsigned int rsec;
+ unsigned int rusec;
+
+ Selective_GetTime (left, &lsec, &lusec);
+ Selective_GetTime (right, &rsec, &rusec);
+ if (lusec >= rusec)
+ {
+ /* No borrow. */
+ lusec -= rusec;
+ if (lsec >= rsec)
+ {
+ lsec -= rsec;
+ }
+ else
+ {
+ lsec = 0;
+ }
+ }
+ else
+ {
+ if (lsec > 0)
+ {
+ lusec += MICROSEC;
+ lusec -= rusec;
+ lsec -= 1;
+ if (lsec >= rsec)
+ {
+ lsec -= rsec;
+ }
+ else
+ {
+ lsec = 0;
+ }
+ }
+ else
+ {
+ lsec = 0;
+ lusec = 0;
+ }
+ }
+ Selective_SetTime (left, lsec, lusec);
+}
+
+
+/*
+ CheckParam -
+*/
+
+static void CheckParam (unsigned int paramno)
+{
+ if ((paramno < 1) || (paramno > MaxParam))
+ {
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ }
+}
+
+
+/*
+ CreateStartTime -
+*/
+
+static void CreateStartTime (void)
+{
+ if (EnableDiagnostics)
+ {
+ /* avoid dangling else. */
+ if (StartTime == NULL)
+ {
+ StartTime = Selective_InitTime (0, 0);
+ if ((Selective_GetTimeOfDay (StartTime)) == 0)
+ {} /* empty. */
+ }
+ if (TotalTime == NULL)
+ {
+ TotalTime = Selective_InitTime (0, 0);
+ }
+ }
+ else
+ {
+ StartTime = NULL;
+ TotalTime = NULL;
+ }
+}
+
+
+/*
+ UpdateTotalTime -
+*/
+
+static void UpdateTotalTime (void)
+{
+ if ((Selective_GetTimeOfDay (TotalTime)) == 0)
+ {} /* empty. */
+ DecTime (TotalTime, StartTime);
+}
+
+
+/*
+ GetTimeParam - a paramno of 0 will return the total time so far
+ whereas a paramno > 0 will return the time associated
+ with Diag.
+*/
+
+static Selective_Timeval GetTimeParam (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ unsigned int sec;
+ unsigned int usec;
+
+ if (paramno == 0)
+ {
+ UpdateTotalTime ();
+ return TotalTime;
+ }
+ else
+ {
+ return Diag->tdiag.total;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ GetMemParam - return the mem paramno from within Diag. A paramno of 0
+ will return the total heap.
+*/
+
+static long unsigned int GetMemParam (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ if (paramno == 0)
+ {
+ return TotalHeap;
+ }
+ else
+ {
+ return Diag->mdiag.param.array[paramno-1];
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CreateDecimalMem - converts c to a decimal string.
+*/
+
+static DynamicStrings_String CreateDecimalMem (long unsigned int c)
+{
+ return StringConvert_LongCardinalToString (c, 0, ' ', 10, true);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CreateHexadecimalMem - converts c to a hexadecimal string.
+*/
+
+static DynamicStrings_String CreateHexadecimalMem (long unsigned int c)
+{
+ return DynamicStrings_ConCat (DynamicStrings_InitString ((const char *) "0x", 2), DynamicStrings_Mark (StringConvert_LongCardinalToString (c, 0, ' ', 16, true)));
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CreateDecimalTime - return timeval as a decimal seconds.usecs string.
+*/
+
+static DynamicStrings_String CreateDecimalTime (Selective_Timeval timeval)
+{
+ unsigned int sec;
+ unsigned int usec;
+
+ Selective_GetTime (timeval, &sec, &usec);
+ return DynamicStrings_ConCat (DynamicStrings_ConCat (StringConvert_LongCardinalToString (static_cast<long unsigned int> (sec), 0, ' ', 10, true), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) ".", 1))), StringConvert_LongCardinalToString (static_cast<long unsigned int> (usec), 6, '0', 10, true));
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CreateHexadecimalTime - return timeval as a hexadecimal seconds.usecs string.
+*/
+
+static DynamicStrings_String CreateHexadecimalTime (Selective_Timeval timeval)
+{
+ unsigned int sec;
+ unsigned int usec;
+
+ Selective_GetTime (timeval, &sec, &usec);
+ return DynamicStrings_ConCat (DynamicStrings_ConCat (StringConvert_LongCardinalToString (static_cast<long unsigned int> (sec), 0, ' ', 16, true), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) ".", 1))), StringConvert_LongCardinalToString (static_cast<long unsigned int> (usec), 5, '0', 16, true));
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ Decimal - convert paramno in Diag to a string.
+*/
+
+static DynamicStrings_String Decimal (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ switch (Diag->type)
+ {
+ case M2Diagnostic_memdiag:
+ return CreateDecimalMem (GetMemParam (Diag, paramno));
+ break;
+
+ case M2Diagnostic_timediag:
+ return CreateDecimalTime (GetTimeParam (Diag, paramno));
+ break;
+
+
+ default:
+ CaseException ("../../gcc/m2/gm2-libs/M2Diagnostic.def", 20, 1);
+ __builtin_unreachable ();
+ }
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ Hexadecimal - convert paramno in Diag to a hex string.
+*/
+
+static DynamicStrings_String Hexadecimal (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ switch (Diag->type)
+ {
+ case M2Diagnostic_memdiag:
+ return CreateHexadecimalMem (GetMemParam (Diag, paramno));
+ break;
+
+ case M2Diagnostic_timediag:
+ return CreateHexadecimalTime (GetTimeParam (Diag, paramno));
+ break;
+
+
+ default:
+ CaseException ("../../gcc/m2/gm2-libs/M2Diagnostic.def", 20, 1);
+ __builtin_unreachable ();
+ }
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ Count - return the count field for a time diag or return the decimal
+ value for a paramno in a mem diag.
+*/
+
+static DynamicStrings_String Count (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ switch (Diag->type)
+ {
+ case M2Diagnostic_memdiag:
+ return CreateDecimalMem (GetMemParam (Diag, paramno));
+ break;
+
+ case M2Diagnostic_timediag:
+ return StringConvert_ctos (Diag->tdiag.count, 0, ' ');
+ break;
+
+
+ default:
+ CaseException ("../../gcc/m2/gm2-libs/M2Diagnostic.def", 20, 1);
+ __builtin_unreachable ();
+ }
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ Microsec - convert timeval into microseconds and return the value as
+ a longcard.
+*/
+
+static long unsigned int Microsec (Selective_Timeval timeval)
+{
+ unsigned int sec;
+ unsigned int usec;
+ long unsigned int microsec;
+
+ Selective_GetTime (timeval, &sec, &usec);
+ microsec = (((long unsigned int ) (sec))*MICROSEC)+((long unsigned int ) (usec));
+ return microsec;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CreateTimePercent - return timeval as a percentage of the TotalTime.
+*/
+
+static DynamicStrings_String CreateTimePercent (Selective_Timeval timeval)
+{
+ long unsigned int total;
+ long unsigned int param;
+
+ if (timeval == TotalTime)
+ {
+ param = 100;
+ }
+ else
+ {
+ UpdateTotalTime ();
+ param = (Microsec (timeval))*100;
+ total = Microsec (TotalTime);
+ if (total == 0)
+ {
+ param = 0;
+ }
+ else
+ {
+ param = param / total;
+ }
+ }
+ return DynamicStrings_ConCatChar (StringConvert_ctos ((unsigned int ) (param), 3, ' '), '%');
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CreateMemPercent - return memval as a percentage of TotalHeap.
+*/
+
+static DynamicStrings_String CreateMemPercent (long unsigned int memval)
+{
+ long unsigned int param;
+
+ if (memval == TotalHeap)
+ {
+ param = 100;
+ }
+ else
+ {
+ param = memval*100;
+ if (TotalHeap == 0)
+ {
+ param = 0;
+ }
+ else
+ {
+ param = param / TotalHeap;
+ }
+ }
+ return DynamicStrings_ConCatChar (StringConvert_ctos ((unsigned int ) (param), 3, ' '), '%');
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ DescribePercent - call the appropriate mem or time percentage procedure.
+*/
+
+static DynamicStrings_String DescribePercent (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ switch (Diag->type)
+ {
+ case M2Diagnostic_memdiag:
+ return CreateMemPercent (GetMemParam (Diag, paramno));
+ break;
+
+ case M2Diagnostic_timediag:
+ return CreateTimePercent (GetTimeParam (Diag, paramno));
+ break;
+
+
+ default:
+ CaseException ("../../gcc/m2/gm2-libs/M2Diagnostic.def", 20, 1);
+ __builtin_unreachable ();
+ }
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ DescribeMemory - return the memory diagnostic
+*/
+
+static DynamicStrings_String DescribeMemory (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ long unsigned int param;
+ DynamicStrings_String s;
+
+ param = GetMemParam (Diag, paramno);
+ if (param < kilo)
+ {
+ s = DynamicStrings_ConCat (StringConvert_LongCardinalToString (param, 0, ' ', 10, false), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) " Bytes", 6)));
+ }
+ else if (param < mega)
+ {
+ /* avoid dangling else. */
+ param = param / kilo;
+ s = DynamicStrings_ConCat (StringConvert_LongCardinalToString (param, 0, ' ', 10, false), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) "KB", 2)));
+ }
+ else
+ {
+ /* avoid dangling else. */
+ param = param / mega;
+ s = DynamicStrings_ConCat (StringConvert_LongCardinalToString (param, 0, ' ', 10, false), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) "MB", 2)));
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ DescribeTime - returns the time diagnostic in seconds.
+*/
+
+static DynamicStrings_String DescribeTime (M2Diagnostic_Diagnostic Diag, unsigned int paramno)
+{
+ unsigned int sec;
+ unsigned int usec;
+
+ switch (Diag->type)
+ {
+ case M2Diagnostic_memdiag:
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ break;
+
+ case M2Diagnostic_timediag:
+ Selective_GetTime (GetTimeParam (Diag, paramno), &sec, &usec);
+ return DynamicStrings_ConCat (DynamicStrings_ConCat (StringConvert_LongCardinalToString (static_cast<long unsigned int> (sec), 0, ' ', 10, true), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) ".", 1))), DynamicStrings_ConCat (StringConvert_LongCardinalToString (static_cast<long unsigned int> (usec), 6, '0', 10, true), DynamicStrings_Mark (DynamicStrings_InitString ((const char *) " sec", 4))));
+ break;
+
+
+ default:
+ CaseException ("../../gcc/m2/gm2-libs/M2Diagnostic.def", 20, 1);
+ __builtin_unreachable ();
+ }
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ParamSpec - ebnf:
+
+ ( '{' | '0' | '1' | '2' | '3' | '4' )
+ ( 'd' | 'x' | 'C' | 'T' | 'M' | 'N' | 'P' )
+ '}'
+*/
+
+static unsigned int ParamSpec (M2Diagnostic_Diagnostic Diag, unsigned int i)
+{
+ unsigned int paramno;
+ unsigned int length;
+ char ch;
+
+ length = DynamicStrings_Length (Diag->format);
+ paramno = 0;
+ if (i < length)
+ {
+ ch = DynamicStrings_char (Diag->format, static_cast<int> (i));
+ switch (ch)
+ {
+ case '{':
+ Output = DynamicStrings_ConCatChar (Output, '{');
+ return i+1;
+ break;
+
+ case '0':
+ paramno = 0;
+ break;
+
+ case '1':
+ paramno = 1;
+ break;
+
+ case '2':
+ paramno = 2;
+ break;
+
+ case '3':
+ paramno = 3;
+ break;
+
+ case '4':
+ paramno = 4;
+ break;
+
+
+ default:
+ Error ((const char *) "unexpected character: ", 22, ch);
+ break;
+ }
+ i += 1;
+ if (i < length)
+ {
+ ch = DynamicStrings_char (Diag->format, static_cast<int> (i));
+ switch (ch)
+ {
+ case 'd':
+ Output = DynamicStrings_ConCat (Output, Decimal (Diag, paramno));
+ break;
+
+ case 'x':
+ Output = DynamicStrings_ConCat (Output, Hexadecimal (Diag, paramno));
+ break;
+
+ case 'C':
+ Output = DynamicStrings_ConCat (Output, Count (Diag, paramno));
+ break;
+
+ case 'M':
+ Output = DynamicStrings_ConCat (Output, DescribeMemory (Diag, paramno));
+ break;
+
+ case 'N':
+ Output = DynamicStrings_ConCat (Output, Diag->name);
+ break;
+
+ case 'P':
+ Output = DynamicStrings_ConCat (Output, DescribePercent (Diag, paramno));
+ break;
+
+ case 'T':
+ Output = DynamicStrings_ConCat (Output, DescribeTime (Diag, paramno));
+ break;
+
+
+ default:
+ Error ((const char *) "unexpected character: ", 22, ch);
+ break;
+ }
+ i += 1;
+ if (i < length)
+ {
+ ch = DynamicStrings_char (Diag->format, static_cast<int> (i));
+ if (ch != '}')
+ {
+ Error ((const char *) "expected } character, seen ", 27, ch);
+ }
+ }
+ }
+ }
+ return i+1;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ FormatDiag - ebnf:
+
+ { ( '{' ParamSpec ) | any }
+*/
+
+static void FormatDiag (M2Diagnostic_Diagnostic Diag)
+{
+ unsigned int i;
+ unsigned int length;
+ char ch;
+
+ i = 0;
+ length = DynamicStrings_Length (Diag->format);
+ while (i < length)
+ {
+ ch = DynamicStrings_char (Diag->format, static_cast<int> (i));
+ if (ch == '{')
+ {
+ i += 1;
+ i = ParamSpec (Diag, i);
+ }
+ else
+ {
+ Output = DynamicStrings_ConCatChar (Output, ch);
+ i += 1;
+ }
+ }
+ Output = DynamicStrings_ConCatChar (Output, ASCII_nl);
+}
+
+
+/*
+ InitTimeDiagnostic - create and return a time diagnostic.
+ The format string can be free form and may
+ contain {1T}, {1C} or {1P}.
+ {1T} will contain the time and
+ {1C} the count of the number of times the
+ code enters the time diagnostic code region.
+ {1P} generates the time as a percentage.
+ {0T} is the total time for the application.
+ {{ is rendered as a single {.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_InitTimeDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high)
+{
+ M2Diagnostic_Diagnostic d;
+ char name[_name_high+1];
+ char format[_format_high+1];
+
+ /* make a local copy of each unbounded array. */
+ memcpy (name, name_, _name_high+1);
+ memcpy (format, format_, _format_high+1);
+
+ if (EnableDiagnostics)
+ {
+ Storage_ALLOCATE ((void **) &d, sizeof (M2Diagnostic__T1));
+ d->name = DynamicStrings_InitString ((const char *) name, _name_high);
+ d->format = DynamicStrings_InitString ((const char *) format, _format_high);
+ d->enable = DefaultTimeEnable;
+ d->next = Head;
+ d->type = M2Diagnostic_timediag;
+ switch (d->type)
+ {
+ case M2Diagnostic_timediag:
+ d->tdiag.count = 0;
+ d->tdiag.total = Selective_InitTime (0, 0);
+ d->tdiag.enter = Selective_InitTime (0, 0);
+ d->tdiag.exit_ = Selective_InitTime (0, 0);
+ break;
+
+
+ default:
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ break;
+ }
+ Head = d;
+ return d;
+ }
+ else
+ {
+ return NULL;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ EnterDiagnostic - attribute all execution time from now to TimeDiag.
+*/
+
+extern "C" void M2Diagnostic_EnterDiagnostic (M2Diagnostic_Diagnostic TimeDiag)
+{
+ if (EnableDiagnostics && (TimeDiag != NULL))
+ {
+ Assert (TimeDiag->type == M2Diagnostic_timediag);
+ Assert ((Selective_GetTimeOfDay (TimeDiag->tdiag.enter)) == 0);
+ TimeDiag->tdiag.count += 1;
+ }
+}
+
+
+/*
+ ExitDiagnostic - stop attributing execution time to TimeDiag.
+*/
+
+extern "C" void M2Diagnostic_ExitDiagnostic (M2Diagnostic_Diagnostic TimeDiag)
+{
+ if (EnableDiagnostics && (TimeDiag != NULL))
+ {
+ Assert (TimeDiag->type == M2Diagnostic_timediag);
+ Assert ((Selective_GetTimeOfDay (TimeDiag->tdiag.exit_)) == 0);
+ Accumulate (TimeDiag->tdiag.total, TimeDiag->tdiag.enter, TimeDiag->tdiag.exit_);
+ }
+}
+
+
+/*
+ InitMemDiagnostic - create and return a memory diagnostic.
+ The format string can be free form and may
+ contain {1M} {1d} {1x} {1P}.
+ {1M} is replaced by the value of the first parameter
+ with memory size units.
+ {1d} unsigned decimal. {1x} unsigned hexadecimal.
+ {0M} is the global allocation (Storage.mod:ALLOCATE).
+ {1P} is the percentage of param 1 relative
+ to global memory.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_InitMemDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high)
+{
+ unsigned int i;
+ M2Diagnostic_Diagnostic d;
+ char name[_name_high+1];
+ char format[_format_high+1];
+
+ /* make a local copy of each unbounded array. */
+ memcpy (name, name_, _name_high+1);
+ memcpy (format, format_, _format_high+1);
+
+ if (EnableDiagnostics)
+ {
+ Storage_ALLOCATE ((void **) &d, sizeof (M2Diagnostic__T1));
+ d->name = DynamicStrings_InitString ((const char *) name, _name_high);
+ d->format = DynamicStrings_InitString ((const char *) format, _format_high);
+ d->enable = DefaultMemEnable;
+ d->next = Head;
+ d->type = M2Diagnostic_memdiag;
+ switch (d->type)
+ {
+ case M2Diagnostic_memdiag:
+ for (i=1; i<=MaxParam; i++)
+ {
+ d->mdiag.param.array[i-1] = 0;
+ }
+ break;
+
+
+ default:
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ break;
+ }
+ Head = d;
+ return d;
+ }
+ else
+ {
+ return NULL;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ MemIncr - allow the appropriate parameter to be incremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*/
+
+extern "C" void M2Diagnostic_MemIncr (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int incr)
+{
+ if (EnableDiagnostics && (MemDiag != NULL))
+ {
+ CheckParam (paramno);
+ switch (MemDiag->type)
+ {
+ case M2Diagnostic_memdiag:
+ MemDiag->mdiag.param.array[paramno-1] += (long unsigned int ) (incr);
+ break;
+
+
+ default:
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ break;
+ }
+ }
+}
+
+
+/*
+ MemDecr - allow the appropriate parameter to be decremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*/
+
+extern "C" void M2Diagnostic_MemDecr (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int decr)
+{
+ if (EnableDiagnostics && (MemDiag != NULL))
+ {
+ CheckParam (paramno);
+ switch (MemDiag->type)
+ {
+ case M2Diagnostic_memdiag:
+ MemDiag->mdiag.param.array[paramno-1] -= (long unsigned int ) (decr);
+ break;
+
+
+ default:
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ break;
+ }
+ }
+}
+
+
+/*
+ MemSet - allow the appropriate parameter to be set to value.
+ All parameters are initially set to zero.
+*/
+
+extern "C" void M2Diagnostic_MemSet (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int value)
+{
+ if (EnableDiagnostics && (MemDiag != NULL))
+ {
+ CheckParam (paramno);
+ switch (MemDiag->type)
+ {
+ case M2Diagnostic_memdiag:
+ MemDiag->mdiag.param.array[paramno-1] = (long unsigned int ) (value);
+ break;
+
+
+ default:
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ break;
+ }
+ }
+}
+
+
+/*
+ TotalHeapIncr - increments the total heap used.
+*/
+
+extern "C" void M2Diagnostic_TotalHeapIncr (unsigned int incr)
+{
+ if (EnableDiagnostics)
+ {
+ TotalHeap = TotalHeap+((long unsigned int ) (incr));
+ }
+}
+
+
+/*
+ TotalHeapDecr - decrements the total heap used.
+*/
+
+extern "C" void M2Diagnostic_TotalHeapDecr (unsigned int incr)
+{
+ if (EnableDiagnostics)
+ {
+ TotalHeap = TotalHeap-((long unsigned int ) (incr));
+ }
+}
+
+
+/*
+ SetEnable - set the enable flag in Diag to value.
+*/
+
+extern "C" void M2Diagnostic_SetEnable (M2Diagnostic_Diagnostic Diag, bool value)
+{
+ if (EnableDiagnostics && (Diag != NULL))
+ {
+ Diag->enable = value;
+ }
+}
+
+
+/*
+ Lookup - returns the Diagnostic containing name or NIL
+ if it does not exist.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_Lookup (const char *name_, unsigned int _name_high)
+{
+ M2Diagnostic_Diagnostic ptr;
+ DynamicStrings_String s;
+ char name[_name_high+1];
+
+ /* make a local copy of each unbounded array. */
+ memcpy (name, name_, _name_high+1);
+
+ if (EnableDiagnostics)
+ {
+ s = DynamicStrings_InitString ((const char *) name, _name_high);
+ ptr = Head;
+ while (ptr != NULL)
+ {
+ if (DynamicStrings_Equal (ptr->name, s))
+ {
+ s = DynamicStrings_KillString (s);
+ return ptr;
+ }
+ ptr = ptr->next;
+ }
+ s = DynamicStrings_KillString (s);
+ return NULL;
+ }
+ else
+ {
+ return NULL;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ GetName - returns the name of Diag.
+*/
+
+extern "C" DynamicStrings_String M2Diagnostic_GetName (M2Diagnostic_Diagnostic Diag)
+{
+ if (EnableDiagnostics && (Diag != NULL))
+ {
+ return Diag->name;
+ }
+ else
+ {
+ return static_cast<DynamicStrings_String> (NULL);
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ForeachDiagDo - for diag in global diag list do
+ dp (diag);
+ end
+*/
+
+extern "C" void M2Diagnostic_ForeachDiagDo (M2Diagnostic_DiagProc dp)
+{
+ M2Diagnostic_Diagnostic ptr;
+
+ ptr = Head;
+ while (ptr != NULL)
+ {
+ (*dp.proc) (ptr);
+ ptr = ptr->next;
+ }
+}
+
+
+/*
+ SetDefaultConfig - force the Diag enable flag to the
+ time or mem global default.
+*/
+
+extern "C" void M2Diagnostic_SetDefaultConfig (M2Diagnostic_Diagnostic Diag)
+{
+ if (Diag->type == M2Diagnostic_timediag)
+ {
+ Diag->enable = DefaultTimeEnable;
+ }
+ else
+ {
+ Diag->enable = DefaultMemEnable;
+ }
+}
+
+
+/*
+ Configure - will turn on or off all the memory or time
+ instrumentation diagnostics and set the defaults
+ time and mem values.
+*/
+
+extern "C" void M2Diagnostic_Configure (bool time_, bool mem)
+{
+ if (EnableDiagnostics)
+ {
+ DefaultTimeEnable = time_;
+ DefaultMemEnable = mem;
+ M2Diagnostic_ForeachDiagDo ((M2Diagnostic_DiagProc) {(M2Diagnostic_DiagProc_t) M2Diagnostic_SetDefaultConfig});
+ }
+}
+
+
+/*
+ Generate - return a string containing the output from
+ all the diagnostics enabled.
+*/
+
+extern "C" DynamicStrings_String M2Diagnostic_Generate (void)
+{
+ if (EnableDiagnostics)
+ {
+ Output = DynamicStrings_KillString (Output);
+ Output = DynamicStrings_InitString ((const char *) "", 0);
+ M2Diagnostic_ForeachDiagDo ((M2Diagnostic_DiagProc) {(M2Diagnostic_DiagProc_t) FormatDiag});
+ return Output;
+ }
+ else
+ {
+ return static_cast<DynamicStrings_String> (NULL);
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+extern "C" void _M2_M2Diagnostic_init (__attribute__((unused)) int argc,__attribute__((unused)) char *argv[],__attribute__((unused)) char *envp[])
+{
+ TotalHeap = 0;
+ StartTime = NULL;
+ TotalTime = NULL;
+ CreateStartTime ();
+ Head = NULL;
+ Output = static_cast<DynamicStrings_String> (NULL);
+ DefaultTimeEnable = DefaultTimeEnableValue;
+ DefaultMemEnable = DefaultMemEnableValue;
+}
+
+extern "C" void _M2_M2Diagnostic_fini (__attribute__((unused)) int argc,__attribute__((unused)) char *argv[],__attribute__((unused)) char *envp[])
+{
+}
diff --git a/gcc/m2/mc-boot/GM2Diagnostic.h b/gcc/m2/mc-boot/GM2Diagnostic.h
new file mode 100644
index 000000000000..51f592daf3bc
--- /dev/null
+++ b/gcc/m2/mc-boot/GM2Diagnostic.h
@@ -0,0 +1,186 @@
+/* do not edit automatically generated by mc from M2Diagnostic. */
+/* M2Diagnotic provides memory and time diagnosics to the user.
+
+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 (_M2Diagnostic_H)
+# define _M2Diagnostic_H
+
+#include "config.h"
+#include "system.h"
+# ifdef __cplusplus
+extern "C" {
+# endif
+#include <stdbool.h>
+# if !defined (PROC_D)
+# define PROC_D
+ typedef void (*PROC_t) (void);
+ typedef struct { PROC_t proc; } PROC;
+# endif
+
+# include "GDynamicStrings.h"
+
+# if defined (_M2Diagnostic_C)
+# define EXTERN
+# else
+# define EXTERN extern
+# endif
+
+#if !defined (M2Diagnostic_Diagnostic_D)
+# define M2Diagnostic_Diagnostic_D
+ typedef void *M2Diagnostic_Diagnostic;
+#endif
+
+typedef struct M2Diagnostic_DiagProc_p M2Diagnostic_DiagProc;
+
+typedef void (*M2Diagnostic_DiagProc_t) (M2Diagnostic_Diagnostic);
+struct M2Diagnostic_DiagProc_p { M2Diagnostic_DiagProc_t proc; };
+
+
+/*
+ InitTimeDiagnostic - create and return a time diagnostic.
+ The format string can be free form and may
+ contain {1T}, {1C} or {1P}.
+ {1T} will contain the time and
+ {1C} the count of the number of times the
+ code enters the time diagnostic code region.
+ {1P} generates the time as a percentage.
+ {0T} is the total time for the application.
+ {{ is rendered as a single {.
+*/
+
+EXTERN M2Diagnostic_Diagnostic M2Diagnostic_InitTimeDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high);
+
+/*
+ EnterDiagnostic - attribute all execution time from now to TimeDiag.
+*/
+
+EXTERN void M2Diagnostic_EnterDiagnostic (M2Diagnostic_Diagnostic TimeDiag);
+
+/*
+ ExitDiagnostic - stop attributing execution time to TimeDiag.
+*/
+
+EXTERN void M2Diagnostic_ExitDiagnostic (M2Diagnostic_Diagnostic TimeDiag);
+
+/*
+ InitMemDiagnostic - create and return a memory diagnostic.
+ The format string can be free form and may
+ contain {1M} {1d} {1x} {1P}.
+ {1M} is replaced by the value of the first parameter
+ with memory size units.
+ {1d} unsigned decimal. {1x} unsigned hexadecimal.
+ {0M} is the global allocation (Storage.mod:ALLOCATE).
+ {1P} is the percentage of param 1 relative
+ to global memory.
+*/
+
+EXTERN M2Diagnostic_Diagnostic M2Diagnostic_InitMemDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high);
+
+/*
+ MemIncr - allow the appropriate parameter to be incremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*/
+
+EXTERN void M2Diagnostic_MemIncr (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int incr);
+
+/*
+ MemDecr - allow the appropriate parameter to be decremented.
+ All parameters are initially set to zero and are stored
+ as LONGCARD.
+*/
+
+EXTERN void M2Diagnostic_MemDecr (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int decr);
+
+/*
+ MemSet - allow the appropriate parameter to be set to value.
+ All parameters are initially set to zero.
+*/
+
+EXTERN void M2Diagnostic_MemSet (M2Diagnostic_Diagnostic MemDiag, unsigned int paramno, unsigned int value);
+
+/*
+ TotalHeapIncr - increments the total heap used.
+*/
+
+EXTERN void M2Diagnostic_TotalHeapIncr (unsigned int incr);
+
+/*
+ TotalHeapDecr - decrements the total heap used.
+*/
+
+EXTERN void M2Diagnostic_TotalHeapDecr (unsigned int incr);
+
+/*
+ SetEnable - set the enable flag in Diag to value.
+*/
+
+EXTERN void M2Diagnostic_SetEnable (M2Diagnostic_Diagnostic Diag, bool value);
+
+/*
+ Lookup - returns the Diagnostic containing name or NIL
+ if it does not exist.
+*/
+
+EXTERN M2Diagnostic_Diagnostic M2Diagnostic_Lookup (const char *name_, unsigned int _name_high);
+
+/*
+ GetName - returns the name of Diag.
+*/
+
+EXTERN DynamicStrings_String M2Diagnostic_GetName (M2Diagnostic_Diagnostic Diag);
+
+/*
+ ForeachDiagDo - for diag in global diag list do
+ dp (diag);
+ end
+*/
+
+EXTERN void M2Diagnostic_ForeachDiagDo (M2Diagnostic_DiagProc dp);
+
+/*
+ SetDefaultConfig - force the Diag enable flag to the
+ time or mem global default.
+*/
+
+EXTERN void M2Diagnostic_SetDefaultConfig (M2Diagnostic_Diagnostic Diag);
+
+/*
+ Configure - will turn on or off all the memory or time
+ instrumentation diagnostics and set the defaults
+ time and mem values.
+*/
+
+EXTERN void M2Diagnostic_Configure (bool time_, bool mem);
+
+/*
+ Generate - return a string containing the output from
+ all the diagnostics enabled.
+*/
+
+EXTERN DynamicStrings_String M2Diagnostic_Generate (void);
+# ifdef __cplusplus
+}
+# endif
+
+# undef EXTERN
+#endif
diff --git a/gcc/m2/pge-boot/GM2Diagnostic.cc b/gcc/m2/pge-boot/GM2Diagnostic.cc
new file mode 100644
index 000000000000..8f901d14d5ed
--- /dev/null
+++ b/gcc/m2/pge-boot/GM2Diagnostic.cc
@@ -0,0 +1,1485 @@
+/* do not edit automatically generated by mc from M2Diagnostic. */
+/* M2Diagnotic provides memory and time diagnosics to the user.
+
+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/>. */
+
+#include <stdbool.h>
+# if !defined (PROC_D)
+# define PROC_D
+ typedef void (*PROC_t) (void);
+ typedef struct { PROC_t proc; } PROC;
+# endif
+
+# if !defined (TRUE)
+# define TRUE (1==1)
+# endif
+
+# if !defined (FALSE)
+# define FALSE (1==0)
+# endif
+
+#include <stddef.h>
+#include <string.h>
+#include <limits.h>
+# include "GStorage.h"
+# include "Gmcrts.h"
+#if defined(__cplusplus)
+# undef NULL
+# define NULL 0
+#endif
+#define _M2Diagnostic_H
+#define _M2Diagnostic_C
+
+# include "GASCII.h"
+# include "GSelective.h"
+# include "GStringConvert.h"
+# include "GStorage.h"
+# include "GDynamicStrings.h"
+# include "GM2RTS.h"
+
+typedef struct M2Diagnostic_DiagProc_p M2Diagnostic_DiagProc;
+
+# define EnableDiagnostics true
+# define DefaultTimeEnableValue false
+# define DefaultMemEnableValue false
+# define MaxParam 4
+# define MICROSEC 100000
+typedef struct M2Diagnostic_timeDiag_r M2Diagnostic_timeDiag;
+
+typedef struct M2Diagnostic_memDiag_r M2Diagnostic_memDiag;
+
+typedef struct M2Diagnostic__T1_r M2Diagnostic__T1;
+
+typedef struct M2Diagnostic__T2_a M2Diagnostic__T2;
+
+typedef enum {M2Diagnostic_timediag, M2Diagnostic_memdiag} M2Diagnostic_DiagType;
+
+# define kilo 1024
+# define mega (kilo*kilo)
+# define giga (mega*kilo)
+typedef M2Diagnostic__T1 *M2Diagnostic_Diagnostic;
+
+typedef void (*M2Diagnostic_DiagProc_t) (M2Diagnostic_Diagnostic);
+struct M2Diagnostic_DiagProc_p { M2Diagnostic_DiagProc_t proc; };
+
+struct M2Diagnostic_timeDiag_r {
+ unsigned int count;
+ Selective_Timeval total;
+ Selective_Timeval enter;
+ Selective_Timeval exit_;
+ };
+
+struct M2Diagnostic__T2_a { long unsigned int array[MaxParam-1+1]; };
+struct M2Diagnostic_memDiag_r {
+ M2Diagnostic__T2 param;
+ };
+
+struct M2Diagnostic__T1_r {
+ DynamicStrings_String name;
+ DynamicStrings_String format;
+ bool enable;
+ M2Diagnostic_Diagnostic next;
+ M2Diagnostic_DiagType type; /* case tag */
+ union {
+ M2Diagnostic_timeDiag tdiag;
+ M2Diagnostic_memDiag mdiag;
+ };
+ };
+
+static DynamicStrings_String Output;
+static long unsigned int TotalHeap;
+static M2Diagnostic_Diagnostic Head;
+static bool DefaultTimeEnable;
+static bool DefaultMemEnable;
+static Selective_Timeval StartTime;
+static Selective_Timeval TotalTime;
+
+/*
+ InitTimeDiagnostic - create and return a time diagnostic.
+ The format string can be free form and may
+ contain {1T}, {1C} or {1P}.
+ {1T} will contain the time and
+ {1C} the count of the number of times the
+ code enters the time diagnostic code region.
+ {1P} generates the time as a percentage.
+ {0T} is the total time for the application.
+ {{ is rendered as a single {.
+*/
+
+extern "C" M2Diagnostic_Diagnostic M2Diagnostic_InitTimeDiagnostic (const char *name_, unsigned int _name_high, const char *format_, unsigned int _format_high);
+
+/*
+ EnterDiagnostic - attribute all execution time from now to TimeDiag.
+*/
+
+extern "C" void M2Diagnostic_EnterDiagnostic (M2Diagnostic_Diagnostic TimeDiag);
+
+/*
+ ExitDiagnostic - stop attributing execution time to TimeDiag.
+*/
+
+extern "C" void M2Diagnostic_ExitDiagnostic (M2Diagnostic_Diagnostic TimeDiag);
+
+/*
+ InitMemDiagnostic - create and return a memory diagnostic.
+ The format string can be free form and may
+ contain {1M} {1d} {1x} {1P}.
+ [...]
[diff truncated at 524288 bytes]
More information about the Gcc-cvs
mailing list