@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.
IO.def \
Indexing.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
NumberIO.def \
SEnvironment.def \
SFIO.def \
SYSTEM.def \
+ Selective.def \
Scan.def \
StdIO.def \
Storage.def \
IO.mod \
Indexing.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
NumberIO.mod \
# found in gm2-libs-ch.
GM2-LIBS-BOOT-C = \
+ Selective.c \
StdIO.c \
SysExceptions.c \
choosetemp.c \
LMathLib0.def \
LegacyReal.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
MathLib0.def \
SMathLib0.def \
SYSTEM.def \
Scan.def \
+ Selective.def \
StdIO.def \
Storage.def \
StrCase.def \
LMathLib0.mod \
LegacyReal.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
MathLib0.mod \
FpuIO.def \
IO.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
MemUtils.def \
FpuIO.mod \
IO.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
MemUtils.mod \
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 $<
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 \
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 \
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
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.
IO.mod \
Indexing.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
M2EXCEPTION.mod \
M2RTS.mod \
NumberIO.mod \
StrCase.mod \
StrIO.mod \
StrLib.mod \
+ StringConvert.mod \
SysStorage.mod
# Program module ppg.mod from which pge.mod is created. ppg.mod is
FpuIO.def \
IO.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
MemUtils.def \
GLists.h \
GM2Dependent.cc \
GM2Dependent.h \
+ GM2Diagnostic.cc \
+ GM2Diagnostic.h \
GM2EXCEPTION.cc \
GM2EXCEPTION.h \
GM2RTS.cc \
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) ;
(*
VAR
const,
+ set,
subrange,
enumeration,
constructor: Fifo ;
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.
*)
BEGIN
Init(const) ;
+ Init(set) ;
Init(enumeration) ;
Init(subrange) ;
Init(constructor)
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 ;
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.
*)
type (sym). Bit 0 maps onto MIN(sym).
*)
-PROCEDURE PushSetTree (tokenno: CARDINAL;
- t: tree; sym: CARDINAL) ;
+PROCEDURE PushSetTree (tokenno: CARDINAL; value: tree; sym: CARDINAL) ;
(*
(*
- 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 ;
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,
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,
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) ;
EnumerationField: CARDINAL ;
CurrentTokenNo : CARDINAL ;
(* WatchedValue : PtrToValue ; *)
+ StackMemDiag : Diagnostic ; (* Contains memory related statistics *)
+ RangeMemDiag : Diagnostic ; (* Contains memory related statistics *)
+
(*
BEGIN
IF FreeList=NIL
THEN
- NEW (v)
+ NEW (v) ;
+ MemIncr (StackMemDiag, 1, 1) ;
+ MemIncr (StackMemDiag, 2, SIZE (v^))
ELSE
v := FreeList ;
FreeList := FreeList^.next
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
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.
*)
(*
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 ;
END ConvertToType ;
-
(*
IsSolved - returns true if the memory cell indicated by v
has a known value.
(*
- 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
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 ;
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)) ;
PushIntegerTree(i) ;
PushIntegerTree(e2) ;
UNTIL Gre(tokenno) ;
- RETURN( t )
+ RETURN t
END BuildRange ;
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 ;
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.
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 ;
IndexChecking, RangeChecking,
ReturnChecking, CaseElseChecking, Exceptions,
WholeValueChecking,
- DebugBuiltins,
+ DebugBuiltins, GetWideset,
Iso, Pim, Pim2, Pim3 ;
FROM m2type IMPORT GetIntegerType,
Comp,
Expr,
Ass : CompatibilityArray ;
+ m2wideset,
Ord,
OrdS, OrdL,
Float,
InitSystem ;
MakeBitset ; (* We do this after SYSTEM has been created as BITSET
- is dependant upon WORD. *)
+ is dependant upon WORD and BOOLEAN. *)
InitBaseConstants ;
InitBaseFunctions ;
(* 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
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
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 ;
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
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 ;
(*
- 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;
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))
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 *)
(*
- 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
FlushBuffer (StdOut)
END ;
DumpQuadruples ('after all front end optimization\n')
-END OptimizationAnalysis ;
+END ResourceAnalysis ;
(*
qprintf0 (' gcc trees given to the gcc backend\n') ;
EndGlobalContext ;
- OptimizationAnalysis
+ ResourceAnalysis
END Code ;
FROM M2Debug IMPORT Assert ;
IMPORT m2flex ;
+IMPORT m2block ;
IMPORT P0SyntaxCheck ;
IMPORT P1Build ;
IMPORT P2Build ;
IMPORT PHBuild ;
IMPORT PCSymBuild ;
IMPORT DynamicStrings ;
+IMPORT M2Diagnostic ;
FROM M2Batch IMPORT GetSource, GetModuleNo, GetDefinitionModuleFile, GetModuleFile,
AssociateModule, AssociateDefinition, MakeImplementationSource,
GetImportStatementList ;
FROM M2Search IMPORT FindSourceDefFile ;
+FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemSet ;
FROM FIO IMPORT File, StdErr, StdOut, Close, EOF, IsNoError, WriteLine,
WriteChar, FlushOutErr ;
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 ;
InitStringChar, RIndex, Slice, Equal, RemoveWhitePrefix ;
+
CONST
Debugging = FALSE ;
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.
ScaffoldStatic, GetRuntimeModuleOverride ;
FROM M2AsmUtil IMPORT GetFullSymName, GetFullScopeAsmName ;
+FROM FormatStrings IMPORT Sprintf1 ;
FROM M2Batch IMPORT MakeDefinitionSource ;
FROM NameKey IMPORT Name, MakeKey, NulName, KeyToCharStar, makekey ;
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 ;
GetSubrange, PutSubrange, GetArraySubscript,
NoOfParamAny, GetNthParamAny,
PushValue, PopValue, PopSize,
+ IsProcedureAnyNoReturn,
IsTemporary, IsUnbounded, IsPartialUnbounded,
IsEnumeration, IsVar,
IsSubrange, IsPointer, IsRecord, IsArray,
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,
BuildSetType, BuildEndVarient, BuildEndArrayType, InitFunctionTypeParameters,
BuildProcTypeParameterDeclaration, DeclareKnownType,
ValueOutOfTypeRange, ExceedsTypeRange,
- GetMaxFrom, GetMinFrom ;
+ GetMaxFrom, GetMinFrom, GetBooleanEnumList ;
FROM m2convert IMPORT BuildConvert ;
action : IsAction ;
ConstantResolved,
enumDeps : BOOLEAN ;
+ tempset : CARDINAL ; (* Count of the number of set *)
+ (* arrays created. *)
(* *************************************************** *)
PROCEDURE PutEnumList (sym: CARDINAL; enumlist: tree) ;
BEGIN
- PutIndice(EnumerationIndex, sym, enumlist)
+ PutIndice (EnumerationIndex, sym, enumlist)
END PutEnumList ;
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 ;
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 ;
*)
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 ;
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) )
PROCEDURE AllDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsTypeQ(sym, IsFullyDeclared) )
+ RETURN( IsTypeQ (sym, IsFullyDeclared) )
END AllDependantsFullyDeclared ;
PROCEDURE NotAllDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( NOT IsTypeQ(sym, IsFullyDeclared) )
+ RETURN( NOT IsTypeQ (sym, IsFullyDeclared) )
END NotAllDependantsFullyDeclared ;
PROCEDURE AllDependantsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsTypeQ(sym, IsPartiallyDeclared) )
+ RETURN( IsTypeQ (sym, IsPartiallyDeclared) )
END AllDependantsPartiallyDeclared ;
PROCEDURE NotAllDependantsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( NOT IsTypeQ(sym, IsPartiallyDeclared) )
+ RETURN( NOT IsTypeQ (sym, IsPartiallyDeclared) )
END NotAllDependantsPartiallyDeclared ;
PROCEDURE AllDependantsPartiallyOrFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsTypeQ(sym, IsPartiallyOrFullyDeclared) )
+ RETURN( IsTypeQ (sym, IsPartiallyOrFullyDeclared) )
END AllDependantsPartiallyOrFullyDeclared ;
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 ;
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, todolist)
- ELSE
+ ELSIF NOT IsFullyDeclared (sym)
+ THEN
t := TypeConstFullyDeclared(sym) ;
IF t#NIL
THEN
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
PROCEDURE CanBeDeclaredPartiallyViaPartialDependants (sym: CARDINAL) : BOOLEAN ;
BEGIN
- RETURN( IsType(sym) AND AllDependantsPartiallyDeclared(sym) )
+ RETURN( IsType (sym) AND AllDependantsPartiallyDeclared (sym) )
END CanBeDeclaredPartiallyViaPartialDependants ;
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 ;
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')
finished: BOOLEAN ;
copy : Group ;
BEGIN
+ EnterDiagnostic (DeclaredOutstandingTypesDiag) ;
copy := NIL ;
finished := FALSE ;
REPEAT
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,
THEN
END
END ;
+ ExitDiagnostic (DeclaredOutstandingTypesDiag) ;
RETURN NoOfElementsInSet (GlobalGroup^.ToDoList) = 0
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
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 ;
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)
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
(*
- 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) ;
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 ;
PROCEDURE WalkTypesInProcedure (sym: WORD) ;
BEGIN
- ForeachLocalSymDo(sym, TraverseDependants)
+ ForeachLocalSymDo (sym, TraverseDependants)
END WalkTypesInProcedure ;
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 ;
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 ;
DeclareProcedureToGccWholeProgram -
*)
-PROCEDURE DeclareProcedureToGccWholeProgram (Sym: CARDINAL) ;
+PROCEDURE DeclareProcedureToGccWholeProgram (ProcedureSym: CARDINAL) ;
VAR
returnType,
GccParam : tree ;
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)),
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 ;
DeclareProcedureToGccSeparateProgram -
*)
-PROCEDURE DeclareProcedureToGccSeparateProgram (Sym: CARDINAL) ;
+PROCEDURE DeclareProcedureToGccSeparateProgram (ProcedureSym: CARDINAL) ;
VAR
returnType,
GccParam : tree ;
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 ;
THEN
DisplayQuadRange (scope, start, end)
END ;
+ EnterDiagnostic (DeclareTypesConstantsProceduresInRangeDiag) ;
loop := 0 ;
copy := NIL ;
sb := InitScopeBlock (scope) ;
KillGroup (copy) ;
bb := InitBasicBlocks (sb) ;
KillBasicBlocks (bb) ;
- KillScopeBlock (sb)
+ KillScopeBlock (sb) ;
+ ExitDiagnostic (DeclareTypesConstantsProceduresInRangeDiag)
END DeclareTypesConstantsProceduresInRange ;
THEN
printf0 ("declaring types constants in: ") ; PrintTerse (scope)
END ;
+ EnterDiagnostic (DeclareTypesConstantsProceduresDiag) ;
copy := NIL ;
sb := InitScopeBlock (scope) ;
PushBinding (scope) ;
UNTIL EqualGroup (copy, GlobalGroup) ;
KillGroup (copy) ;
PopBinding (scope) ;
- KillScopeBlock (sb)
+ KillScopeBlock (sb) ;
+ ExitDiagnostic (DeclareTypesConstantsProceduresDiag)
END DeclareTypesConstantsProcedures ;
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 ;
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) ;
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
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) ;
INC (n) ;
Variable := GetNth (ModSym, n)
END ;
- ForeachInnerModuleDo(ModSym, DeclareGlobalVariablesWholeProgram)
+ ForeachInnerModuleDo (ModSym, DeclareGlobalVariablesWholeProgram)
END DeclareGlobalVariablesWholeProgram ;
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
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
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.
*)
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) ;
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 ;
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 ;
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 ;
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 ;
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 ;
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 ;
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 ;
(*
- 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 ;
(*
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 ;
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)
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 ;
PROCEDURE IsArrayDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result : BOOLEAN ;
- align : CARDINAL ;
+ align,
subscript: CARDINAL ;
high, low: CARDINAL ;
type : CARDINAL ;
result := TRUE ;
Assert(IsArray(sym)) ;
type := GetSType(sym) ;
-
IF NOT q(type)
THEN
result := FALSE
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) ;
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
PROCEDURE WalkArrayDependants (sym: CARDINAL; p: WalkAction) ;
VAR
- align : CARDINAL ;
+ align,
subscript: CARDINAL ;
high, low: CARDINAL ;
type : CARDINAL ;
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.
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 ;
PROCEDURE WalkSetDependants (sym: CARDINAL; p: WalkAction) ;
VAR
- type, low, high: CARDINAL ;
+ type, low, high, array: CARDINAL ;
BEGIN
Assert(IsSet(sym)) ;
low := GetTypeMin(type) ;
p(low) ;
high := GetTypeMax(type) ;
- p(high)
+ p(high) ;
+ array := GetSetArray (sym) ;
+ IF array # NulSym
+ THEN
+ p (array)
+ END
END WalkSetDependants ;
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
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 ;
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 ;
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 ;
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 ;
PROCEDURE PoisonSymbols (sym: CARDINAL) ;
BEGIN
- IF IsProcedure(sym)
+ IF IsProcedure (sym)
THEN
- ForeachLocalSymDo(sym, Poison)
+ ForeachLocalSymDo (sym, Poison)
END
END PoisonSymbols ;
PROCEDURE ConstantKnownAndUsed (sym: CARDINAL; t: tree) ;
BEGIN
- DeclareConstantFromTree(sym, RememberConstant(t))
+ DeclareConstantFromTree (sym, RememberConstant (t))
END ConstantKnownAndUsed ;
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.
GetLowestType,
GetLocalSym, GetVarWritten,
GetVarient, GetVarBackEndType, GetModuleCtors,
+ GetSetInWord, GetDType,
+ GetNthParamAnyClosest,
+ GetMainModule, IsUnknown,
NoOfVariables,
NoOfParamAny, GetParent, GetDimension, IsAModula2Type,
IsModule, IsDefImp, IsType, IsModuleWithinProcedure,
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 ;
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 ;
NoOfItemsInList, GetItemFromList ;
FROM M2ALU IMPORT PtrToValue,
+ KillValue, PopInto,
IsValueTypeReal, IsValueTypeSet,
IsValueTypeConstructor, IsValueTypeArray,
IsValueTypeRecord, IsValueTypeComplex,
PromoteToString, PromoteToCString, DeclareLocalVariable,
CompletelyResolved,
PoisonSymbols, GetTypeMin, GetTypeMax,
- IsProcedureGccNested, DeclareParameters,
+ IsProcedureGccNested, DeclareParameters, DeclareProcedure,
ConstantKnownAndUsed, PrintSym ;
FROM M2Range IMPORT CodeRangeCheck, FoldRangeCheck, CodeErrorCheck, GetMinMax ;
GetBuiltinConst, GetBuiltinTypeInfo,
BuiltinExists, BuildBuiltinTree ;
-FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
+FROM m2expr IMPORT GetIntegerZero, GetIntegerOne, GetWordOne,
GetCardinalOne,
GetPointerZero,
GetCardinalZero,
+ GetBitsetZero,
GetSizeOfInBits,
TreeOverflow,
FoldAndStrip,
StringLength,
AreConstantsEqual,
GetCstInteger,
+ GetRValue,
BuildForeachWordInSetDoIfExpr,
BuildIfConstInVar,
BuildIfVarInVar,
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,
BuildEqualTo, BuildNotEqualTo,
BuildIsSuperset, BuildIsNotSuperset,
BuildIsSubset, BuildIsNotSubset,
+ BuildIfInSet, BuildIfNotInSet,
BuildIndirect, BuildArray,
BuildTrunc, BuildCoerce,
- BuildBinaryForeachWordDo,
- BuildBinarySetDo,
BuildSetNegate,
BuildComponentRef,
BuildCap, BuildAbs, BuildIm, BuildRe, BuildCmplx,
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,
FROM m2type IMPORT ChainOnParamValue, GetPointerType, GetIntegerType, AddStatement,
GetCardinalType, GetWordType, GetM2ZType, GetM2RType, GetM2CType,
+ GetBooleanFalse,
BuildCharConstant, AddStringToTreeList, BuildArrayStringConstructor,
GetArrayNoOfElements, GetTreeType, IsGccStrictTypeEquivalent ;
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 ;
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. *)
(*
BEGIN
InitBuiltinSyms (BuiltinTokenNo) ;
GetQuad(q, op, op1, op2, op3) ;
+ CheckBreak (q) ;
IF op=StatementNoteOp
THEN
FoldStatementNote (op3) (* Will change CurrentQuadToken using op3. *)
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) |
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 ;
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 ;
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.
*)
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) ;
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 ;
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
parameter, procedure)
ELSIF compatible
THEN
- doParam (quad, parampos, nth, procedure, parameter)
+ doParam (parampos, quad, nth, procedure, parameter)
END
END
END CodeParam ;
END CodeAddr ;
-PROCEDURE stop ; BEGIN END stop ;
-
-PROCEDURE CheckStop (q: CARDINAL) ;
-BEGIN
- IF q=3827
- THEN
- stop
- END
-END CheckStop ;
-
-
(*
------------------------------------------------------------------------------
:= Operator
BEGIN
IF DeclaredOperandsBecomes (p, quad)
THEN
+ CheckBreak (quad) ;
IF (NOT IsConditionalBooleanQuad (quad)) OR IsBasicBlockFirst (bb)
THEN
IF TypeCheckBecomes (p, quad)
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 ;
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
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) ;
(*
- 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.
*)
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 ;
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 ;
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 ;
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 ;
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
PROCEDURE CodeSetOr (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalOr, SetOr, quad)
+ CodeBinarySet (SetOr, BuildLogicalOr, MakeKey ("Or"), quad)
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 ;
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 ;
(*
*)
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 ;
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 ;
*)
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 ;
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 ;
PROCEDURE CodeSetLogicalDifference (quad: CARDINAL) ;
BEGIN
- CodeBinarySet (BuildLogicalDifference, SetDifference, quad)
+ CodeBinarySet (SetAnd, BuildLogicalDifference,
+ MakeKey ("LogicalDifference"), quad)
END CodeSetLogicalDifference ;
(*
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 ;
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
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) ;
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)
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)
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
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 ;
(*
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
(*
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 ;
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 ;
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 ;
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 -
*)
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 ;
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 (),
(*
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) ;
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 ;
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) ;
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 ;
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 ;
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
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
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 ;
(*
- 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 ;
(*
PROCEDURE PerformCodeIfGre (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
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 ;
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 ;
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
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 ;
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 ;
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
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 ;
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 -
*)
PROCEDURE PerformCodeIfEqu (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
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 ;
PROCEDURE PerformCodeIfNotEqu (quad: CARDINAL) ;
VAR
- tl, tr : tree ;
+ tl, tr, condition : tree ;
location : location_t ;
left, right, dest, combined,
leftpos, rightpos, destpos : CARDINAL ;
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
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 ;
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 ;
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.
{%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.
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,
highplus1 : CARDINAL ;
len,
ini : INTEGER ;
+ vowel,
glyph,
chain,
root,
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 ;
(*
- 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.
*)
VAR
c: colorType ;
BEGIN
+ checkVowel (toblock, fromblock) ;
IF empty (fromblock)
THEN
toblock.stackPtr := fromblock.stackPtr ;
)
=:
- 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 ] =:
*)
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.
*)
RETURN InitString('set')
ELSIF IsUnknown(sym)
THEN
- RETURN InitString('an unknown')
+ RETURN InitString('unknown')
ELSIF IsSubrange(sym)
THEN
RETURN InitString('subrange')
(*
- 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 =:
*)
'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) |
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. *)
SharedFlag, (* -fshared indicating this module needs *)
(* the shared library version of the *)
(* scaffold. *)
+ TimeReport, MemReport, (* -ftime-report and -fmem-report values. *)
ForcedLocation,
GenerateStatementNote,
Optimizing,
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.
DumpDecl, (* -fm2-dump=decl. *)
DumpGimple, (* -fm2-dump=gimple. *)
DumpQuad, (* -fq, -fm2-dump=quad dump quadruples. *)
+ WidesetFlag, (* -fwideset. *)
MFlag,
MMFlag,
MPFlag,
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 ;
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) ;
OptimizeBasicBlock := FALSE ;
OptimizeUncalledProcedures := FALSE ;
OptimizeCommonSubExpressions := FALSE ;
+ OptimizeSets := FALSE ;
NilChecking := FALSE ;
WholeDivChecking := FALSE ;
WholeValueChecking := FALSE ;
DumpGimple := FALSE ;
M2Dump := NIL ;
M2DumpFilter := NIL ;
+ TimeReport := FALSE ;
+ MemReport := FALSE ;
EnableForward := TRUE ;
OffTBits := 0 ; (* Default to CSSIZE_T. *)
+ WidesetFlag := TRUE ;
END M2Options.
MakeConstString, MakeConstant, MakeConstVar,
MakeConstStringM2nul, MakeConstStringCnul,
Make2Tuple, IsTuple,
+ MakeSubrange, PutSubrange,
+ PutSetArray, MakeSetArray,
RequestSym, MakePointer, PutPointer,
SkipType,
GetDType, GetSType, GetLType,
IsFieldEnumeration,
IsVar, IsProcType, IsType, IsSubrange, IsExported,
IsConst, IsConstString, IsModule, IsDefImp,
+ IsConstVar,
IsArray, IsUnbounded, IsProcedureNested,
IsParameterUnbounded,
IsPartialUnbounded, IsProcedureBuiltin,
FROM M2GCCDeclare IMPORT PutToBeSolvedByQuads ;
FROM FifoQueue IMPORT GetConstFromFifoQueue,
- PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue ;
+ PutConstructorIntoFifoQueue, GetConstructorFromFifoQueue,
+ GetSetFromFifoQueue ;
FROM M2Comp IMPORT CompilingImplementationModule,
CompilingProgramModule ;
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 ;
(* 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. *)
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
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 ;
(*
- 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) ;
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) ;
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 ()),
(* 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
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
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
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
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
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)) ;
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) ;
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
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
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)
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,
PROCEDURE DisplayQuad (QuadNo: CARDINAL) ;
BEGIN
+ IF QuadNo # 0
+ THEN
DSdbEnter ;
fprintf1 (GetDumpFile (), '%4d ', QuadNo) ; WriteQuad(QuadNo) ; fprintf0 (GetDumpFile (), '\n') ;
DSdbExit
+ END
END DisplayQuad ;
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 ;
InitList(VarientFields) ;
VarientFieldNo := 0 ;
NoOfQuads := 0 ;
+ QuadMemDiag
+ := InitMemDiagnostic
+ ('M2Quad:Quadruples',
+ '{0N} total quadruples {1d} consuming {2M} ram {0M} ({2P})')
END Init ;
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)
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 ;
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")) ;
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 ;
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 ;
FROM StrLib IMPORT StrLen ;
FROM libc IMPORT strlen ;
FROM ASCII IMPORT nul ;
+(* FROM M2Diagnostic IMPORT Diagnostic, InitMemDiagnostic, MemIncr, MemDecr, MemSet ; *)
TYPE
BinaryTree: NameNode ;
KeyIndex : Index ;
LastIndice: CARDINAL ;
+(*
+ NameKeyTreeMemDiag,
+ NameKeyWordMemDiag: Diagnostic ;
+*)
(*
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 ;
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 ;
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 ;
INC(p)
END ;
p^ := nul ;
-
RETURN( DoMakeKey(n, higha) )
END
END MakeKey ;
ALLOCATE(p, higha+1) ;
IF p=NIL
THEN
- HALT (* out of memory error *)
+ HALT (* Out of memory error. *)
ELSE
n := p ;
pa := a ;
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.
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 ;
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). *)
-- end of the Silent constant rules
-SetType := ( "SET" | "PACKEDSET" ) "OF" SimpleType =:
+SetType := ( "SET" | "PACKEDSET" ) "OF" SimpleType
+ =:
PointerType := "POINTER" "TO"
Type
-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 ;
(* 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>.
CONST
USEPOISON = TRUE ;
- GGCPOISON = 0A5A5A5A5H ; (* poisoned memory contains this code *)
+ GGCPOISON = 0A5A5A5A5H ; (* Poisoned memory contains this code. *)
TYPE
PtrToCardinal = POINTER TO CARDINAL ;
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 ;
(*
old: tree ;
t : PtrToCardinal ;
BEGIN
+ CheckBook (sym) ;
IF gcc=GetErrorNode()
THEN
InternalError ('error node generated during symbol conversion')
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 ;
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.
*)
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.
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 ;
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,
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
(* (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. *)
(* errors. *)
ConstLitArray : Indexing.Index ;
BreakSym : CARDINAL ; (* Allows interactive debugging. *)
+ SymMemDiag : Diagnostic ; (* Contains memory related statistics *)
(*
END ;
PutIndice(Symbols, sym, pSym) ;
CheckBreak (sym) ;
- INC(FreeSymbol)
+ INC (FreeSymbol) ;
+ MemSet (SymMemDiag, 1, FreeSymbol-1) ;
+ MemIncr (SymMemDiag, 2, SIZE (pSym^))
END NewSym ;
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.
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.
*)
VarSym: RETURN Var.IsSSA
ELSE
- InternalError ('expecting a variable symbol')
+ RETURN FALSE
END
END
END IsVariableSSA ;
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 *)
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 ;
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. *)
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 ;
CASE SymbolType OF
ErrorSym : n := 0 |
-(*
- ArraySym ,
- UnboundedSym : n := 1 | (* Standard language limitation *)
-*)
EnumerationSym: n := pSym^.Enumeration.NoOfElements |
InterfaceSym : n := HighIndice(Interface.Parameters)
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 *)
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.
*)
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 -
*)
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
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')
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')
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);
_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);
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. */
PROCEDURE removeStmtNote ;
+(*
+ GetTotalConstants - returns the number of global constants.
+*)
+
+PROCEDURE GetTotalConstants () : CARDINAL ;
+
+
+(*
+ GetGlobalTypes - returns the number of global types.
+*)
+
+PROCEDURE GetGlobalTypes () : CARDINAL ;
+
+
END m2block.
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);
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)
/* 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))
{
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. */
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. */
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 *.
*)
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);
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,
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);
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);
}
/* 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);
}
}
/* 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);
}
}
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);
}
}
-/* 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. */
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
/* 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. */
/* 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)
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
{
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. */
{
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. */
{
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. */
{
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
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
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,
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
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. */
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. */
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 ;
PROCEDURE GetCardinalZero (location: location_t) : tree ;
+PROCEDURE GetBitsetZero (location: location_t) : tree ;
+
+
PROCEDURE GetSizeOfInBits (type: tree) : 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 ;
(*
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 ;
(*
(*
- 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 ;
(*
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.
*)
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.
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);
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,
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,
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,
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,
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
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);
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
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;
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,
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)
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
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
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);
}
}
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
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)
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
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)
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
}
}
-/* BuildIndirectProcedureCallTree - creates a procedure call from a
+/* BuildIndirectProcedureCallTree creates a procedure call from a
procedure and parameter list and the return type, rettype. */
tree
}
-/* BuildFunctValue - generates code for value :=
- last_function(foobar); */
+/* BuildFunctValue generates code for
+ value := last_function (foobar). */
tree
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,
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,
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
m2statement_BuildProcedureCallTree (location, procedure, rettype);
}
-/* SetLastFunction - assigns last_function to, t. */
+/* SetLastFunction assigns last_function to, t. */
void
m2statement_SetLastFunction (tree t)
last_function = t;
}
-/* SetParamList - assigns param_list to, t. */
+/* SetParamList assigns param_list to, t. */
void
m2statement_SetParamList (tree t)
param_list = t;
}
-/* GetLastFunction - returns, last_function. */
+/* GetLastFunction returns, last_function. */
tree
m2statement_GetLastFunction (void)
return last_function;
}
-/* GetParamList - returns, param_list. */
+/* GetParamList returns, param_list. */
tree
m2statement_GetParamList (void)
return param_list;
}
-/* GetCurrentFunction - returns the current_function. */
+/* GetCurrentFunction returns the current_function. */
tree
m2statement_GetCurrentFunction (void)
return current_function_decl;
}
-/* GetParamTree - return parameter, i. */
+/* GetParamTree return parameter, i. */
tree
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
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
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,
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. */
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)
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
}
-/* BuildIfThenDoEnd - returns a tree which will only execute
+/* BuildIfThenDoEnd returns a tree which will only execute
statement, s, if, condition, is true. */
tree
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
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)
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"
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) ;
(*
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.
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.
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);
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,
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
{
word = m2convert_ToWord (location, word);
bit = m2convert_ToWord (location, bit);
- m2statement_DoJump (
+ m2statement_IfExprJump (
location,
m2expr_build_binary_op (
location, code,
FALSE),
FALSE),
m2expr_GetWordZero (location), FALSE),
- NULL, label);
+ label);
}
/* build_modify_expr - taken from c-typeck.cc and heavily pruned.
/* nCount - return the number of trees chained on, t. */
-static int
-nCount (tree t)
+int
+m2treelib_nCount (tree t)
{
int i = 0;
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;
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
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.
*)
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.
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,
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. */
/* 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;
};
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
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
#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. */
}
/* IsGccRealType return true if type is a GCC realtype. */
-
+
static
bool
IsGccRealType (tree type)
return TYPE_MIN_VALUE (m2tree_skip_type_decl (type));
}
-static
+static
tree
do_max_real (tree type)
{
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);
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)
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. */
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;
}
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. */
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
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;
}
= 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)
BuildSetConstructorElement - adds, value, to the constructor_element_list.
*)
-PROCEDURE BuildSetConstructorElement (p: Constructor; value: tree) ;
+PROCEDURE BuildSetConstructorElement (location: location_t; p: Constructor; value: tree) ;
(*
(*
- RealToTree - convert a real number into a Tree.
+ RealToTree - convert a real number into a tree.
*)
PROCEDURE RealToTree (name: CharStar) : 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 ;
(*
PROCEDURE IsGccStrictTypeEquivalent (left, right: tree) : BOOLEAN ;
+(*
+ GetBooleanEnumList - return a list containing boolean fields true and false.
+*)
+
+PROCEDURE GetBooleanEnumList (location: location_t) : tree ;
+
+
END m2type.
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);
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 */
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;
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);
(* 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
*)
*)
-(* 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.
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 ;
*)
PROCEDURE TRANSFER (VAR p1: PROCESS; p2: PROCESS) ;
-VAR
- r: INTEGER ;
BEGIN
localMain (p1) ;
IF p1.context=p2.context
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)
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__)
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
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
*)
*)
-
-(* 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.
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.
--- /dev/null
+(* 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.
--- /dev/null
+(* 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.
--- /dev/null
+(* 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.
--- /dev/null
+(* 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.
*)
*)
-(* 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.
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.
(* 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 ;
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) ;
FROM Debug IMPORT Halt ;
FROM SYSTEM IMPORT ADR ;
+IMPORT M2Diagnostic ;
+
CONST
enableDeallocation = TRUE ;
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 ;
END ;
free (a)
END ;
+ M2Diagnostic.TotalHeapDecr (size) ;
a := NIL
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) ;
M2EXCEPTION
M2RTS
SysExceptions
+M2Diagnostic
StrLib
errno
termios
FIO
SFIO
StrCase
+StringConvert
bnflex
Lists
Args
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
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.
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
--- /dev/null
+/* 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[])
+{
+}
--- /dev/null
+/* 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
--- /dev/null
+/* 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}.
+ {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[])
+{
+}
--- /dev/null
+/* 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
--- /dev/null
+/* do not edit automatically generated by mc from Selective. */
+/* Selective.def provides Modula-2 with access to the select(2) primitive.
+
+Copyright (C) 2001-2024 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/>. */
+
+
+#if !defined (_Selective_H)
+# define _Selective_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 "GSYSTEM.h"
+
+# if defined (_Selective_C)
+# define EXTERN
+# else
+# define EXTERN extern
+# endif
+
+typedef void *Selective_SetOfFd;
+
+typedef void *Selective_Timeval;
+
+EXTERN int Selective_Select (unsigned int nooffds, Selective_SetOfFd readfds, Selective_SetOfFd writefds, Selective_SetOfFd exceptfds, Selective_Timeval timeout);
+EXTERN Selective_Timeval Selective_InitTime (unsigned int sec, unsigned int usec);
+EXTERN Selective_Timeval Selective_KillTime (Selective_Timeval t);
+EXTERN void Selective_GetTime (Selective_Timeval t, unsigned int *sec, unsigned int *usec);
+EXTERN void Selective_SetTime (Selective_Timeval t, unsigned int sec, unsigned int usec);
+EXTERN Selective_SetOfFd Selective_InitSet (void);
+EXTERN Selective_SetOfFd Selective_KillSet (Selective_SetOfFd s);
+EXTERN void Selective_FdZero (Selective_SetOfFd s);
+EXTERN void Selective_FdSet (int fd, Selective_SetOfFd s);
+EXTERN void Selective_FdClr (int fd, Selective_SetOfFd s);
+EXTERN bool Selective_FdIsSet (int fd, Selective_SetOfFd s);
+EXTERN int Selective_MaxFdsPlusOne (int a, int b);
+EXTERN void Selective_WriteCharRaw (int fd, char ch);
+EXTERN char Selective_ReadCharRaw (int fd);
+
+/*
+ GetTimeOfDay - fills in a record, Timeval, filled in with the
+ current system time in seconds and microseconds.
+ It returns zero (see man 3p gettimeofday)
+*/
+
+EXTERN int Selective_GetTimeOfDay (Selective_Timeval tv);
+# ifdef __cplusplus
+}
+# endif
+
+# undef EXTERN
+#endif
--- /dev/null
+/* do not edit automatically generated by mc from StringConvert. */
+/* StringConvert.mod provides functions to convert numbers to and from strings.
+
+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.
+
+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/>. */
+
+#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 <stdlib.h>
+#if defined(__cplusplus)
+# undef NULL
+# define NULL 0
+#endif
+#define _StringConvert_H
+#define _StringConvert_C
+
+# include "GSYSTEM.h"
+# include "Glibc.h"
+# include "Glibm.h"
+# include "GM2RTS.h"
+# include "GDynamicStrings.h"
+# include "Gldtoa.h"
+# include "Gdtoa.h"
+
+
+/*
+ IntegerToString - converts INTEGER, i, into a String. The field with can be specified
+ if non zero. Leading characters are defined by padding and this
+ function will prepend a + if sign is set to TRUE.
+ The base allows the caller to generate binary, octal, decimal, hexidecimal
+ numbers. The value of lower is only used when hexidecimal numbers are
+ generated and if TRUE then digits abcdef are used, and if FALSE then ABCDEF
+ are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_IntegerToString (int i, unsigned int width, char padding, bool sign, unsigned int base, bool lower);
+
+/*
+ CardinalToString - converts CARDINAL, c, into a String. The field with can be specified
+ if non zero. Leading characters are defined by padding.
+ The base allows the caller to generate binary, octal, decimal, hexidecimal
+ numbers. The value of lower is only used when hexidecimal numbers are
+ generated and if TRUE then digits abcdef are used, and if FALSE then ABCDEF
+ are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_CardinalToString (unsigned int c, unsigned int width, char padding, unsigned int base, bool lower);
+
+/*
+ StringToInteger - converts a string, s, of, base, into an INTEGER.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" int StringConvert_StringToInteger (DynamicStrings_String s, unsigned int base, bool *found);
+
+/*
+ StringToCardinal - converts a string, s, of, base, into a CARDINAL.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" unsigned int StringConvert_StringToCardinal (DynamicStrings_String s, unsigned int base, bool *found);
+
+/*
+ LongIntegerToString - converts LONGINT, i, into a String. The field with
+ can be specified if non zero. Leading characters
+ are defined by padding and this function will
+ prepend a + if sign is set to TRUE.
+ The base allows the caller to generate binary,
+ octal, decimal, hexidecimal numbers.
+ The value of lower is only used when hexidecimal
+ numbers are generated and if TRUE then digits
+ abcdef are used, and if FALSE then ABCDEF are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_LongIntegerToString (long int i, unsigned int width, char padding, bool sign, unsigned int base, bool lower);
+
+/*
+ StringToLongInteger - converts a string, s, of, base, into an LONGINT.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" long int StringConvert_StringToLongInteger (DynamicStrings_String s, unsigned int base, bool *found);
+
+/*
+ LongCardinalToString - converts LONGCARD, c, into a String. The field
+ width can be specified if non zero. Leading
+ characters are defined by padding.
+ The base allows the caller to generate binary,
+ octal, decimal, hexidecimal numbers.
+ The value of lower is only used when hexidecimal
+ numbers are generated and if TRUE then digits
+ abcdef are used, and if FALSE then ABCDEF are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_LongCardinalToString (long unsigned int c, unsigned int width, char padding, unsigned int base, bool lower);
+
+/*
+ StringToLongCardinal - converts a string, s, of, base, into a LONGCARD.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" long unsigned int StringConvert_StringToLongCardinal (DynamicStrings_String s, unsigned int base, bool *found);
+
+/*
+ ShortCardinalToString - converts SHORTCARD, c, into a String. The field
+ width can be specified if non zero. Leading
+ characters are defined by padding.
+ The base allows the caller to generate binary,
+ octal, decimal, hexidecimal numbers.
+ The value of lower is only used when hexidecimal
+ numbers are generated and if TRUE then digits
+ abcdef are used, and if FALSE then ABCDEF are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_ShortCardinalToString (short unsigned int c, unsigned int width, char padding, unsigned int base, bool lower);
+
+/*
+ StringToShortCardinal - converts a string, s, of, base, into a SHORTCARD.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" short unsigned int StringConvert_StringToShortCardinal (DynamicStrings_String s, unsigned int base, bool *found);
+
+/*
+ stoi - decimal string to INTEGER
+*/
+
+extern "C" int StringConvert_stoi (DynamicStrings_String s);
+
+/*
+ itos - integer to decimal string.
+*/
+
+extern "C" DynamicStrings_String StringConvert_itos (int i, unsigned int width, char padding, bool sign);
+
+/*
+ ctos - cardinal to decimal string.
+*/
+
+extern "C" DynamicStrings_String StringConvert_ctos (unsigned int c, unsigned int width, char padding);
+
+/*
+ stoc - decimal string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_stoc (DynamicStrings_String s);
+
+/*
+ hstoi - hexidecimal string to INTEGER
+*/
+
+extern "C" int StringConvert_hstoi (DynamicStrings_String s);
+
+/*
+ ostoi - octal string to INTEGER
+*/
+
+extern "C" int StringConvert_ostoi (DynamicStrings_String s);
+
+/*
+ bstoi - binary string to INTEGER
+*/
+
+extern "C" int StringConvert_bstoi (DynamicStrings_String s);
+
+/*
+ hstoc - hexidecimal string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_hstoc (DynamicStrings_String s);
+
+/*
+ ostoc - octal string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_ostoc (DynamicStrings_String s);
+
+/*
+ bstoc - binary string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_bstoc (DynamicStrings_String s);
+
+/*
+ StringToLongreal - returns a LONGREAL and sets found to TRUE if a legal number is seen.
+*/
+
+extern "C" long double StringConvert_StringToLongreal (DynamicStrings_String s, bool *found);
+
+/*
+ LongrealToString - converts a LONGREAL number, Real, which has,
+ TotalWidth, and FractionWidth into a string.
+ It uses decimal notation.
+
+ So for example:
+
+ LongrealToString(1.0, 4, 2) -> '1.00'
+ LongrealToString(12.3, 5, 2) -> '12.30'
+ LongrealToString(12.3, 6, 2) -> ' 12.30'
+ LongrealToString(12.3, 6, 3) -> '12.300'
+
+ if total width is too small then the fraction
+ becomes truncated.
+
+ LongrealToString(12.3, 5, 3) -> '12.30'
+
+ Positive numbers do not have a '+' prepended.
+ Negative numbers will have a '-' prepended and
+ the TotalWidth will need to be large enough
+ to contain the sign, whole number, '.' and
+ fractional components.
+*/
+
+extern "C" DynamicStrings_String StringConvert_LongrealToString (long double x, unsigned int TotalWidth, unsigned int FractionWidth);
+
+/*
+ stor - returns a REAL given a string.
+*/
+
+extern "C" double StringConvert_stor (DynamicStrings_String s);
+
+/*
+ stolr - returns a LONGREAL given a string.
+*/
+
+extern "C" long double StringConvert_stolr (DynamicStrings_String s);
+
+/*
+ ToSigFig - returns a floating point or base 10 integer
+ string which is accurate to, n, significant
+ figures. It will return a new String
+ and, s, will be destroyed.
+
+
+ So: 12.345
+
+ rounded to the following significant figures yields
+
+ 5 12.345
+ 4 12.34
+ 3 12.3
+ 2 12
+ 1 10
+*/
+
+extern "C" DynamicStrings_String StringConvert_ToSigFig (DynamicStrings_String s, unsigned int n);
+
+/*
+ ToDecimalPlaces - returns a floating point or base 10 integer
+ string which is accurate to, n, decimal
+ places. It will return a new String
+ and, s, will be destroyed.
+ Decimal places yields, n, digits after
+ the .
+
+ So: 12.345
+
+ rounded to the following decimal places yields
+
+ 5 12.34500
+ 4 12.3450
+ 3 12.345
+ 2 12.34
+ 1 12.3
+*/
+
+extern "C" DynamicStrings_String StringConvert_ToDecimalPlaces (DynamicStrings_String s, unsigned int n);
+
+/*
+ Assert - implement a simple assert.
+*/
+
+static void Assert (bool b, const char *file_, unsigned int _file_high, unsigned int line, const char *func_, unsigned int _func_high);
+
+/*
+ Max -
+*/
+
+static unsigned int Max (unsigned int a, unsigned int b);
+
+/*
+ Min -
+*/
+
+static unsigned int Min (unsigned int a, unsigned int b);
+
+/*
+ LongMin - returns the smallest LONGCARD
+*/
+
+static long unsigned int LongMin (long unsigned int a, long unsigned int b);
+
+/*
+ IsDigit - returns TRUE if, ch, lies between '0'..'9'.
+*/
+
+static bool IsDigit (char ch);
+
+/*
+ IsDecimalDigitValid - returns the TRUE if, ch, is a base legal decimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsDecimalDigitValid (char ch, unsigned int base, unsigned int *c);
+
+/*
+ IsHexidecimalDigitValid - returns the TRUE if, ch, is a base legal hexidecimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsHexidecimalDigitValid (char ch, unsigned int base, unsigned int *c);
+
+/*
+ IsDecimalDigitValidLong - returns the TRUE if, ch, is a base legal decimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsDecimalDigitValidLong (char ch, unsigned int base, long unsigned int *c);
+
+/*
+ IsHexidecimalDigitValidLong - returns the TRUE if, ch, is a base legal hexidecimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsHexidecimalDigitValidLong (char ch, unsigned int base, long unsigned int *c);
+
+/*
+ IsDecimalDigitValidShort - returns the TRUE if, ch, is a base legal decimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsDecimalDigitValidShort (char ch, unsigned int base, short unsigned int *c);
+
+/*
+ IsHexidecimalDigitValidShort - returns the TRUE if, ch, is a base legal hexidecimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsHexidecimalDigitValidShort (char ch, unsigned int base, short unsigned int *c);
+
+/*
+ ToThePower10 - returns a LONGREAL containing the value of v * 10^power.
+*/
+
+static long double ToThePower10 (long double v, int power);
+
+/*
+ DetermineSafeTruncation - we wish to use TRUNC when converting REAL/LONGREAL
+ into a string for the non fractional component.
+ However we need a simple method to
+ determine the maximum safe truncation value.
+*/
+
+static unsigned int DetermineSafeTruncation (void);
+
+/*
+ rtos -
+*/
+
+static DynamicStrings_String rtos (double r, unsigned int TotalWidth, unsigned int FractionWidth);
+
+/*
+ lrtos -
+*/
+
+static DynamicStrings_String lrtos (long double r, unsigned int TotalWidth, unsigned int FractionWidth);
+
+/*
+ doDecimalPlaces - returns a string which is accurate to
+ n decimal places. It returns a new String
+ and, s, will be destroyed.
+*/
+
+static DynamicStrings_String doDecimalPlaces (DynamicStrings_String s, unsigned int n);
+
+/*
+ doSigFig - returns a string which is accurate to
+ n decimal places. It returns a new String
+ and, s, will be destroyed.
+*/
+
+static DynamicStrings_String doSigFig (DynamicStrings_String s, unsigned int n);
+
+/*
+ carryOne - add a carry at position, i.
+*/
+
+static DynamicStrings_String carryOne (DynamicStrings_String s, unsigned int i);
+
+
+/*
+ Assert - implement a simple assert.
+*/
+
+static void Assert (bool b, const char *file_, unsigned int _file_high, unsigned int line, const char *func_, unsigned int _func_high)
+{
+ char file[_file_high+1];
+ char func[_func_high+1];
+
+ /* make a local copy of each unbounded array. */
+ memcpy (file, file_, _file_high+1);
+ memcpy (func, func_, _func_high+1);
+
+ if (! b)
+ {
+ M2RTS_ErrorMessage ((const char *) "assert failed", 13, (const char *) file, _file_high, line, (const char *) func, _func_high);
+ }
+}
+
+
+/*
+ Max -
+*/
+
+static unsigned int Max (unsigned int a, unsigned int b)
+{
+ if (a > b)
+ {
+ return a;
+ }
+ else
+ {
+ return b;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ Min -
+*/
+
+static unsigned int Min (unsigned int a, unsigned int b)
+{
+ if (a < b)
+ {
+ return a;
+ }
+ else
+ {
+ return b;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ LongMin - returns the smallest LONGCARD
+*/
+
+static long unsigned int LongMin (long unsigned int a, long unsigned int b)
+{
+ if (a < b)
+ {
+ return a;
+ }
+ else
+ {
+ return b;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsDigit - returns TRUE if, ch, lies between '0'..'9'.
+*/
+
+static bool IsDigit (char ch)
+{
+ return (ch >= '0') && (ch <= '9');
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsDecimalDigitValid - returns the TRUE if, ch, is a base legal decimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsDecimalDigitValid (char ch, unsigned int base, unsigned int *c)
+{
+ if ((IsDigit (ch)) && (( ((unsigned int) (ch))- ((unsigned int) ('0'))) < base))
+ {
+ (*c) = ((*c)*base)+( ((unsigned int) (ch))- ((unsigned int) ('0')));
+ return true;
+ }
+ else
+ {
+ return false;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsHexidecimalDigitValid - returns the TRUE if, ch, is a base legal hexidecimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsHexidecimalDigitValid (char ch, unsigned int base, unsigned int *c)
+{
+ if (((ch >= 'a') && (ch <= 'f')) && ((( ((unsigned int) (ch))- ((unsigned int) ('a')))+10) < base))
+ {
+ (*c) = ((*c)*base)+(( ((unsigned int) (ch))- ((unsigned int) ('a')))+10);
+ return true;
+ }
+ else if (((ch >= 'A') && (ch <= 'F')) && ((( ((unsigned int) (ch))- ((unsigned int) ('F')))+10) < base))
+ {
+ /* avoid dangling else. */
+ (*c) = ((*c)*base)+(( ((unsigned int) (ch))- ((unsigned int) ('A')))+10);
+ return true;
+ }
+ else
+ {
+ /* avoid dangling else. */
+ return false;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsDecimalDigitValidLong - returns the TRUE if, ch, is a base legal decimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsDecimalDigitValidLong (char ch, unsigned int base, long unsigned int *c)
+{
+ if ((IsDigit (ch)) && (( ((unsigned int) (ch))- ((unsigned int) ('0'))) < base))
+ {
+ (*c) = (*c)*((long unsigned int ) (base+( ((unsigned int) (ch))- ((unsigned int) ('0')))));
+ return true;
+ }
+ else
+ {
+ return false;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsHexidecimalDigitValidLong - returns the TRUE if, ch, is a base legal hexidecimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsHexidecimalDigitValidLong (char ch, unsigned int base, long unsigned int *c)
+{
+ if (((ch >= 'a') && (ch <= 'f')) && ((( ((unsigned int) (ch))- ((unsigned int) ('a')))+10) < base))
+ {
+ (*c) = (*c)*((long unsigned int ) (base+(( ((unsigned int) (ch))- ((unsigned int) ('a')))+10)));
+ return true;
+ }
+ else if (((ch >= 'A') && (ch <= 'F')) && ((( ((unsigned int) (ch))- ((unsigned int) ('F')))+10) < base))
+ {
+ /* avoid dangling else. */
+ (*c) = (*c)*((long unsigned int ) (base+(( ((unsigned int) (ch))- ((unsigned int) ('A')))+10)));
+ return true;
+ }
+ else
+ {
+ /* avoid dangling else. */
+ return false;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsDecimalDigitValidShort - returns the TRUE if, ch, is a base legal decimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsDecimalDigitValidShort (char ch, unsigned int base, short unsigned int *c)
+{
+ if ((IsDigit (ch)) && (( ((unsigned int) (ch))- ((unsigned int) ('0'))) < base))
+ {
+ (*c) = (*c)*((short unsigned int ) (base+( ((unsigned int) (ch))- ((unsigned int) ('0')))));
+ return true;
+ }
+ else
+ {
+ return false;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IsHexidecimalDigitValidShort - returns the TRUE if, ch, is a base legal hexidecimal digit.
+ If legal then the value is appended numerically onto, c.
+*/
+
+static bool IsHexidecimalDigitValidShort (char ch, unsigned int base, short unsigned int *c)
+{
+ if (((ch >= 'a') && (ch <= 'f')) && ((( ((unsigned int) (ch))- ((unsigned int) ('a')))+10) < base))
+ {
+ (*c) = (*c)*((short unsigned int ) (base+(( ((unsigned int) (ch))- ((unsigned int) ('a')))+10)));
+ return true;
+ }
+ else if (((ch >= 'A') && (ch <= 'F')) && ((( ((unsigned int) (ch))- ((unsigned int) ('F')))+10) < base))
+ {
+ /* avoid dangling else. */
+ (*c) = (*c)*((short unsigned int ) (base+(( ((unsigned int) (ch))- ((unsigned int) ('A')))+10)));
+ return true;
+ }
+ else
+ {
+ /* avoid dangling else. */
+ return false;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ToThePower10 - returns a LONGREAL containing the value of v * 10^power.
+*/
+
+static long double ToThePower10 (long double v, int power)
+{
+ int i;
+
+ i = 0;
+ if (power > 0)
+ {
+ while (i < power)
+ {
+ v = v*10.0;
+ i += 1;
+ }
+ }
+ else
+ {
+ while (i > power)
+ {
+ v = v/10.0;
+ i -= 1;
+ }
+ }
+ return v;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ DetermineSafeTruncation - we wish to use TRUNC when converting REAL/LONGREAL
+ into a string for the non fractional component.
+ However we need a simple method to
+ determine the maximum safe truncation value.
+*/
+
+static unsigned int DetermineSafeTruncation (void)
+{
+ double MaxPowerOfTen;
+ unsigned int LogPower;
+
+ MaxPowerOfTen = static_cast<double> (1.0);
+ LogPower = 0;
+ while ((MaxPowerOfTen*10.0) < ((double) ((INT_MAX) / 10)))
+ {
+ MaxPowerOfTen = MaxPowerOfTen*10.0;
+ LogPower += 1;
+ }
+ return LogPower;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ rtos -
+*/
+
+static DynamicStrings_String rtos (double r, unsigned int TotalWidth, unsigned int FractionWidth)
+{
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ lrtos -
+*/
+
+static DynamicStrings_String lrtos (long double r, unsigned int TotalWidth, unsigned int FractionWidth)
+{
+ M2RTS_HALT (-1);
+ __builtin_unreachable ();
+ return static_cast<DynamicStrings_String> (NULL);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ doDecimalPlaces - returns a string which is accurate to
+ n decimal places. It returns a new String
+ and, s, will be destroyed.
+*/
+
+static DynamicStrings_String doDecimalPlaces (DynamicStrings_String s, unsigned int n)
+{
+ int i;
+ int l;
+ int point;
+ DynamicStrings_String t;
+ DynamicStrings_String tenths;
+ DynamicStrings_String hundreths;
+
+ l = DynamicStrings_Length (s);
+ i = 0;
+ /* remove '.' */
+ point = DynamicStrings_Index (s, '.', 0);
+ if (point == 0)
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 1, 0);
+ }
+ else if (point < l)
+ {
+ /* avoid dangling else. */
+ s = DynamicStrings_ConCat (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), point+1, 0)));
+ }
+ else
+ {
+ /* avoid dangling else. */
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point);
+ }
+ l = DynamicStrings_Length (s);
+ i = 0;
+ if (l > 0)
+ {
+ /* skip over leading zeros */
+ while ((i < l) && ((DynamicStrings_char (s, i)) == '0'))
+ {
+ i += 1;
+ }
+ /* was the string full of zeros? */
+ if ((i == l) && ((DynamicStrings_char (s, i-1)) == '0'))
+ {
+ s = DynamicStrings_KillString (s);
+ s = DynamicStrings_ConCat (DynamicStrings_InitString ((const char *) "0.", 2), DynamicStrings_Mark (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), n)));
+ return s;
+ }
+ }
+ /* insert leading zero */
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('0'), DynamicStrings_Mark (s));
+ point += 1; /* and move point position to correct place */
+ l = DynamicStrings_Length (s); /* update new length */
+ i = point; /* update new length */
+ while ((n > 1) && (i < l))
+ {
+ n -= 1;
+ i += 1;
+ }
+ if ((i+3) <= l)
+ {
+ t = DynamicStrings_Dup (s);
+ hundreths = DynamicStrings_Slice (DynamicStrings_Mark (s), i+1, i+3);
+ s = t;
+ if ((StringConvert_stoc (hundreths)) >= 50)
+ {
+ s = carryOne (DynamicStrings_Mark (s), static_cast<unsigned int> (i));
+ }
+ hundreths = DynamicStrings_KillString (hundreths);
+ }
+ else if ((i+2) <= l)
+ {
+ /* avoid dangling else. */
+ t = DynamicStrings_Dup (s);
+ tenths = DynamicStrings_Slice (DynamicStrings_Mark (s), i+1, i+2);
+ s = t;
+ if ((StringConvert_stoc (tenths)) >= 5)
+ {
+ s = carryOne (DynamicStrings_Mark (s), static_cast<unsigned int> (i));
+ }
+ tenths = DynamicStrings_KillString (tenths);
+ }
+ /* check whether we need to remove the leading zero */
+ if ((DynamicStrings_char (s, 0)) == '0')
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 1, 0);
+ l -= 1;
+ point -= 1;
+ }
+ if (i < l)
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 0, i);
+ l = DynamicStrings_Length (s);
+ if (l < point)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), static_cast<unsigned int> (point-l)));
+ }
+ }
+ /* re-insert the point */
+ if (point >= 0)
+ {
+ /* avoid gcc warning by using compound statement even if not strictly necessary. */
+ if (point == 0)
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('.'), DynamicStrings_Mark (s));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCatChar (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point), '.'), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), point, 0)));
+ }
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ doSigFig - returns a string which is accurate to
+ n decimal places. It returns a new String
+ and, s, will be destroyed.
+*/
+
+static DynamicStrings_String doSigFig (DynamicStrings_String s, unsigned int n)
+{
+ int i;
+ int l;
+ int z;
+ int point;
+ DynamicStrings_String t;
+ DynamicStrings_String tenths;
+ DynamicStrings_String hundreths;
+
+ l = DynamicStrings_Length (s);
+ i = 0;
+ /* remove '.' */
+ point = DynamicStrings_Index (s, '.', 0);
+ if (point >= 0)
+ {
+ if (point == 0)
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 1, 0);
+ }
+ else if (point < l)
+ {
+ /* avoid dangling else. */
+ s = DynamicStrings_ConCat (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), point+1, 0)));
+ }
+ else
+ {
+ /* avoid dangling else. */
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point);
+ }
+ }
+ else
+ {
+ s = DynamicStrings_Dup (DynamicStrings_Mark (s));
+ }
+ l = DynamicStrings_Length (s);
+ i = 0;
+ if (l > 0)
+ {
+ /* skip over leading zeros */
+ while ((i < l) && ((DynamicStrings_char (s, i)) == '0'))
+ {
+ i += 1;
+ }
+ /* was the string full of zeros? */
+ if ((i == l) && ((DynamicStrings_char (s, i-1)) == '0'))
+ {
+ /* truncate string */
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 0, static_cast<int> (n));
+ i = n;
+ }
+ }
+ /* add a leading zero in case we need to overflow the carry */
+ z = i; /* remember where we inserted zero */
+ if (z == 0) /* remember where we inserted zero */
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('0'), DynamicStrings_Mark (s));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCatChar (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, i), '0'), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), i, 0)));
+ }
+ n += 1; /* and increase the number of sig figs needed */
+ l = DynamicStrings_Length (s); /* and increase the number of sig figs needed */
+ while ((n > 1) && (i < l))
+ {
+ n -= 1;
+ i += 1;
+ }
+ if ((i+3) <= l)
+ {
+ t = DynamicStrings_Dup (s);
+ hundreths = DynamicStrings_Slice (DynamicStrings_Mark (s), i+1, i+3);
+ s = t;
+ if ((StringConvert_stoc (hundreths)) >= 50)
+ {
+ s = carryOne (DynamicStrings_Mark (s), static_cast<unsigned int> (i));
+ }
+ hundreths = DynamicStrings_KillString (hundreths);
+ }
+ else if ((i+2) <= l)
+ {
+ /* avoid dangling else. */
+ t = DynamicStrings_Dup (s);
+ tenths = DynamicStrings_Slice (DynamicStrings_Mark (s), i+1, i+2);
+ s = t;
+ if ((StringConvert_stoc (tenths)) >= 5)
+ {
+ s = carryOne (DynamicStrings_Mark (s), static_cast<unsigned int> (i));
+ }
+ tenths = DynamicStrings_KillString (tenths);
+ }
+ /* check whether we need to remove the leading zero */
+ if ((DynamicStrings_char (s, z)) == '0')
+ {
+ if (z == 0)
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), z+1, 0);
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, z), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), z+1, 0)));
+ }
+ l = DynamicStrings_Length (s);
+ }
+ else
+ {
+ point += 1;
+ }
+ if (i < l)
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (s), 0, i);
+ l = DynamicStrings_Length (s);
+ if (l < point)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), static_cast<unsigned int> (point-l)));
+ }
+ }
+ /* re-insert the point */
+ if (point >= 0)
+ {
+ /* avoid gcc warning by using compound statement even if not strictly necessary. */
+ if (point == 0)
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('.'), DynamicStrings_Mark (s));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCatChar (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point), '.'), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), point, 0)));
+ }
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ carryOne - add a carry at position, i.
+*/
+
+static DynamicStrings_String carryOne (DynamicStrings_String s, unsigned int i)
+{
+ if (i >= 0)
+ {
+ if (IsDigit (DynamicStrings_char (s, static_cast<int> (i))))
+ {
+ /* avoid gcc warning by using compound statement even if not strictly necessary. */
+ if ((DynamicStrings_char (s, static_cast<int> (i))) == '9')
+ {
+ if (i == 0)
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('1'), DynamicStrings_Mark (s));
+ return s;
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCatChar (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, static_cast<int> (i)), '0'), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), static_cast<int> (i+1), 0)));
+ return carryOne (s, i-1);
+ }
+ }
+ else
+ {
+ if (i == 0)
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ( ((char) ( ((unsigned int) (DynamicStrings_char (s, static_cast<int> (i))))+1))), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), static_cast<int> (i+1), 0)));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCatChar (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, static_cast<int> (i)), ((char) ( ((unsigned int) (DynamicStrings_char (s, static_cast<int> (i))))+1))), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), static_cast<int> (i+1), 0)));
+ }
+ }
+ }
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ IntegerToString - converts INTEGER, i, into a String. The field with can be specified
+ if non zero. Leading characters are defined by padding and this
+ function will prepend a + if sign is set to TRUE.
+ The base allows the caller to generate binary, octal, decimal, hexidecimal
+ numbers. The value of lower is only used when hexidecimal numbers are
+ generated and if TRUE then digits abcdef are used, and if FALSE then ABCDEF
+ are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_IntegerToString (int i, unsigned int width, char padding, bool sign, unsigned int base, bool lower)
+{
+ DynamicStrings_String s;
+ unsigned int c;
+
+ if (i < 0)
+ {
+ if (i == (INT_MIN))
+ {
+ /* remember that -15 MOD 4 = 1 in Modula-2 */
+ c = ((unsigned int ) (abs (i+1)))+1;
+ if (width > 0)
+ {
+ return DynamicStrings_ConCat (StringConvert_IntegerToString (-((int ) (c / base)), width-1, padding, sign, base, lower), DynamicStrings_Mark (StringConvert_IntegerToString (static_cast<int> (c % base), 0, ' ', false, base, lower)));
+ }
+ else
+ {
+ return DynamicStrings_ConCat (StringConvert_IntegerToString (-((int ) (c / base)), 0, padding, sign, base, lower), DynamicStrings_Mark (StringConvert_IntegerToString (static_cast<int> (c % base), 0, ' ', false, base, lower)));
+ }
+ }
+ else
+ {
+ s = DynamicStrings_InitString ((const char *) "-", 1);
+ }
+ i = -i;
+ }
+ else
+ {
+ if (sign)
+ {
+ s = DynamicStrings_InitString ((const char *) "+", 1);
+ }
+ else
+ {
+ s = DynamicStrings_InitString ((const char *) "", 0);
+ }
+ }
+ if (i > (((int ) (base))-1))
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCat (s, DynamicStrings_Mark (StringConvert_IntegerToString (static_cast<int> (((unsigned int ) (i)) / base), 0, ' ', false, base, lower))), DynamicStrings_Mark (StringConvert_IntegerToString (static_cast<int> (((unsigned int ) (i)) % base), 0, ' ', false, base, lower)));
+ }
+ else
+ {
+ if (i <= 9)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) (((unsigned int ) (i))+ ((unsigned int) ('0')))))));
+ }
+ else
+ {
+ if (lower)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (i))+ ((unsigned int) ('a')))-10)))));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (i))+ ((unsigned int) ('A')))-10)))));
+ }
+ }
+ }
+ if (width > (DynamicStrings_Length (s)))
+ {
+ return DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar (padding)), width-(DynamicStrings_Length (s))), DynamicStrings_Mark (s));
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ CardinalToString - converts CARDINAL, c, into a String. The field with can be specified
+ if non zero. Leading characters are defined by padding.
+ The base allows the caller to generate binary, octal, decimal, hexidecimal
+ numbers. The value of lower is only used when hexidecimal numbers are
+ generated and if TRUE then digits abcdef are used, and if FALSE then ABCDEF
+ are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_CardinalToString (unsigned int c, unsigned int width, char padding, unsigned int base, bool lower)
+{
+ DynamicStrings_String s;
+
+ s = DynamicStrings_InitString ((const char *) "", 0);
+ if (c > (base-1))
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCat (s, DynamicStrings_Mark (StringConvert_CardinalToString (c / base, 0, ' ', base, lower))), DynamicStrings_Mark (StringConvert_CardinalToString (c % base, 0, ' ', base, lower)));
+ }
+ else
+ {
+ if (c <= 9)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) (c+ ((unsigned int) ('0')))))));
+ }
+ else
+ {
+ if (lower)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) ((c+ ((unsigned int) ('a')))-10)))));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) ((c+ ((unsigned int) ('A')))-10)))));
+ }
+ }
+ }
+ if (width > (DynamicStrings_Length (s)))
+ {
+ return DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar (padding)), width-(DynamicStrings_Length (s))), s);
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ StringToInteger - converts a string, s, of, base, into an INTEGER.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" int StringConvert_StringToInteger (DynamicStrings_String s, unsigned int base, bool *found)
+{
+ unsigned int n;
+ unsigned int l;
+ unsigned int c;
+ bool negative;
+
+ s = DynamicStrings_RemoveWhitePrefix (s); /* returns a new string, s */
+ l = DynamicStrings_Length (s); /* returns a new string, s */
+ c = 0;
+ n = 0;
+ negative = false;
+ if (n < l)
+ {
+ /* parse leading + and - */
+ while (((DynamicStrings_char (s, static_cast<int> (n))) == '-') || ((DynamicStrings_char (s, static_cast<int> (n))) == '+'))
+ {
+ if ((DynamicStrings_char (s, static_cast<int> (n))) == '-')
+ {
+ negative = ! negative;
+ }
+ n += 1;
+ }
+ while ((n < l) && ((IsDecimalDigitValid (DynamicStrings_char (s, static_cast<int> (n)), base, &c)) || (IsHexidecimalDigitValid (DynamicStrings_char (s, static_cast<int> (n)), base, &c))))
+ {
+ (*found) = true;
+ n += 1;
+ }
+ }
+ s = DynamicStrings_KillString (s);
+ if (negative)
+ {
+ return -((int ) (Min (((unsigned int ) (INT_MAX))+1, c)));
+ }
+ else
+ {
+ return (int ) (Min (static_cast<unsigned int> (INT_MAX), c));
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ StringToCardinal - converts a string, s, of, base, into a CARDINAL.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" unsigned int StringConvert_StringToCardinal (DynamicStrings_String s, unsigned int base, bool *found)
+{
+ unsigned int n;
+ unsigned int l;
+ unsigned int c;
+
+ s = DynamicStrings_RemoveWhitePrefix (s); /* returns a new string, s */
+ l = DynamicStrings_Length (s); /* returns a new string, s */
+ c = 0;
+ n = 0;
+ if (n < l)
+ {
+ /* parse leading + */
+ while ((DynamicStrings_char (s, static_cast<int> (n))) == '+')
+ {
+ n += 1;
+ }
+ while ((n < l) && ((IsDecimalDigitValid (DynamicStrings_char (s, static_cast<int> (n)), base, &c)) || (IsHexidecimalDigitValid (DynamicStrings_char (s, static_cast<int> (n)), base, &c))))
+ {
+ (*found) = true;
+ n += 1;
+ }
+ }
+ s = DynamicStrings_KillString (s);
+ return c;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ LongIntegerToString - converts LONGINT, i, into a String. The field with
+ can be specified if non zero. Leading characters
+ are defined by padding and this function will
+ prepend a + if sign is set to TRUE.
+ The base allows the caller to generate binary,
+ octal, decimal, hexidecimal numbers.
+ The value of lower is only used when hexidecimal
+ numbers are generated and if TRUE then digits
+ abcdef are used, and if FALSE then ABCDEF are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_LongIntegerToString (long int i, unsigned int width, char padding, bool sign, unsigned int base, bool lower)
+{
+ DynamicStrings_String s;
+ long unsigned int c;
+
+ if (i < 0)
+ {
+ if (i == (LONG_MIN))
+ {
+ /* remember that -15 MOD 4 is 1 in Modula-2, and although ABS(MIN(LONGINT)+1)
+ is very likely MAX(LONGINT), it is safer not to assume this is the case */
+ c = ((long unsigned int ) (labs (i+1)))+1;
+ if (width > 0)
+ {
+ return DynamicStrings_ConCat (StringConvert_LongIntegerToString (-((long int ) (c / ((long unsigned int ) (base)))), width-1, padding, sign, base, lower), DynamicStrings_Mark (StringConvert_LongIntegerToString (static_cast<long int> (c % ((long unsigned int ) (base))), 0, ' ', false, base, lower)));
+ }
+ else
+ {
+ return DynamicStrings_ConCat (StringConvert_LongIntegerToString (-((long int ) (c / ((long unsigned int ) (base)))), 0, padding, sign, base, lower), DynamicStrings_Mark (StringConvert_LongIntegerToString (static_cast<long int> (c % ((long unsigned int ) (base))), 0, ' ', false, base, lower)));
+ }
+ }
+ else
+ {
+ s = DynamicStrings_InitString ((const char *) "-", 1);
+ }
+ i = -i;
+ }
+ else
+ {
+ if (sign)
+ {
+ s = DynamicStrings_InitString ((const char *) "+", 1);
+ }
+ else
+ {
+ s = DynamicStrings_InitString ((const char *) "", 0);
+ }
+ }
+ if (i > ((long int ) (base-1)))
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCat (s, DynamicStrings_Mark (StringConvert_LongIntegerToString (i / ((long int ) (base)), 0, ' ', false, base, lower))), DynamicStrings_Mark (StringConvert_LongIntegerToString (i % ((long int ) (base)), 0, ' ', false, base, lower)));
+ }
+ else
+ {
+ if (i <= 9)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) (((unsigned int ) (i))+ ((unsigned int) ('0')))))));
+ }
+ else
+ {
+ if (lower)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (i))+ ((unsigned int) ('a')))-10)))));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (i))+ ((unsigned int) ('A')))-10)))));
+ }
+ }
+ }
+ if (width > (DynamicStrings_Length (s)))
+ {
+ return DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar (padding)), width-(DynamicStrings_Length (s))), s);
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ StringToLongInteger - converts a string, s, of, base, into an LONGINT.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" long int StringConvert_StringToLongInteger (DynamicStrings_String s, unsigned int base, bool *found)
+{
+ unsigned int n;
+ unsigned int l;
+ long unsigned int c;
+ bool negative;
+
+ s = DynamicStrings_RemoveWhitePrefix (s); /* returns a new string, s */
+ l = DynamicStrings_Length (s); /* returns a new string, s */
+ c = 0;
+ n = 0;
+ negative = false;
+ if (n < l)
+ {
+ /* parse leading + and - */
+ while (((DynamicStrings_char (s, static_cast<int> (n))) == '-') || ((DynamicStrings_char (s, static_cast<int> (n))) == '+'))
+ {
+ if ((DynamicStrings_char (s, static_cast<int> (n))) == '-')
+ {
+ negative = ! negative;
+ }
+ n += 1;
+ }
+ while ((n < l) && ((IsDecimalDigitValidLong (DynamicStrings_char (s, static_cast<int> (n)), base, &c)) || (IsHexidecimalDigitValidLong (DynamicStrings_char (s, static_cast<int> (n)), base, &c))))
+ {
+ (*found) = true;
+ n += 1;
+ }
+ }
+ s = DynamicStrings_KillString (s);
+ if (negative)
+ {
+ return -((long int ) (LongMin (((long unsigned int ) (LONG_MAX))+1, c)));
+ }
+ else
+ {
+ return (long int ) (LongMin (static_cast<long unsigned int> (LONG_MAX), c));
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ LongCardinalToString - converts LONGCARD, c, into a String. The field
+ width can be specified if non zero. Leading
+ characters are defined by padding.
+ The base allows the caller to generate binary,
+ octal, decimal, hexidecimal numbers.
+ The value of lower is only used when hexidecimal
+ numbers are generated and if TRUE then digits
+ abcdef are used, and if FALSE then ABCDEF are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_LongCardinalToString (long unsigned int c, unsigned int width, char padding, unsigned int base, bool lower)
+{
+ DynamicStrings_String s;
+
+ s = DynamicStrings_InitString ((const char *) "", 0);
+ if (c > ((long unsigned int ) (base-1)))
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCat (s, StringConvert_LongCardinalToString (c / ((long unsigned int ) (base)), 0, ' ', base, lower)), StringConvert_LongCardinalToString (c % ((long unsigned int ) (base)), 0, ' ', base, lower));
+ }
+ else
+ {
+ if (c <= 9)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_InitStringChar ( ((char) (((unsigned int ) (c))+ ((unsigned int) ('0'))))));
+ }
+ else
+ {
+ if (lower)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (c))+ ((unsigned int) ('a')))-10))));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (c))+ ((unsigned int) ('A')))-10))));
+ }
+ }
+ }
+ if (width > (DynamicStrings_Length (s)))
+ {
+ return DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar (padding)), width-(DynamicStrings_Length (s))), s);
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ StringToLongCardinal - converts a string, s, of, base, into a LONGCARD.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" long unsigned int StringConvert_StringToLongCardinal (DynamicStrings_String s, unsigned int base, bool *found)
+{
+ unsigned int n;
+ unsigned int l;
+ long unsigned int c;
+
+ s = DynamicStrings_RemoveWhitePrefix (s); /* returns a new string, s */
+ l = DynamicStrings_Length (s); /* returns a new string, s */
+ c = 0;
+ n = 0;
+ if (n < l)
+ {
+ /* parse leading + */
+ while ((DynamicStrings_char (s, static_cast<int> (n))) == '+')
+ {
+ n += 1;
+ }
+ while ((n < l) && ((IsDecimalDigitValidLong (DynamicStrings_char (s, static_cast<int> (n)), base, &c)) || (IsHexidecimalDigitValidLong (DynamicStrings_char (s, static_cast<int> (n)), base, &c))))
+ {
+ (*found) = true;
+ n += 1;
+ }
+ }
+ s = DynamicStrings_KillString (s);
+ return c;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ShortCardinalToString - converts SHORTCARD, c, into a String. The field
+ width can be specified if non zero. Leading
+ characters are defined by padding.
+ The base allows the caller to generate binary,
+ octal, decimal, hexidecimal numbers.
+ The value of lower is only used when hexidecimal
+ numbers are generated and if TRUE then digits
+ abcdef are used, and if FALSE then ABCDEF are used.
+*/
+
+extern "C" DynamicStrings_String StringConvert_ShortCardinalToString (short unsigned int c, unsigned int width, char padding, unsigned int base, bool lower)
+{
+ DynamicStrings_String s;
+
+ s = DynamicStrings_InitString ((const char *) "", 0);
+ if (((unsigned int ) (c)) > (base-1))
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCat (s, StringConvert_ShortCardinalToString (c / ((short unsigned int ) (base)), 0, ' ', base, lower)), StringConvert_ShortCardinalToString (c % ((short unsigned int ) (base)), 0, ' ', base, lower));
+ }
+ else
+ {
+ if (c <= 9)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_InitStringChar ( ((char) (((unsigned int ) (c))+ ((unsigned int) ('0'))))));
+ }
+ else
+ {
+ if (lower)
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (c))+ ((unsigned int) ('a')))-10))));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_InitStringChar ( ((char) ((((unsigned int ) (c))+ ((unsigned int) ('A')))-10))));
+ }
+ }
+ }
+ if (width > (DynamicStrings_Length (s)))
+ {
+ return DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar (padding)), width-(DynamicStrings_Length (s))), s);
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ StringToShortCardinal - converts a string, s, of, base, into a SHORTCARD.
+ Leading white space is ignored. It stops converting
+ when either the string is exhausted or if an illegal
+ numeral is found.
+ The parameter found is set TRUE if a number was found.
+*/
+
+extern "C" short unsigned int StringConvert_StringToShortCardinal (DynamicStrings_String s, unsigned int base, bool *found)
+{
+ unsigned int n;
+ unsigned int l;
+ short unsigned int c;
+
+ s = DynamicStrings_RemoveWhitePrefix (s); /* returns a new string, s */
+ l = DynamicStrings_Length (s); /* returns a new string, s */
+ c = 0;
+ n = 0;
+ if (n < l)
+ {
+ /* parse leading + */
+ while ((DynamicStrings_char (s, static_cast<int> (n))) == '+')
+ {
+ n += 1;
+ }
+ while ((n < l) && ((IsDecimalDigitValidShort (DynamicStrings_char (s, static_cast<int> (n)), base, &c)) || (IsHexidecimalDigitValidShort (DynamicStrings_char (s, static_cast<int> (n)), base, &c))))
+ {
+ (*found) = true;
+ n += 1;
+ }
+ }
+ s = DynamicStrings_KillString (s);
+ return c;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ stoi - decimal string to INTEGER
+*/
+
+extern "C" int StringConvert_stoi (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToInteger (s, 10, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ itos - integer to decimal string.
+*/
+
+extern "C" DynamicStrings_String StringConvert_itos (int i, unsigned int width, char padding, bool sign)
+{
+ return StringConvert_IntegerToString (i, width, padding, sign, 10, false);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ctos - cardinal to decimal string.
+*/
+
+extern "C" DynamicStrings_String StringConvert_ctos (unsigned int c, unsigned int width, char padding)
+{
+ return StringConvert_CardinalToString (c, width, padding, 10, false);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ stoc - decimal string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_stoc (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToCardinal (s, 10, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ hstoi - hexidecimal string to INTEGER
+*/
+
+extern "C" int StringConvert_hstoi (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToInteger (s, 16, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ostoi - octal string to INTEGER
+*/
+
+extern "C" int StringConvert_ostoi (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToInteger (s, 8, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ bstoi - binary string to INTEGER
+*/
+
+extern "C" int StringConvert_bstoi (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToInteger (s, 2, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ hstoc - hexidecimal string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_hstoc (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToCardinal (s, 16, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ostoc - octal string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_ostoc (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToCardinal (s, 8, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ bstoc - binary string to CARDINAL
+*/
+
+extern "C" unsigned int StringConvert_bstoc (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToCardinal (s, 2, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ StringToLongreal - returns a LONGREAL and sets found to TRUE if a legal number is seen.
+*/
+
+extern "C" long double StringConvert_StringToLongreal (DynamicStrings_String s, bool *found)
+{
+ bool error;
+ long double value;
+
+ s = DynamicStrings_RemoveWhitePrefix (s); /* new string is created */
+ value = ldtoa_strtold (DynamicStrings_string (s), &error); /* new string is created */
+ s = DynamicStrings_KillString (s);
+ (*found) = ! error;
+ return value;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ LongrealToString - converts a LONGREAL number, Real, which has,
+ TotalWidth, and FractionWidth into a string.
+ It uses decimal notation.
+
+ So for example:
+
+ LongrealToString(1.0, 4, 2) -> '1.00'
+ LongrealToString(12.3, 5, 2) -> '12.30'
+ LongrealToString(12.3, 6, 2) -> ' 12.30'
+ LongrealToString(12.3, 6, 3) -> '12.300'
+
+ if total width is too small then the fraction
+ becomes truncated.
+
+ LongrealToString(12.3, 5, 3) -> '12.30'
+
+ Positive numbers do not have a '+' prepended.
+ Negative numbers will have a '-' prepended and
+ the TotalWidth will need to be large enough
+ to contain the sign, whole number, '.' and
+ fractional components.
+*/
+
+extern "C" DynamicStrings_String StringConvert_LongrealToString (long double x, unsigned int TotalWidth, unsigned int FractionWidth)
+{
+ bool maxprecision;
+ DynamicStrings_String s;
+ void * r;
+ int point;
+ bool sign;
+ int l;
+
+ if (TotalWidth == 0)
+ {
+ maxprecision = true;
+ r = ldtoa_ldtoa (x, ldtoa_decimaldigits, 100, &point, &sign);
+ }
+ else
+ {
+ r = ldtoa_ldtoa (x, ldtoa_decimaldigits, 100, &point, &sign);
+ }
+ s = DynamicStrings_InitStringCharStar (r);
+ libc_free (r);
+ l = DynamicStrings_Length (s);
+ if (point > l)
+ {
+ /* avoid dangling else. */
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), static_cast<unsigned int> (point-l))));
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitString ((const char *) ".0", 2)));
+ if (! maxprecision && (FractionWidth > 0))
+ {
+ FractionWidth -= 1;
+ if (((int ) (FractionWidth)) > (point-l))
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitString ((const char *) "0", 1)), FractionWidth)));
+ }
+ }
+ }
+ else if (point < 0)
+ {
+ /* avoid dangling else. */
+ s = DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), static_cast<unsigned int> (-point)), DynamicStrings_Mark (s));
+ l = DynamicStrings_Length (s);
+ s = DynamicStrings_ConCat (DynamicStrings_InitString ((const char *) "0.", 2), DynamicStrings_Mark (s));
+ if (! maxprecision && (l < ((int ) (FractionWidth))))
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitString ((const char *) "0", 1)), static_cast<unsigned int> (((int ) (FractionWidth))-l))));
+ }
+ }
+ else
+ {
+ /* avoid dangling else. */
+ if (point == 0)
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_InitString ((const char *) "0.", 2), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), point, 0)));
+ }
+ else
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_ConCatChar (DynamicStrings_Slice (DynamicStrings_Mark (s), 0, point), '.'), DynamicStrings_Mark (DynamicStrings_Slice (DynamicStrings_Mark (s), point, 0)));
+ }
+ if (! maxprecision && ((l-point) < ((int ) (FractionWidth))))
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitString ((const char *) "0", 1)), static_cast<unsigned int> (((int ) (FractionWidth))-(l-point)))));
+ }
+ }
+ if ((DynamicStrings_Length (s)) > TotalWidth)
+ {
+ /* avoid gcc warning by using compound statement even if not strictly necessary. */
+ if (TotalWidth > 0)
+ {
+ if (sign)
+ {
+ s = DynamicStrings_Slice (DynamicStrings_Mark (StringConvert_ToDecimalPlaces (s, FractionWidth)), 0, static_cast<int> (TotalWidth-1));
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('-'), DynamicStrings_Mark (s));
+ sign = false;
+ }
+ else
+ {
+ /* minus 1 because all results will include a '.' */
+ s = DynamicStrings_Slice (DynamicStrings_Mark (StringConvert_ToDecimalPlaces (s, FractionWidth)), 0, static_cast<int> (TotalWidth));
+ }
+ }
+ else
+ {
+ if (sign)
+ {
+ s = StringConvert_ToDecimalPlaces (s, FractionWidth);
+ s = DynamicStrings_ConCat (DynamicStrings_InitStringChar ('-'), DynamicStrings_Mark (s));
+ sign = false;
+ }
+ else
+ {
+ /* minus 1 because all results will include a '.' */
+ s = StringConvert_ToDecimalPlaces (s, FractionWidth);
+ }
+ }
+ }
+ if ((DynamicStrings_Length (s)) < TotalWidth)
+ {
+ s = DynamicStrings_ConCat (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar (' ')), TotalWidth-(DynamicStrings_Length (s))), DynamicStrings_Mark (s));
+ }
+ return s;
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ stor - returns a REAL given a string.
+*/
+
+extern "C" double StringConvert_stor (DynamicStrings_String s)
+{
+ bool found;
+
+ return (double ) (StringConvert_StringToLongreal (s, &found));
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ stolr - returns a LONGREAL given a string.
+*/
+
+extern "C" long double StringConvert_stolr (DynamicStrings_String s)
+{
+ bool found;
+
+ return StringConvert_StringToLongreal (s, &found);
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ToSigFig - returns a floating point or base 10 integer
+ string which is accurate to, n, significant
+ figures. It will return a new String
+ and, s, will be destroyed.
+
+
+ So: 12.345
+
+ rounded to the following significant figures yields
+
+ 5 12.345
+ 4 12.34
+ 3 12.3
+ 2 12
+ 1 10
+*/
+
+extern "C" DynamicStrings_String StringConvert_ToSigFig (DynamicStrings_String s, unsigned int n)
+{
+ int point;
+ unsigned int poTen;
+
+ Assert ((IsDigit (DynamicStrings_char (s, 0))) || ((DynamicStrings_char (s, 0)) == '.'), (const char *) "../../gcc/m2/gm2-libs/StringConvert.mod", 39, 1220, (const char *) "ToSigFig", 8);
+ point = DynamicStrings_Index (s, '.', 0);
+ if (point < 0)
+ {
+ poTen = DynamicStrings_Length (s);
+ }
+ else
+ {
+ poTen = point;
+ }
+ s = doSigFig (s, n);
+ /* if the last character is '.' remove it */
+ if (((DynamicStrings_Length (s)) > 0) && ((DynamicStrings_char (s, -1)) == '.'))
+ {
+ return DynamicStrings_Slice (DynamicStrings_Mark (s), 0, -1);
+ }
+ else
+ {
+ if (poTen > (DynamicStrings_Length (s)))
+ {
+ s = DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), poTen-(DynamicStrings_Length (s)))));
+ }
+ return s;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+
+/*
+ ToDecimalPlaces - returns a floating point or base 10 integer
+ string which is accurate to, n, decimal
+ places. It will return a new String
+ and, s, will be destroyed.
+ Decimal places yields, n, digits after
+ the .
+
+ So: 12.345
+
+ rounded to the following decimal places yields
+
+ 5 12.34500
+ 4 12.3450
+ 3 12.345
+ 2 12.34
+ 1 12.3
+*/
+
+extern "C" DynamicStrings_String StringConvert_ToDecimalPlaces (DynamicStrings_String s, unsigned int n)
+{
+ int point;
+
+ Assert ((IsDigit (DynamicStrings_char (s, 0))) || ((DynamicStrings_char (s, 0)) == '.'), (const char *) "../../gcc/m2/gm2-libs/StringConvert.mod", 39, 1069, (const char *) "ToDecimalPlaces", 15);
+ point = DynamicStrings_Index (s, '.', 0);
+ if (point < 0)
+ {
+ /* avoid gcc warning by using compound statement even if not strictly necessary. */
+ if (n > 0)
+ {
+ return DynamicStrings_ConCat (DynamicStrings_ConCat (s, DynamicStrings_Mark (DynamicStrings_InitStringChar ('.'))), DynamicStrings_Mult (DynamicStrings_Mark (DynamicStrings_InitStringChar ('0')), n));
+ }
+ else
+ {
+ return s;
+ }
+ }
+ s = doDecimalPlaces (s, n);
+ /* if the last character is '.' remove it */
+ if (((DynamicStrings_Length (s)) > 0) && ((DynamicStrings_char (s, -1)) == '.'))
+ {
+ return DynamicStrings_Slice (DynamicStrings_Mark (s), 0, -1);
+ }
+ else
+ {
+ return s;
+ }
+ /* static analysis guarentees a RETURN statement will be used before here. */
+ __builtin_unreachable ();
+}
+
+extern "C" void _M2_StringConvert_init (__attribute__((unused)) int argc,__attribute__((unused)) char *argv[],__attribute__((unused)) char *envp[])
+{
+}
+
+extern "C" void _M2_StringConvert_fini (__attribute__((unused)) int argc,__attribute__((unused)) char *argv[],__attribute__((unused)) char *envp[])
+{
+}
extern "C" void _M2_M2RTS_fini (int argc, char *argv[], char *envp[]);
extern "C" void _M2_SysExceptions_init (int argc, char *argv[], char *envp[]);
extern "C" void _M2_SysExceptions_fini (int argc, char *argv[], char *envp[]);
+extern "C" void _M2_M2Diagnostic_init (int argc, char *argv[], char *envp[]);
+extern "C" void _M2_M2Diagnostic_fini (int argc, char *argv[], char *envp[]);
extern "C" void _M2_StrLib_init (int argc, char *argv[], char *envp[]);
extern "C" void _M2_StrLib_fini (int argc, char *argv[], char *envp[]);
extern "C" void _M2_errno_init (int argc, char *argv[], char *envp[]);
extern "C" void _M2_SFIO_fini (int argc, char *argv[], char *envp[]);
extern "C" void _M2_StrCase_init (int argc, char *argv[], char *envp[]);
extern "C" void _M2_StrCase_fini (int argc, char *argv[], char *envp[]);
+extern "C" void _M2_StringConvert_init (int argc, char *argv[], char *envp[]);
+extern "C" void _M2_StringConvert_fini (int argc, char *argv[], char *envp[]);
extern "C" void _M2_bnflex_init (int argc, char *argv[], char *envp[]);
extern "C" void _M2_bnflex_fini (int argc, char *argv[], char *envp[]);
extern "C" void _M2_Lists_init (int argc, char *argv[], char *envp[]);
_M2_M2EXCEPTION_init (argc, argv, envp);
_M2_M2RTS_init (argc, argv, envp);
_M2_SysExceptions_init (argc, argv, envp);
+ _M2_M2Diagnostic_init (argc, argv, envp);
_M2_StrLib_init (argc, argv, envp);
_M2_errno_init (argc, argv, envp);
_M2_termios_init (argc, argv, envp);
_M2_FIO_init (argc, argv, envp);
_M2_SFIO_init (argc, argv, envp);
_M2_StrCase_init (argc, argv, envp);
+ _M2_StringConvert_init (argc, argv, envp);
_M2_bnflex_init (argc, argv, envp);
_M2_Lists_init (argc, argv, envp);
_M2_Args_init (argc, argv, envp);
_M2_Args_fini (argc, argv, envp);
_M2_Lists_fini (argc, argv, envp);
_M2_bnflex_fini (argc, argv, envp);
+ _M2_StringConvert_fini (argc, argv, envp);
_M2_StrCase_fini (argc, argv, envp);
_M2_SFIO_fini (argc, argv, envp);
_M2_FIO_fini (argc, argv, envp);
_M2_termios_fini (argc, argv, envp);
_M2_errno_fini (argc, argv, envp);
_M2_StrLib_fini (argc, argv, envp);
+ _M2_M2Diagnostic_fini (argc, argv, envp);
_M2_SysExceptions_fini (argc, argv, envp);
_M2_M2RTS_fini (argc, argv, envp);
_M2_M2EXCEPTION_fini (argc, argv, envp);
Usage () {
- echo "Usage: makesystem dialectflag SYSTEM.def SYSTEM.mod { librarypath } compiler"
+ echo "Usage: makesystem [-gdb] dialectflag SYSTEM.def SYSTEM.mod { librarypath } compiler"
}
if [ $# -lt 6 ] ; then
exit 1
fi
+if [ "$1" = "-gdb" ] ; then
+ DEBUG=$1
+ shift
+else
+ DEBUG=""
+fi
DIALECT=$1
SYSTEMDEF=$2
SYSTEMMOD=$3
MINIMAL="-fno-scaffold-main -fno-scaffold-dynamic -fno-scaffold-static -fno-m2-plugin"
rm -f ${OUTPUTFILE}
+
+if [ "$DEBUG" != "" ] ; then
+ echo "entering gdb to debug cc1gm2 when using -fdump-system-exports"
+ ${COMPILER} ${DIALECT} ${LIBRARY} ${MINIMAL} \
+ -c -fdump-system-exports ${SYSTEMMOD} -wrapper gdb,--args
+ exit $?
+fi
+
${COMPILER} ${DIALECT} ${LIBRARY} ${MINIMAL} \
-S -fdump-system-exports ${SYSTEMMOD} -o /dev/null 2>&1 > /dev/null
res=$?
FROM StrIO IMPORT WriteString, WriteLn ;
+TYPE
+ index = CARDINAL ;
+
VAR
- c : CARDINAL ;
+ c : index ;
a, b: BITSET ;
BEGIN
- IF b IN b
+ IF c IN c
THEN
WriteString('hmm') ; WriteLn
END
--- /dev/null
+MODULE assigncons ;
+
+
+TYPE
+ rec = RECORD
+ x, y: CARDINAL ;
+ END ;
+
+CONST
+ z = rec {1, 2} ;
+
+
+PROCEDURE Init ;
+VAR
+ r: rec ;
+BEGIN
+ r := z
+END Init ;
+
+
+BEGIN
+ Init
+END assigncons.
--- /dev/null
+(* Copyright (C) 2008 Free Software Foundation, Inc. *)
+(* 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 2, 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 gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE constructor3 ;
+
+FROM libc IMPORT exit ;
+
+
+VAR
+ f: position ;
+
+TYPE
+ position = RECORD
+ x1, y1, x2, y2: CARDINAL ;
+ END ;
+
+CONST
+ first = position{1,2,3,4} ;
+
+BEGIN
+ f := first ;
+ IF (f.x1=1) AND (f.y1=2) AND (f.x2=3) AND (f.y2=4)
+ THEN
+ (* all ok *)
+ ELSE
+ exit(1)
+ END
+END constructor3.
--- /dev/null
+MODULE proc_test;
+
+ PROCEDURE Calc () : CARDINAL;
+ BEGIN
+ RETURN 2;
+ END Calc;
+
+BEGIN
+
+END proc_test.
\ No newline at end of file
MODULE shift4 ;
FROM libc IMPORT exit, printf ;
-FROM SYSTEM IMPORT SHIFT, BITSPERLOC ;
+FROM SYSTEM IMPORT SHIFT, BITSPERLOC, TBITSIZE, BYTE ;
+
+
+CONST
+ EarlyFail = TRUE ;
+ Verbose = FALSE ;
+
+
+(*
+ assert -
+*)
+
+PROCEDURE assert (condition: BOOLEAN) ;
+BEGIN
+ IF NOT condition
+ THEN
+ printf ("assert failed\n");
+ exit (1)
+ END
+END assert ;
+
+
+(*
+ SanityCheck -
+*)
+
+PROCEDURE SanityCheck ;
+BEGIN
+ assert (MIN (large) = 0) ;
+ assert (MAX (large) = 1023) ;
+ assert (TBITSIZE (BYTE) = 8) ;
+END SanityCheck ;
+
TYPE
large = SET OF [0..1023] ;
i : INTEGER ;
b, c: large ;
BEGIN
+ SanityCheck ;
r := 0 ;
b := large{1, 2, 3, 1022} ;
- b := SHIFT(b, 1) ;
+ IF b # large{1, 2, 3, 1022}
+ THEN
+ printf ("failed to assign a large set with a constant set\n");
+ exit (1)
+ END ;
+ b := SHIFT(b, 1) ; (* Shift left by 1 bit. *)
IF b#large{2, 3, 4, 1023}
THEN
+ printf ("failed (exit 1) as b#large{2, 3, 4, 1023}\n");
exit(1)
END ;
b := large{1, 2, 3, 1023} ;
- b := SHIFT(b, -1) ;
+ b := SHIFT(b, -1) ; (* Shift right by 1 bit. *)
IF b#large{0, 1, 2, 1022}
THEN
+ printf ("failed (exit 2) as b#large{1, 2, 3, 1022}\n");
exit(2)
END ;
b := large{1+SIZE(BITSET)*BITSPERLOC} ;
b := SHIFT(b, -1) ;
IF b#large{SIZE(BITSET)*BITSPERLOC}
THEN
+ printf ("failed (exit 3)\n");
exit(3)
END ;
b := SHIFT(b, -1) ;
IF b#large{SIZE(BITSET)*BITSPERLOC-1}
THEN
+ printf ("failed (exit 4)\n");
exit(4)
END ;
+
+ printf ("test left shift on byte boundaries\n");
+ FOR i := 0 TO MAX(large) BY 8 DO
+ b := large{0} ;
+ b := SHIFT(b, i) ;
+ c := large{i} ;
+ IF b # c
+ THEN
+ printf("failed shift left in loop on iteration %d, failed to shift bit 0 left by %i bits\n", i, i) ;
+ IF EarlyFail
+ THEN
+ exit (5)
+ END ;
+ r := 5
+ END
+ END ;
+ IF r = 0
+ THEN
+ printf ("test left shift on byte boundaries passed\n")
+ ELSE
+ printf ("test left shift on byte boundaries failed\n")
+ END ;
+
+ printf ("test right shift on byte boundaries\n");
+ FOR i := 0 TO MAX(large) BY 8 DO
+ b := large{i} ;
+ b := SHIFT(b, -i) ;
+ c := large{0} ;
+ IF b = c
+ THEN
+ IF Verbose
+ THEN
+ printf ("success shifted large set right by %d bits\n", i)
+ END
+ ELSE
+ printf("failed shift right in loop on iteration %d\n", i) ;
+ IF EarlyFail
+ THEN
+ exit (6)
+ END ;
+ r := 6
+ END
+ END ;
+ IF r = 0
+ THEN
+ printf ("test right shift on byte boundaries passed\n")
+ ELSE
+ printf ("test right shift on byte boundaries failed\n")
+ END ;
+
+ printf ("test shift on each bit\n");
FOR i := 0 TO MAX(large) DO
b := large{0} ;
b := SHIFT(b, i) ;
c := large{i} ;
- IF b#c
+ IF b = c
THEN
- printf("failed shift left in loop on iteration %d\n", i) ;
+ IF Verbose
+ THEN
+ printf ("success shifted large set left by %d bits\n", i)
+ END
+ ELSE
+ printf("failed shift left in loop on iteration %d, failed to shift bit 0 left by %i bits\n", i, i) ;
+ IF EarlyFail
+ THEN
+ exit (5)
+ END ;
r := 5
END
END ;
b := large{i} ;
b := SHIFT(b, -i) ;
c := large{0} ;
- IF b#c
+ IF b = c
THEN
+ IF Verbose
+ THEN
+ printf ("success shifted large set right by %d bits\n", i)
+ END
+ ELSE
printf("failed shift right in loop on iteration %d\n", i) ;
+ IF EarlyFail
+ THEN
+ exit (6)
+ END ;
r := 6
END
END ;
--- /dev/null
+(* Copyright (C) 2014 Free Software Foundation, Inc. *)
+(* 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 2, 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 gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE simplelarge2 ;
+
+FROM STextIO IMPORT WriteString, WriteLn, WriteChar, ReadToken, SkipLine ;
+FROM SWholeIO IMPORT WriteCard, WriteInt ;
+FROM WholeStr IMPORT StrToCard, ConvResults ;
+FROM SYSTEM IMPORT CARDINAL8 ;
+FROM libc IMPORT printf ;
+
+CONST
+ BoardX = 16 ;
+ BoardY = 16 ;
+ BoardSize = BoardX * BoardY ;
+
+TYPE
+ Squares = [0..BoardSize-1] ;
+ SoS = SET OF Squares ;
+ Colour = (Blue, Red, Green, White) ;
+
+VAR
+ homeBase: ARRAY [MIN(Colour)..MAX(Colour)] OF SoS ;
+
+
+PROCEDURE dumpSet (c: Colour) ;
+VAR
+ n: CARDINAL ;
+BEGIN
+ printf ("inside dumpSet (%d)\n", ORD(c)) ;
+ printf (" : 0 2 4 6 8 a c e \n") ;
+ FOR n := MIN(Squares) TO MAX(Squares) DO
+ IF n MOD 16 = 0
+ THEN
+ printf ("\nrow %2d: ", n DIV 16)
+ END ;
+ IF n IN homeBase[c]
+ THEN
+ printf ("1")
+ ELSE
+ printf ("0")
+ END
+ END ;
+ printf ("\n")
+END dumpSet ;
+
+
+(*
+ assert -
+*)
+
+PROCEDURE assert (b: BOOLEAN) ;
+BEGIN
+ IF NOT b
+ THEN
+ WriteString('assert failed') ; WriteLn ;
+ HALT
+ END
+END assert ;
+
+
+BEGIN
+ homeBase[Blue] := SoS {0, 1, 2, 3,
+ 16, 17, 18, 19,
+ 32, 33, 34,
+ 48, 49} ;
+
+ dumpSet(Blue) ;
+
+ assert (0 IN homeBase[Blue]) ;
+ assert (1 IN homeBase[Blue]) ;
+ assert (2 IN homeBase[Blue]) ;
+ assert (3 IN homeBase[Blue]) ;
+
+ homeBase[Blue] := homeBase[Blue] + SoS {4, 20, 35, 50, 65, 64} ;
+ dumpSet(Blue) ;
+
+ assert (0 IN homeBase[Blue]) ;
+ assert (1 IN homeBase[Blue]) ;
+ assert (2 IN homeBase[Blue]) ;
+ assert (3 IN homeBase[Blue]) ;
+ assert (4 IN homeBase[Blue]) ;
+ assert (NOT (5 IN homeBase[Blue])) ;
+ assert (NOT (6 IN homeBase[Blue])) ;
+END simplelarge2.
--- /dev/null
+(* Copyright (C) 2014 Free Software Foundation, Inc. *)
+(* 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 2, 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 gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE simplelarge3 ;
+
+FROM STextIO IMPORT WriteString, WriteLn, WriteChar, ReadToken, SkipLine ;
+FROM SWholeIO IMPORT WriteCard, WriteInt ;
+FROM WholeStr IMPORT StrToCard, ConvResults ;
+FROM SYSTEM IMPORT CARDINAL8 ;
+FROM libc IMPORT printf ;
+
+CONST
+ BoardX = 16 ;
+ BoardY = 16 ;
+ BoardSize = BoardX * BoardY ;
+
+TYPE
+ Squares = [0..BoardSize-1] ;
+ SoS = SET OF Squares ;
+ Colour = (Blue, Red, Green, White) ;
+
+VAR
+ homeBase: ARRAY [MIN(Colour)..MAX(Colour)] OF SoS ;
+
+
+PROCEDURE dumpSet (c: Colour) ;
+VAR
+ n: CARDINAL ;
+BEGIN
+ printf ("inside dumpSet (%d)\n", ORD(c)) ;
+ printf (" : 0 2 4 6 8 a c e \n") ;
+ FOR n := MIN(Squares) TO MAX(Squares) DO
+ IF n MOD 16 = 0
+ THEN
+ printf ("\nrow %2d: ", n DIV 16)
+ END ;
+ IF n IN homeBase[c]
+ THEN
+ printf ("1")
+ ELSE
+ printf ("0")
+ END
+ END ;
+ printf ("\n")
+END dumpSet ;
+
+
+(*
+ assert -
+*)
+
+PROCEDURE assert (b: BOOLEAN) ;
+BEGIN
+ IF NOT b
+ THEN
+ WriteString('assert failed') ; WriteLn ;
+ HALT
+ END
+END assert ;
+
+
+BEGIN
+ homeBase[Blue] := SoS {0, 1, 2, 3,
+ 16, 17, 18, 19,
+ 32, 33, 34,
+ 48, 49} ;
+
+ dumpSet(Blue) ;
+
+ homeBase[Blue] := homeBase[Blue] + SoS {4, 20, 35, 50, 65, 64} ;
+ dumpSet(Blue) ;
+
+ assert (0 IN homeBase[Blue])
+END simplelarge3.
--- /dev/null
+(* Copyright (C) 2014 Free Software Foundation, Inc. *)
+(* 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 2, 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 gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE simplelarge4 ;
+
+FROM STextIO IMPORT WriteString, WriteLn, WriteChar, ReadToken, SkipLine ;
+FROM SWholeIO IMPORT WriteCard, WriteInt ;
+FROM WholeStr IMPORT StrToCard, ConvResults ;
+FROM SYSTEM IMPORT CARDINAL8 ;
+FROM libc IMPORT printf ;
+
+CONST
+ BoardX = 16 ;
+ BoardY = 16 ;
+ BoardSize = BoardX * BoardY ;
+
+TYPE
+ Squares = [0..BoardSize-1] ;
+ SoS = SET OF Squares ;
+ Colour = (Blue, Red, Green, White) ;
+
+VAR
+ homeBase: SoS ;
+
+
+PROCEDURE dumpSet (c: Colour) ;
+VAR
+ n: CARDINAL ;
+BEGIN
+ printf ("inside dumpSet (%d)\n", ORD(c)) ;
+ printf (" : 0 2 4 6 8 a c e \n") ;
+ FOR n := MIN(Squares) TO MAX(Squares) DO
+ IF n MOD 16 = 0
+ THEN
+ printf ("\nrow %2d: ", n DIV 16)
+ END ;
+ IF n IN homeBase
+ THEN
+ printf ("1")
+ ELSE
+ printf ("0")
+ END
+ END ;
+ printf ("\n")
+END dumpSet ;
+
+
+(*
+ assert -
+*)
+
+PROCEDURE assert (b: BOOLEAN) ;
+BEGIN
+ IF NOT b
+ THEN
+ WriteString('assert failed') ; WriteLn ;
+ HALT
+ END
+END assert ;
+
+
+BEGIN
+ homeBase := SoS {0, 1, 2, 3,
+ 16, 17, 18, 19,
+ 32, 33, 34,
+ 48, 49} ;
+
+ dumpSet(Blue) ;
+
+ homeBase := homeBase + SoS {4, 20, 35, 50, 65, 64} ;
+ dumpSet(Blue) ;
+
+ assert (0 IN homeBase)
+END simplelarge4.
PROCEDURE FindFirstElement (start: CARDINAL; s: LargeSet) : CARDINAL ;
BEGIN
- WHILE NOT (start IN s) DO
+ WHILE (start < 1024) AND (NOT (start IN s)) DO
INC(start)
END ;
RETURN( start )
--- /dev/null
+MODULE bitset ;
+
+FROM libc IMPORT printf, exit ;
+FROM M2WIDESET IMPORT Equal, Clear ;
+
+TYPE
+ set = BITSET ;
+
+CONST
+ HighBit = MAX (set) ;
+
+
+(*
+ Assert -
+*)
+
+PROCEDURE Assert (bool: BOOLEAN; line: CARDINAL) ;
+BEGIN
+ IF NOT bool
+ THEN
+ printf ("%s:%d:assert failed\n", __FILE__, line);
+ exit (1)
+ END
+END Assert ;
+
+
+(*
+ init -
+*)
+
+PROCEDURE init ;
+VAR
+ left, right: set ;
+BEGIN
+ left := set {} ;
+ right := set {1} ;
+ Assert (NOT Equal (left, right, HighBit), __LINE__) ;
+ Clear (right, HighBit) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+ printf ("All tests pass in %s\n", __FILE__)
+END init ;
+
+
+BEGIN
+ init
+END bitset.
--- /dev/null
+MODULE bitset ;
+
+FROM libc IMPORT printf, exit ;
+FROM M2WIDESET IMPORT Equal, Clear ;
+
+CONST
+ HighBit = MAX (BITSET) ;
+
+
+(*
+ Assert -
+*)
+
+PROCEDURE Assert (bool: BOOLEAN; line: CARDINAL) ;
+BEGIN
+ IF NOT bool
+ THEN
+ printf ("%s:%d:assert failed\n", __FILE__, line);
+ exit (1)
+ END
+END Assert ;
+
+
+(*
+ init -
+*)
+
+PROCEDURE init ;
+VAR
+ left, right: BITSET ;
+BEGIN
+ left := BITSET {} ;
+ right := BITSET {1} ;
+ Assert (NOT Equal (left, right, HighBit), __LINE__) ;
+ Clear (right, HighBit) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+ printf ("All tests pass in %s\n", __FILE__)
+END init ;
+
+
+BEGIN
+ init
+END bitset.
--- /dev/null
+MODULE colorset ;
+
+FROM libc IMPORT printf, exit ;
+FROM M2WIDESET IMPORT Equal, Clear ;
+
+TYPE
+ color = SET OF (red, green, blue) ;
+ set = color ;
+
+CONST
+ HighBit = MAX (set) ;
+
+
+(*
+ Assert -
+*)
+
+PROCEDURE Assert (bool: BOOLEAN; line: CARDINAL) ;
+BEGIN
+ IF NOT bool
+ THEN
+ printf ("%s:%d:assert failed\n", __FILE__, line);
+ exit (1)
+ END
+END Assert ;
+
+
+(*
+ init -
+*)
+
+PROCEDURE init ;
+VAR
+ left, right: set ;
+BEGIN
+ left := set {} ;
+ right := set {green} ;
+ Assert (NOT Equal (left, right, HighBit), __LINE__) ;
+ Clear (right, HighBit) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+ printf ("All tests pass in %s\n", __FILE__)
+END init ;
+
+
+BEGIN
+ init
+END colorset.
--- /dev/null
+MODULE colorset2 ;
+
+FROM libc IMPORT printf, exit ;
+FROM M2WIDESET IMPORT Equal, Clear, Shift, Rotate ;
+
+TYPE
+ color = SET OF (red, green, blue) ;
+ set = color ;
+
+CONST
+ HighBit = MAX (set) ;
+
+
+(*
+ Assert -
+*)
+
+PROCEDURE Assert (bool: BOOLEAN; line: CARDINAL) ;
+BEGIN
+ IF NOT bool
+ THEN
+ printf ("%s:%d:assert failed\n", __FILE__, line);
+ exit (1)
+ END
+END Assert ;
+
+
+(*
+ init -
+*)
+
+PROCEDURE init ;
+VAR
+ left, right: set ;
+BEGIN
+ left := set {} ;
+ right := set {green} ;
+ Assert (NOT Equal (left, right, HighBit), __LINE__) ;
+ Clear (right, HighBit) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+
+ left := set {red} ;
+ right := set {green} ;
+ Assert (NOT Equal (left, right, HighBit), __LINE__) ;
+ Shift (right, right, MAX (set), -1) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+ left := set {red} ;
+ right := set {green} ;
+ Shift (left, left, MAX (set), 1) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+
+ left := set {red} ;
+ right := set {green} ;
+ Rotate (left, left, MAX (set), 1) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+
+ left := set {green} ;
+ right := set {red} ;
+ Rotate (left, left, MAX (set), -1) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+
+ left := set {red} ;
+ right := set {blue} ;
+ Rotate (left, left, MAX (set), -1) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+ printf ("All tests pass in %s\n", __FILE__)
+END init ;
+
+
+BEGIN
+ init
+END colorset2.
--- /dev/null
+MODULE colorset3 ;
+
+FROM libc IMPORT printf, exit ;
+FROM M2WIDESET IMPORT Equal, Clear, Shift, Rotate ;
+
+TYPE
+ color = SET OF (red, green, blue) ;
+ set = color ;
+
+CONST
+ HighBit = MAX (set) ;
+
+
+(*
+ Assert -
+*)
+
+PROCEDURE Assert (bool: BOOLEAN; line: CARDINAL) ;
+BEGIN
+ IF NOT bool
+ THEN
+ printf ("%s:%d:assert failed\n", __FILE__, line);
+ exit (1)
+ END
+END Assert ;
+
+
+(*
+ init -
+*)
+
+PROCEDURE init ;
+VAR
+ left, right: set ;
+BEGIN
+ left := set {green} ;
+ right := set {red} ;
+ Rotate (left, left, MAX (set), -1) ;
+ Assert (Equal (left, right, HighBit), __LINE__) ;
+ printf ("All tests pass in %s\n", __FILE__)
+END init ;
+
+
+BEGIN
+ init
+END colorset3.
--- /dev/null
+MODULE highbit ;
+
+FROM libc IMPORT printf ;
+
+TYPE
+ set = BITSET ;
+
+CONST
+ HighBit = MAX (set) ;
+
+BEGIN
+ printf ("the MAX (set) = %d\n", HighBit)
+END highbit.
--- /dev/null
+MODULE highbit2 ;
+
+FROM libc IMPORT printf ;
+
+TYPE
+ set = BITSET ;
+
+CONST
+ HighBit = MAX (BITSET) ;
+
+BEGIN
+ printf ("the MAX (BITSET) = %d\n", HighBit)
+END highbit2.
MODULE multisetrotate4 ;
FROM libc IMPORT printf, exit ;
-FROM SYSTEM IMPORT ROTATE, WORD, BITSPERLOC ;
+FROM SYSTEM IMPORT ROTATE, WORD, BITSPERLOC, TBITSIZE ;
TYPE
multi = SET OF [0..SIZE (WORD) * 2 * BITSPERLOC-1] ;
BEGIN
set := multi {1} ;
bits := SIZE (multi) * BITSPERLOC ;
+ IF bits # TBITSIZE (set)
+ THEN
+ printf ("test code is invalid, set must match TBITSIZE\n");
+ exit (3)
+ END ;
IF ROTATE (set, bits-1) # multi {0}
THEN
+ printf ("rotate %d on a set type of %d bits failed\n",
+ bits-1, bits) ;
exit (1)
END ;
IF ROTATE (set, -(bits - 1)) # multi {2}
THEN
+ printf ("rotate %d on a set type of %d bits failed\n",
+ - (bits-1), bits) ;
exit (2)
END ;
exit (0)
--- /dev/null
+(* Copyright (C) 2025 Free Software Foundation, Inc. *)
+(* 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 2, 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 gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE multisetrotate5 ;
+
+FROM libc IMPORT printf, exit ;
+FROM SYSTEM IMPORT ROTATE, WORD, BITSPERLOC ;
+
+TYPE
+ multi = SET OF [0..SIZE (WORD) * 2 * BITSPERLOC-1] ;
+
+
+(*
+ dump -
+*)
+
+PROCEDURE dump (s: multi) ;
+VAR
+ bits, i: CARDINAL ;
+BEGIN
+ bits := SIZE (multi) * BITSPERLOC -1;
+ FOR i := 0 TO bits DO
+ printf (" %2d", i)
+ END ;
+ printf ("\n") ;
+ FOR i := 0 TO bits DO
+ IF i IN s
+ THEN
+ printf (" X")
+ ELSE
+ printf (" ")
+ END
+ END ;
+ printf ("\n")
+END dump ;
+
+
+VAR
+ set : multi ;
+ bits: INTEGER ;
+BEGIN
+ dump (multi {1}) ;
+ dump (multi {2}) ;
+ set := multi {2} ;
+ dump (set) ;
+ set := multi {1} ;
+ dump (set) ;
+ IF ROTATE (set, 1) = multi {2}
+ THEN
+ exit (0)
+ END ;
+ set := multi {2} ;
+ set := ROTATE (set, 1) ;
+ dump (set) ;
+ exit (1)
+END multisetrotate5.
--- /dev/null
+MODULE setcard ;
+
+FROM libc IMPORT exit ;
+
+TYPE
+ large = SET OF CARDINAL ;
+VAR
+ set: large ;
+BEGIN
+ set := large {} ;
+ INCL (set, 2) ;
+ IF 2 IN set
+ THEN
+ exit (0)
+ ELSE
+ exit (1)
+ END
+END setcard.
--- /dev/null
+(* Copyright (C) 2024 Free Software Foundation, Inc. *)
+(* 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 2, 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 gm2; see the file COPYING. If not, write to the Free Software
+Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
+
+MODULE setincl ;
+
+FROM libc IMPORT printf, exit ;
+FROM SYSTEM IMPORT ROTATE ;
+
+
+PROCEDURE incl (VAR set: BITSET; bit: CARDINAL) ;
+BEGIN
+ INCL (set, bit)
+END incl ;
+
+
+PROCEDURE excl (VAR set: BITSET; bit: CARDINAL) ;
+BEGIN
+ EXCL (set, bit)
+END excl ;
+
+
+VAR
+ set: BITSET ;
+BEGIN
+ set := BITSET {} ;
+ incl (set, 1) ;
+ IF set # BITSET {1}
+ THEN
+ exit (1)
+ END ;
+ excl (set, 1) ;
+ IF set # BITSET {}
+ THEN
+ exit (2)
+ END ;
+ exit (0)
+END setincl.
assert (ROTATE (psettype {1}, 1) = ROTATE (psettype {1}, 1), __LINE__, "comparision between constant rotated packed sets") ;
assert (ROTATE (psettype {1}, 1) # ROTATE (psettype {2}, 1), __LINE__, "comparision between constant rotated packed sets") ;
assert (ROTATE (a, 1) = psettype {2}, __LINE__, "comparision between rotated variable and constant packed sets") ;
- assert (ROTATE (a, -1) = settype {0}, __LINE__, "comparision between rotated variable and constant packed sets") ;
+ assert (ROTATE (a, -1) = psettype {0}, __LINE__, "comparision between rotated variable and constant packed sets") ;
END testpset ;
gm2_link_lib "m2min"
lappend args -fno-exceptions
lappend args -fno-libs=-
+ lappend args -fno-wideset
gm2_init {*}${theIpath} {*}${dialect} {*}${theLpath} {*}${args}
}
M2MODS = ASCII.mod IO.mod \
Args.mod M2RTS.mod \
M2Dependent.mod \
+ M2Diagnostic.mod \
+ M2WIDESET.mod \
Assertion.mod NumberIO.mod \
Break.mod SYSTEM.mod \
CmdArgs.mod Scan.mod \
LegacyReal.def libc.def \
libm.def LMathLib0.def \
M2Dependent.def \
+ M2Diagnostic.def \
M2EXCEPTION.def \
M2RTS.def \
+ M2WIDESET.def \
MathLib0.def MemUtils.def \
NumberIO.def PushBackInput.def \
RTExceptions.def RTint.def \
LTLIBRARIES = $(toolexeclib_LTLIBRARIES)
libm2pim_la_LIBADD =
@BUILD_PIMLIB_TRUE@am__objects_1 = ASCII.lo IO.lo Args.lo M2RTS.lo \
-@BUILD_PIMLIB_TRUE@ M2Dependent.lo Assertion.lo NumberIO.lo \
-@BUILD_PIMLIB_TRUE@ Break.lo SYSTEM.lo CmdArgs.lo Scan.lo \
-@BUILD_PIMLIB_TRUE@ StrCase.lo FIO.lo StrIO.lo StrLib.lo \
-@BUILD_PIMLIB_TRUE@ TimeString.lo Environment.lo FpuIO.lo \
-@BUILD_PIMLIB_TRUE@ Debug.lo SysStorage.lo Storage.lo StdIO.lo \
+@BUILD_PIMLIB_TRUE@ M2Dependent.lo M2Diagnostic.lo M2WIDESET.lo \
+@BUILD_PIMLIB_TRUE@ Assertion.lo NumberIO.lo Break.lo SYSTEM.lo \
+@BUILD_PIMLIB_TRUE@ CmdArgs.lo Scan.lo StrCase.lo FIO.lo \
+@BUILD_PIMLIB_TRUE@ StrIO.lo StrLib.lo TimeString.lo \
+@BUILD_PIMLIB_TRUE@ Environment.lo FpuIO.lo Debug.lo \
+@BUILD_PIMLIB_TRUE@ SysStorage.lo Storage.lo StdIO.lo \
@BUILD_PIMLIB_TRUE@ SEnvironment.lo DynamicStrings.lo SFIO.lo \
@BUILD_PIMLIB_TRUE@ SArgs.lo SCmdArgs.lo PushBackInput.lo \
@BUILD_PIMLIB_TRUE@ StringConvert.lo FormatStrings.lo \
@BUILD_PIMLIB_TRUE@M2MODS = ASCII.mod IO.mod \
@BUILD_PIMLIB_TRUE@ Args.mod M2RTS.mod \
@BUILD_PIMLIB_TRUE@ M2Dependent.mod \
+@BUILD_PIMLIB_TRUE@ M2Diagnostic.mod \
+@BUILD_PIMLIB_TRUE@ M2WIDESET.mod \
@BUILD_PIMLIB_TRUE@ Assertion.mod NumberIO.mod \
@BUILD_PIMLIB_TRUE@ Break.mod SYSTEM.mod \
@BUILD_PIMLIB_TRUE@ CmdArgs.mod Scan.mod \
@BUILD_PIMLIB_TRUE@ LegacyReal.def libc.def \
@BUILD_PIMLIB_TRUE@ libm.def LMathLib0.def \
@BUILD_PIMLIB_TRUE@ M2Dependent.def \
+@BUILD_PIMLIB_TRUE@ M2Diagnostic.def \
@BUILD_PIMLIB_TRUE@ M2EXCEPTION.def \
@BUILD_PIMLIB_TRUE@ M2RTS.def \
+@BUILD_PIMLIB_TRUE@ M2WIDESET.def \
@BUILD_PIMLIB_TRUE@ MathLib0.def MemUtils.def \
@BUILD_PIMLIB_TRUE@ NumberIO.def PushBackInput.def \
@BUILD_PIMLIB_TRUE@ RTExceptions.def RTint.def \
projects / thirdparty / gcc.git / commitdiff
