Google Git
Sign in
gnu / gcc.git / 7c99de1c439dbb149cc6a33a214f22f2df1c88f3 / . / gcc / m2 / gm2-compiler / M2GCCDeclare.mod
blob: 860a89ac8b0c6be29ee46dc7ddb71e9883d2f7bb [file] [log] [blame]
(* M2GCCDeclare.mod declares Modula-2 types to GCC.
Copyright (C) 2001-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.
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 M2GCCDeclare ;
(*
Title : M2GCCDeclare
Author : Gaius Mulley
System : UNIX (gm2)
Date : Fri Jul 16 20:10:55 1999
Description: declares Modula-2 types to GCC, it attempts
to only declare a type once all subcomponents are known.
*)
FROM SYSTEM IMPORT ADDRESS, ADR, WORD ;
FROM ASCII IMPORT nul ;
FROM Storage IMPORT ALLOCATE ;
FROM M2Debug IMPORT Assert ;
FROM M2Quads IMPORT DisplayQuadRange ;
FROM m2pp IMPORT DumpGimpleFd ;
IMPORT FIO ;
FROM M2Options IMPORT GenerateDebugging, GenerateLineDebug, Iso, Optimizing, WholeProgram,
ScaffoldStatic, GetRuntimeModuleOverride ;
FROM M2AsmUtil IMPORT GetFullSymName, GetFullScopeAsmName ;
FROM M2Batch IMPORT MakeDefinitionSource ;
FROM NameKey IMPORT Name, MakeKey, NulName, KeyToCharStar, makekey ;
FROM M2FileName IMPORT CalculateFileName ;
FROM DynamicStrings IMPORT String, string, InitString, KillString, InitStringCharStar, InitStringChar, Mark ;
FROM M2LexBuf IMPORT TokenToLineNo, FindFileNameFromToken, TokenToLocation, UnknownTokenNo, BuiltinTokenNo ;
FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3 ;
FROM M2Error IMPORT FlushErrors, InternalError ;
FROM M2LangDump IMPORT GetDumpFile ;
FROM M2Printf IMPORT printf0, printf1, printf2, printf3,
fprintf0, fprintf1, fprintf2, fprintf3 ;
FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, InBounds,
IncludeIndiceIntoIndex, HighIndice,
DebugIndex ;
FROM Lists IMPORT List, InitList, IncludeItemIntoList,
PutItemIntoList, GetItemFromList,
RemoveItemFromList, ForeachItemInListDo,
IsItemInList, NoOfItemsInList, KillList ;
FROM Sets IMPORT Set, InitSet, KillSet,
IncludeElementIntoSet, ExcludeElementFromSet,
NoOfElementsInSet, IsElementInSet, ForeachElementInSetDo,
DuplicateSet, EqualSet ;
FROM M2BasicBlock IMPORT BasicBlock, InitBasicBlocks, KillBasicBlocks, ForeachBasicBlockDo ;
FROM SymbolTable IMPORT NulSym,
ModeOfAddr, ProcedureKind,
GetProcedureKindDesc,
GetProcedureParametersDefined,
GetMode,
GetScope,
GetNth, SkipType, GetVarBackEndType,
GetSType, GetLType, GetDType,
MakeType, PutType, GetLowestType,
GetSubrange, PutSubrange, GetArraySubscript,
NoOfParamAny, GetNthParamAny,
PushValue, PopValue, PopSize,
IsTemporary, IsUnbounded, IsPartialUnbounded,
IsEnumeration, IsVar,
IsSubrange, IsPointer, IsRecord, IsArray,
IsFieldEnumeration,
IsProcedure, IsProcedureNested, IsModule,
IsDefImp,
IsSubscript, IsVarient, IsFieldVarient,
IsType, IsProcType, IsSet, IsSetPacked,
IsConst, IsConstSet, IsConstructor,
IsFieldEnumeration,
IsExported, IsImported,
IsVarParamAny, IsRecordField, IsUnboundedParam,
IsValueSolved,
IsDefinitionForC, IsHiddenTypeDeclared,
IsInnerModule, IsUnknown,
IsProcedureReachable, IsParameter, IsConstLit,
IsDummy, IsVarAParam, IsProcedureVariable,
IsGnuAsm, IsGnuAsmVolatile, IsObject, IsTuple,
IsError, IsHiddenType, IsVarHeap,
IsComponent, IsPublic, IsExtern, IsCtor,
IsImport, IsImportStatement, IsConstStringKnown,
IsUnboundedParamAny,
GetMainModule, GetBaseModule, GetModule, GetLocalSym,
PutModuleFinallyFunction,
GetProcedureScope, GetProcedureQuads,
NoOfParam, IsVarParam, GetNthParam, GetType,
IsRecordFieldAVarientTag, IsEmptyFieldVarient,
GetVarient, GetUnbounded, PutArrayLarge,
IsAModula2Type, UsesVarArgs,
GetSymName, GetParent,
GetDeclaredMod, GetVarBackEndType,
GetProcedureBeginEnd, IsProcedureAnyNoReturn,
GetString, GetStringLength, IsConstString,
IsConstStringM2, IsConstStringC, IsConstStringM2nul, IsConstStringCnul,
GetAlignment, IsDeclaredPacked, PutDeclaredPacked,
GetDefaultRecordFieldAlignment, IsDeclaredPackedResolved,
GetPackedEquivalent,
GetParameterShadowVar,
GetUnboundedRecordType,
GetModuleCtors, GetProcedureProcType,
MakeSubrange, MakeConstVar, MakeConstLit,
PutConst,
ForeachOAFamily, GetOAFamily,
IsModuleWithinProcedure, IsVariableSSA,
IsVariableAtAddress, IsConstructorConstant,
ForeachLocalSymDo,
ForeachProcedureDo, ForeachModuleDo,
ForeachInnerModuleDo, ForeachImportedDo,
ForeachExportedDo, PrintInitialized,
FinalSymbol ;
FROM M2Base IMPORT IsPseudoBaseProcedure, IsPseudoBaseFunction,
GetBaseTypeMinMax, MixTypes,
Cardinal, Char, Proc, Integer,
LongInt, LongCard, ShortCard, ShortInt,
Real, LongReal, ShortReal, ZType, RType,
CType, Complex, LongComplex, ShortComplex,
Boolean, True, False, Nil,
IsRealType, IsNeededAtRunTime, IsComplexType ;
FROM M2System IMPORT IsPseudoSystemFunction, IsSystemType, IsRealN,
GetSystemTypeMinMax, Address, Word, Byte, Loc,
System, IntegerN, CardinalN, WordN, RealN, SetN, ComplexN,
CSizeT, CSSizeT, COffT ;
FROM M2Bitset IMPORT Bitset, Bitnum ;
FROM SymbolConversion IMPORT AddModGcc, Mod2Gcc, GccKnowsAbout, Poison, RemoveMod2Gcc ;
FROM M2GenGCC IMPORT ResolveConstantExpressions ;
FROM M2Scope IMPORT ScopeBlock, InitScopeBlock, KillScopeBlock, ForeachScopeBlockDo3 ;
FROM M2ALU IMPORT Addn, Sub, Equ, GreEqu, Gre, Less, PushInt, PushCard, ConvertToType,
PushIntegerTree, PopIntegerTree, PopRealTree, ConvertToInt, PopSetTree,
PopChar,
DivTrunc,
IsConstructorDependants, WalkConstructorDependants,
PopConstructorTree, PopComplexTree, PutConstructorSolved,
ChangeToConstructor, EvaluateValue, TryEvaluateValue ;
FROM M2Batch IMPORT IsSourceSeen, GetModuleFile, IsModuleSeen, LookupModule ;
FROM gcctypes IMPORT location_t, tree ;
FROM m2linemap IMPORT BuiltinsLocation ;
FROM m2decl IMPORT BuildIntegerConstant, BuildStringConstant, BuildCStringConstant,
BuildStartFunctionDeclaration,
BuildParameterDeclaration, BuildEndFunctionDeclaration,
DeclareKnownVariable, GetBitsPerBitset, BuildPtrToTypeString ;
FROM m2type IMPORT MarkFunctionReferenced, BuildStartRecord, BuildStartVarient, BuildStartFunctionType,
BuildStartFieldVarient, BuildStartVarient, BuildStartType, BuildStartArrayType,
PutArrayType, BuildPointerType, BuildEndType, BuildCharConstant,
BuildTypeDeclaration, GetDefaultType, GetBooleanType, GetBooleanTrue,
GetBooleanFalse, BuildSubrangeType, GetM2ZType, GetM2RType, GetM2CType,
GetM2CardinalType, GetM2IntegerType, GetM2CharType, GetISOLocType, GetIntegerType,
GetISOByteType, GetISOWordType, GetByteType, GetWordType, GetProcType, GetPointerType,
GetM2LongIntType, GetM2LongCardType, GetM2ShortIntType, GetM2ShortCardType,
GetM2LongRealType, GetM2ShortRealType, GetM2RealType, GetBitnumType, GetBitsetType,
GetM2ComplexType, GetM2ComplexType, GetM2LongComplexType, GetM2ShortComplexType,
GetM2Integer8, GetM2Integer16, GetM2Integer32, GetM2Integer64, GetM2Cardinal8,
GetM2Cardinal16, GetM2Cardinal32, GetM2Cardinal64, GetM2Word16, GetM2Word32,
GetM2Word64, GetM2Bitset8, GetM2Bitset16, GetM2Bitset32, GetM2Real32, GetM2Real64,
GetM2Real96, GetM2Real128, GetM2Complex32, GetM2Complex64, GetM2Complex96,
GetM2Complex128, GetCSizeTType, GetCSSizeTType, GetCOffTType,
GetPackedBooleanType, BuildConstPointerType,
BuildPointerType, BuildEnumerator, BuildStartEnumeration, BuildEndEnumeration,
SetAlignment, SetTypePacked, SetDeclPacked, BuildSmallestTypeRange,
SetRecordFieldOffset, ChainOn, BuildEndRecord, BuildFieldRecord,
BuildEndFieldVarient, BuildArrayIndexType, BuildEndFunctionType,
BuildSetType, BuildEndVarient, BuildEndArrayType, InitFunctionTypeParameters,
BuildProcTypeParameterDeclaration, DeclareKnownType,
ValueOutOfTypeRange, ExceedsTypeRange,
GetMaxFrom, GetMinFrom ;
FROM m2convert IMPORT BuildConvert ;
FROM m2expr IMPORT BuildSub, BuildLSL, BuildTBitSize, BuildAdd, BuildDivTrunc, BuildModTrunc,
BuildSize, TreeOverflow, AreConstantsEqual, CompareTrees,
GetPointerZero, GetIntegerZero, GetIntegerOne ;
FROM m2block IMPORT RememberType, pushGlobalScope, popGlobalScope,
pushFunctionScope, popFunctionScope,
finishFunctionDecl, RememberConstant, GetGlobalContext ;
TYPE
StartProcedure = PROCEDURE (location_t, ADDRESS) : tree ;
ListType = (fullydeclared, partiallydeclared, niltypedarrays,
heldbyalignment, finishedalignment, todolist,
tobesolvedbyquads, finishedsetarray) ;
doDeclareProcedure = PROCEDURE (CARDINAL, CARDINAL) ;
CONST
Debugging = FALSE ;
Progress = FALSE ;
EnableSSA = FALSE ;
EnableWatch = TRUE ;
TraceQuadruples = FALSE ;
TYPE
Group = POINTER TO RECORD
ToBeSolvedByQuads, (* Constants which must be solved *)
(* by processing the quadruples. *)
FinishedSetArray, (* Sets which have had their set *)
(* array created. *)
NilTypedArrays, (* Arrays which have NIL as their *)
(* type. *)
FullyDeclared, (* Those symbols which have been *)
(* fully declared. *)
PartiallyDeclared, (* Those types which have need to *)
(* be finished (but already *)
(* started: records, function *)
(* and array type). *)
HeldByAlignment, (* Types which have a user *)
(* specified alignment constant. *)
FinishedAlignment, (* Records for which we know *)
(* their alignment value. *)
ToDoList : Set ; (* Contains a set of all *)
(* outstanding types that need to *)
(* be declared to GCC once *)
(* its dependants have *)
(* been written. *)
Next : Group ;
END ;
VAR
FreeGroup,
GlobalGroup : Group ; (* The global group of all sets. *)
ErrorDepList, (* The set of symbols with dependency errors. *)
VisitedList,
ChainedList : Set ;
HaveInitDefaultTypes: BOOLEAN ; (* Have we initialized them yet? *)
WatchList : Set ; (* Set of symbols being watched. *)
EnumerationIndex : Index ;
action : IsAction ;
ConstantResolved,
enumDeps : BOOLEAN ;
(* *************************************************** *)
(*
PrintNum -
*)
PROCEDURE PrintNum (sym: WORD) ;
BEGIN
printf1 ('%d, ', sym)
END PrintNum ;
(*
DebugSet -
*)
PROCEDURE DebugSet (a: ARRAY OF CHAR; l: Set) ;
BEGIN
printf0 (a) ;
printf0 (' {') ;
ForeachElementInSetDo (l, PrintNum) ;
printf0 ('}\n')
END DebugSet ;
(*
DebugSets -
*)
PROCEDURE DebugSets ;
BEGIN
DebugSet ('ToDoList', GlobalGroup^.ToDoList) ;
DebugSet ('HeldByAlignment', GlobalGroup^.HeldByAlignment) ;
DebugSet ('FinishedAlignment', GlobalGroup^.FinishedAlignment) ;
DebugSet ('PartiallyDeclared', GlobalGroup^.PartiallyDeclared) ;
DebugSet ('FullyDeclared', GlobalGroup^.FullyDeclared) ;
DebugSet ('NilTypedArrays', GlobalGroup^.NilTypedArrays) ;
DebugSet ('ToBeSolvedByQuads', GlobalGroup^.ToBeSolvedByQuads) ;
DebugSet ('FinishedSetArray', GlobalGroup^.FinishedSetArray)
END DebugSets ;
(* ************************************************ *)
(*
DebugNumber -
*)
PROCEDURE DebugNumber (a: ARRAY OF CHAR; s: Set) ;
VAR
n: CARDINAL ;
BEGIN
n := NoOfElementsInSet (s) ;
printf1 (a, n) ;
FIO.FlushBuffer (FIO.StdOut)
END DebugNumber ;
(*
DebugSets -
*)
PROCEDURE DebugSetNumbers ;
BEGIN
DebugNumber ('ToDoList : %d\n', GlobalGroup^.ToDoList) ;
DebugNumber ('HeldByAlignment : %d\n', GlobalGroup^.HeldByAlignment) ;
DebugNumber ('PartiallyDeclared : %d\n', GlobalGroup^.PartiallyDeclared) ;
DebugNumber ('FullyDeclared : %d\n', GlobalGroup^.FullyDeclared) ;
DebugNumber ('NilTypedArrays : %d\n', GlobalGroup^.NilTypedArrays) ;
DebugNumber ('ToBeSolvedByQuads : %d\n', GlobalGroup^.ToBeSolvedByQuads) ;
DebugNumber ('FinishedSetArray : %d\n', GlobalGroup^.FinishedSetArray)
END DebugSetNumbers ;
(*
AddSymToWatch - adds symbol, sym, to the list of symbols
to watch and annotate their movement between
lists.
*)
PROCEDURE AddSymToWatch (sym: WORD) ;
BEGIN
IF (sym # NulSym) AND (NOT IsElementInSet (WatchList, sym))
THEN
IncludeElementIntoSet (WatchList, sym) ;
WalkDependants (sym, AddSymToWatch) ;
fprintf1 (GetDumpFile (), "%d, ", sym)
END
END AddSymToWatch ;
(*
TryFindSymbol -
*)
(*
PROCEDURE TryFindSymbol (module, symname: ARRAY OF CHAR) : CARDINAL ;
VAR
mn, sn: Name ;
mod : CARDINAL ;
BEGIN
mn := MakeKey(module) ;
sn := MakeKey(symname) ;
IF IsModuleSeen(mn)
THEN
mod := LookupModule (UnknownTokenNo, mn) ;
RETURN( GetLocalSym(mod, sn) )
ELSE
RETURN( NulSym )
END
END TryFindSymbol ;
*)
(*
doInclude -
*)
PROCEDURE doInclude (l: Set; a: ARRAY OF CHAR; sym: CARDINAL) ;
BEGIN
IF NOT IsElementInSet(l, sym)
THEN
fprintf0 (GetDumpFile (), 'rule: ') ;
WriteRule ;
fprintf0 (GetDumpFile (), ' ') ;
fprintf1 (GetDumpFile (), a, sym) ;
IncludeElementIntoSet (l, sym)
END
END doInclude ;
(*
WatchIncludeList - include a symbol onto the set first checking
whether it is already on the set and
displaying a debug message if the set is
changed.
*)
PROCEDURE WatchIncludeList (sym: CARDINAL; lt: ListType) ;
BEGIN
IF IsElementInSet (WatchList, sym)
THEN
CASE lt OF
tobesolvedbyquads : doInclude (GlobalGroup^.ToBeSolvedByQuads, "symbol %d -> ToBeSolvedByQuads\n", sym) |
fullydeclared : doInclude (GlobalGroup^.FullyDeclared, "symbol %d -> FullyDeclared\n", sym) |
partiallydeclared : doInclude (GlobalGroup^.PartiallyDeclared, "symbol %d -> PartiallyDeclared\n", sym) |
heldbyalignment : doInclude (GlobalGroup^.HeldByAlignment, "symbol %d -> HeldByAlignment\n", sym) |
finishedalignment : doInclude (GlobalGroup^.FinishedAlignment, "symbol %d -> FinishedAlignment\n", sym) |
todolist : doInclude (GlobalGroup^.ToDoList, "symbol %d -> ToDoList\n", sym) |
niltypedarrays : doInclude (GlobalGroup^.NilTypedArrays, "symbol %d -> NilTypedArrays\n", sym) |
finishedsetarray : doInclude (GlobalGroup^.FinishedSetArray, "symbol %d -> FinishedSetArray\n", sym)
ELSE
InternalError ('unknown list')
END
ELSE
CASE lt OF
tobesolvedbyquads : IncludeElementIntoSet (GlobalGroup^.ToBeSolvedByQuads, sym) |
fullydeclared : IncludeElementIntoSet (GlobalGroup^.FullyDeclared, sym) |
partiallydeclared : IncludeElementIntoSet (GlobalGroup^.PartiallyDeclared, sym) |
heldbyalignment : IncludeElementIntoSet (GlobalGroup^.HeldByAlignment, sym) |
finishedalignment : IncludeElementIntoSet (GlobalGroup^.FinishedAlignment, sym) |
todolist : IncludeElementIntoSet (GlobalGroup^.ToDoList, sym) |
niltypedarrays : IncludeElementIntoSet (GlobalGroup^.NilTypedArrays, sym) |
finishedsetarray : IncludeElementIntoSet (GlobalGroup^.FinishedSetArray, sym)
ELSE
InternalError ('unknown list')
END
END
END WatchIncludeList ;
(*
doExclude -
*)
PROCEDURE doExclude (l: Set; a: ARRAY OF CHAR; sym: CARDINAL) ;
BEGIN
IF IsElementInSet (l, sym)
THEN
fprintf0 (GetDumpFile (), 'rule: ') ;
WriteRule ;
fprintf0 (GetDumpFile (), ' ') ;
fprintf1 (GetDumpFile (), a, sym) ;
ExcludeElementFromSet (l, sym)
END
END doExclude ;
(*
WatchRemoveList - remove a symbol onto the list first checking
whether it is already on the list and
displaying a debug message if the list is
changed.
*)
PROCEDURE WatchRemoveList (sym: CARDINAL; lt: ListType) ;
BEGIN
IF IsElementInSet (WatchList, sym)
THEN
CASE lt OF
tobesolvedbyquads : doExclude (GlobalGroup^.ToBeSolvedByQuads, "symbol %d off ToBeSolvedByQuads\n", sym) |
fullydeclared : doExclude (GlobalGroup^.FullyDeclared, "symbol %d off FullyDeclared\n", sym) |
partiallydeclared : doExclude (GlobalGroup^.PartiallyDeclared, "symbol %d off PartiallyDeclared\n", sym) |
heldbyalignment : doExclude (GlobalGroup^.HeldByAlignment, "symbol %d -> HeldByAlignment\n", sym) |
finishedalignment : doExclude (GlobalGroup^.FinishedAlignment, "symbol %d -> FinishedAlignment\n", sym) |
todolist : doExclude (GlobalGroup^.ToDoList, "symbol %d off ToDoList\n", sym) |
niltypedarrays : doExclude (GlobalGroup^.NilTypedArrays, "symbol %d off NilTypedArrays\n", sym) |
finishedsetarray : doExclude (GlobalGroup^.FinishedSetArray, "symbol %d off FinishedSetArray\n", sym) |
ELSE
InternalError ('unknown list')
END
ELSE
CASE lt OF
tobesolvedbyquads : ExcludeElementFromSet (GlobalGroup^.ToBeSolvedByQuads, sym) |
fullydeclared : ExcludeElementFromSet (GlobalGroup^.FullyDeclared, sym) |
partiallydeclared : ExcludeElementFromSet (GlobalGroup^.PartiallyDeclared, sym) |
heldbyalignment : ExcludeElementFromSet (GlobalGroup^.HeldByAlignment, sym) |
finishedalignment : ExcludeElementFromSet (GlobalGroup^.FinishedAlignment, sym) |
todolist : ExcludeElementFromSet (GlobalGroup^.ToDoList, sym) |
niltypedarrays : ExcludeElementFromSet (GlobalGroup^.NilTypedArrays, sym) |
finishedsetarray : ExcludeElementFromSet (GlobalGroup^.FinishedSetArray, sym) |
ELSE
InternalError ('unknown list')
END
END
END WatchRemoveList ;
(*
NewGroup -
*)
PROCEDURE NewGroup (VAR g: Group) ;
BEGIN
IF FreeGroup = NIL
THEN
NEW (g)
ELSE
g := FreeGroup ;
FreeGroup := FreeGroup^.Next
END
END NewGroup ;
(*
DisposeGroup -
*)
PROCEDURE DisposeGroup (VAR g: Group) ;
BEGIN
g^.Next := FreeGroup ;
FreeGroup := g ;
g := NIL
END DisposeGroup ;
(*
InitGroup - initialize all sets in group and return the group.
*)
PROCEDURE InitGroup () : Group ;
VAR
g: Group ;
BEGIN
NewGroup (g) ;
(* Initialize all sets in group. *)
WITH g^ DO
FinishedSetArray := InitSet (1) ;
ToDoList := InitSet (1) ;
FullyDeclared := InitSet (1) ;
PartiallyDeclared := InitSet (1) ;
NilTypedArrays := InitSet (1) ;
HeldByAlignment := InitSet (1) ;
FinishedAlignment := InitSet (1) ;
ToBeSolvedByQuads := InitSet (1) ;
Next := NIL
END ;
RETURN g
END InitGroup ;
(*
KillGroup - delete all sets in group and deallocate g.
*)
PROCEDURE KillGroup (VAR g: Group) ;
BEGIN
(* Delete all sets in group. *)
IF g # NIL
THEN
WITH g^ DO
FinishedSetArray := KillSet (FinishedSetArray) ;
ToDoList := KillSet (ToDoList) ;
FullyDeclared := KillSet (FullyDeclared) ;
PartiallyDeclared := KillSet (PartiallyDeclared) ;
NilTypedArrays := KillSet (NilTypedArrays) ;
HeldByAlignment := KillSet (HeldByAlignment) ;
FinishedAlignment := KillSet (FinishedAlignment) ;
ToBeSolvedByQuads := KillSet (ToBeSolvedByQuads) ;
Next := NIL
END ;
DisposeGroup (g)
END
END KillGroup ;
(*
DupGroup - If g is not NIL then destroy g.
Return a duplicate of GlobalGroup.
*)
PROCEDURE DupGroup (g: Group) : Group ;
BEGIN
IF g # NIL
THEN
(* Kill old group. *)
KillGroup (g)
END ;
NewGroup (g) ;
WITH g^ DO
(* Copy all sets. *)
FinishedSetArray := DuplicateSet (GlobalGroup^.FinishedSetArray) ;
ToDoList := DuplicateSet (GlobalGroup^.ToDoList) ;
FullyDeclared := DuplicateSet (GlobalGroup^.FullyDeclared) ;
PartiallyDeclared := DuplicateSet (GlobalGroup^.PartiallyDeclared) ;
NilTypedArrays := DuplicateSet (GlobalGroup^.NilTypedArrays) ;
HeldByAlignment := DuplicateSet (GlobalGroup^.HeldByAlignment) ;
FinishedAlignment := DuplicateSet (GlobalGroup^.FinishedAlignment) ;
ToBeSolvedByQuads := DuplicateSet (GlobalGroup^.ToBeSolvedByQuads) ;
Next := NIL
END ;
RETURN g
END DupGroup ;
(*
EqualGroup - return TRUE if group left = right.
*)
PROCEDURE EqualGroup (left, right: Group) : BOOLEAN ;
BEGIN
RETURN ((left = right) OR
(EqualSet (left^.FullyDeclared, right^.FullyDeclared) AND
EqualSet (left^.PartiallyDeclared, right^.PartiallyDeclared) AND
EqualSet (left^.NilTypedArrays, right^.NilTypedArrays) AND
EqualSet (left^.HeldByAlignment, right^.HeldByAlignment) AND
EqualSet (left^.FinishedAlignment, right^.FinishedAlignment) AND
EqualSet (left^.ToDoList, right^.ToDoList) AND
EqualSet (left^.ToBeSolvedByQuads, right^.ToBeSolvedByQuads) AND
EqualSet (left^.FinishedSetArray, right^.FinishedSetArray)))
END EqualGroup ;
(*
LookupSet -
*)
PROCEDURE LookupSet (listtype: ListType) : Set ;
BEGIN
CASE listtype OF
fullydeclared : RETURN GlobalGroup^.FullyDeclared |
partiallydeclared : RETURN GlobalGroup^.PartiallyDeclared |
niltypedarrays : RETURN GlobalGroup^.NilTypedArrays |
heldbyalignment : RETURN GlobalGroup^.HeldByAlignment |
finishedalignment : RETURN GlobalGroup^.FinishedAlignment |
todolist : RETURN GlobalGroup^.ToDoList |
tobesolvedbyquads : RETURN GlobalGroup^.ToBeSolvedByQuads |
finishedsetarray : RETURN GlobalGroup^.FinishedSetArray
ELSE
InternalError ('unknown ListType')
END ;
RETURN NIL
END LookupSet ;
(*
GetEnumList -
*)
PROCEDURE GetEnumList (sym: CARDINAL) : tree ;
BEGIN
IF InBounds(EnumerationIndex, sym)
THEN
RETURN( tree (GetIndice(EnumerationIndex, sym)) )
ELSE
RETURN( NIL )
END
END GetEnumList ;
(*
PutEnumList -
*)
PROCEDURE PutEnumList (sym: CARDINAL; enumlist: tree) ;
BEGIN
PutIndice(EnumerationIndex, sym, enumlist)
END PutEnumList ;
(*
MarkExported - tell GCC to mark all exported procedures in module sym.
*)
PROCEDURE MarkExported (sym: CARDINAL) ;
BEGIN
IF Optimizing
THEN
MarkFunctionReferenced(Mod2Gcc(sym)) ;
IF IsDefImp(sym) OR IsModule(sym)
THEN
ForeachExportedDo(sym, MarkExported)
END
END
END MarkExported ;
(*
Chained - checks to see that, sym, has not already been placed on a chain.
It returns the symbol, sym.
*)
PROCEDURE Chained (sym: CARDINAL) : CARDINAL ;
BEGIN
IF IsElementInSet(ChainedList, sym)
THEN
InternalError ('symbol has already been chained onto a previous list')
END ;
IncludeElementIntoSet(ChainedList, sym) ;
RETURN( sym )
END Chained ;
(*
DoStartDeclaration - returns a tree representing a symbol which has
not yet been finished. Used when declaring
recursive types.
*)
PROCEDURE DoStartDeclaration (sym: CARDINAL; p: StartProcedure) : tree ;
VAR
location: location_t ;
BEGIN
IF NOT GccKnowsAbout (sym)
THEN
location := TokenToLocation (GetDeclaredMod (sym)) ;
PreAddModGcc(sym, p (location, KeyToCharStar (GetFullSymName (sym))))
END ;
RETURN Mod2Gcc (sym)
END DoStartDeclaration ;
(*
ArrayComponentsDeclared - returns TRUE if array, sym,
subscripts and type are known.
*)
PROCEDURE ArrayComponentsDeclared (sym: CARDINAL) : BOOLEAN ;
VAR
Subscript : CARDINAL ;
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) )
END ArrayComponentsDeclared ;
(*
GetRecordOfVarient -
*)
PROCEDURE GetRecordOfVarient (sym: CARDINAL) : CARDINAL ;
BEGIN
IF IsVarient(sym) OR IsFieldVarient(sym)
THEN
REPEAT
sym := GetParent(sym)
UNTIL IsRecord(sym)
END ;
RETURN( sym )
END GetRecordOfVarient ;
(*
CanDeclareRecordKind -
*)
PROCEDURE CanDeclareRecordKind (sym: CARDINAL) : BOOLEAN ;
BEGIN
sym := GetRecordOfVarient(sym) ;
RETURN( IsRecord(sym) AND
((GetDefaultRecordFieldAlignment(sym)=NulSym) OR
IsFullyDeclared(GetDefaultRecordFieldAlignment(sym))) )
END CanDeclareRecordKind ;
(*
DeclareRecordKind - works out whether record, sym, is packed or not.
*)
PROCEDURE DeclareRecordKind (sym: CARDINAL) ;
BEGIN
IF IsRecord(sym)
THEN
DetermineIfRecordPacked(sym)
END ;
WatchIncludeList(sym, todolist) ;
WatchRemoveList(sym, heldbyalignment) ;
WatchIncludeList(sym, finishedalignment) ;
IF AllDependantsFullyDeclared(sym)
THEN
(* All good and ready to be solved. *)
END
END DeclareRecordKind ;
(*
CanDeclareRecord -
*)
PROCEDURE CanDeclareRecord (sym: CARDINAL) : BOOLEAN ;
BEGIN
TraverseDependants(sym) ;
IF AllDependantsFullyDeclared(sym)
THEN
RETURN TRUE
ELSE
WatchIncludeList(sym, finishedalignment) ;
RETURN FALSE
END
END CanDeclareRecord ;
(*
FinishDeclareRecord -
*)
PROCEDURE FinishDeclareRecord (sym: CARDINAL) ;
BEGIN
DeclareTypeConstFully(sym) ;
WatchRemoveList(sym, heldbyalignment) ;
WatchRemoveList(sym, finishedalignment) ;
WatchRemoveList(sym, todolist) ;
WatchIncludeList(sym, fullydeclared)
END FinishDeclareRecord ;
(*
CanDeclareTypePartially - return TRUE if we are able to make a
gcc partially created type.
*)
PROCEDURE CanDeclareTypePartially (sym: CARDINAL) : BOOLEAN ;
VAR
type: CARDINAL ;
BEGIN
IF IsElementInSet(GlobalGroup^.PartiallyDeclared, sym)
THEN
RETURN( FALSE )
ELSIF IsProcType(sym) OR IsRecord(sym) OR IsVarient(sym) OR IsFieldVarient(sym)
THEN
RETURN( TRUE )
ELSIF IsType(sym)
THEN
type := GetSType(sym) ;
IF (type#NulSym) AND IsNilTypedArrays(type)
THEN
RETURN( TRUE )
END
END ;
RETURN( FALSE )
END CanDeclareTypePartially ;
(*
DeclareTypePartially - create the gcc partial type symbol from, sym.
*)
PROCEDURE DeclareTypePartially (sym: CARDINAL) ;
VAR
location: location_t ;
BEGIN
(* check to see if we have already partially declared the symbol *)
IF NOT IsElementInSet(GlobalGroup^.PartiallyDeclared, sym)
THEN
IF IsRecord(sym)
THEN
Assert (NOT IsElementInSet (GlobalGroup^.HeldByAlignment, sym)) ;
Assert (DoStartDeclaration (sym, BuildStartRecord) # NIL) ;
WatchIncludeList (sym, heldbyalignment)
ELSIF IsVarient (sym)
THEN
Assert(NOT IsElementInSet(GlobalGroup^.HeldByAlignment, sym)) ;
Assert (DoStartDeclaration(sym, BuildStartVarient) # NIL) ;
WatchIncludeList(sym, heldbyalignment)
ELSIF IsFieldVarient(sym)
THEN
Assert(NOT IsElementInSet(GlobalGroup^.HeldByAlignment, sym)) ;
Assert (DoStartDeclaration(sym, BuildStartFieldVarient) # NIL) ;
WatchIncludeList(sym, heldbyalignment)
ELSIF IsProcType(sym)
THEN
Assert (DoStartDeclaration(sym, BuildStartFunctionType) # NIL) ;
ELSIF IsType(sym)
THEN
IF NOT GccKnowsAbout(sym)
THEN
location := TokenToLocation(GetDeclaredMod(sym)) ;
PreAddModGcc(sym, BuildStartType(location,
KeyToCharStar(GetFullSymName(sym)),
Mod2Gcc(GetSType(sym))))
END
ELSE
InternalError ('do not know how to create a partial type from this symbol')
END ;
WatchIncludeList(sym, partiallydeclared) ;
TraverseDependants(sym)
END
END DeclareTypePartially ;
(*
CanDeclareArrayAsNil -
*)
PROCEDURE CanDeclareArrayAsNil (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsArray(sym) AND ArrayComponentsDeclared(sym) )
END CanDeclareArrayAsNil ;
(*
DeclareArrayAsNil -
*)
PROCEDURE DeclareArrayAsNil (sym: CARDINAL) ;
BEGIN
PreAddModGcc(sym, BuildStartArrayType(BuildIndex(GetDeclaredMod(sym), sym), NIL, GetDType(sym))) ;
WatchIncludeList(sym, niltypedarrays)
END DeclareArrayAsNil ;
(*
CanDeclareArrayPartially -
*)
PROCEDURE CanDeclareArrayPartially (sym: CARDINAL) : BOOLEAN ;
VAR
type: CARDINAL ;
BEGIN
IF IsArray(sym)
THEN
type := GetSType(sym) ;
IF IsPartiallyOrFullyDeclared(type) OR
(IsPointer(type) AND IsNilTypedArrays(type))
THEN
RETURN( TRUE )
END
END ;
RETURN( FALSE )
END CanDeclareArrayPartially ;
(*
DeclareArrayPartially -
*)
PROCEDURE DeclareArrayPartially (sym: CARDINAL) ;
BEGIN
Assert(IsArray(sym) AND GccKnowsAbout(sym)) ;
PutArrayType(Mod2Gcc(sym), Mod2Gcc(GetSType(sym))) ;
WatchIncludeList(sym, partiallydeclared)
END DeclareArrayPartially ;
(*
CanDeclarePointerToNilArray -
*)
PROCEDURE CanDeclarePointerToNilArray (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsPointer(sym) AND IsNilTypedArrays(GetSType(sym)) )
END CanDeclarePointerToNilArray ;
(*
DeclarePointerToNilArray -
*)
PROCEDURE DeclarePointerToNilArray (sym: CARDINAL) ;
BEGIN
PreAddModGcc(sym, BuildPointerType(Mod2Gcc(GetSType(sym)))) ;
WatchIncludeList(sym, niltypedarrays)
END DeclarePointerToNilArray ;
(*
CanPromotePointerFully -
*)
PROCEDURE CanPromotePointerFully (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsPointer(sym) AND IsPartiallyOrFullyDeclared(GetSType(sym)) )
END CanPromotePointerFully ;
(*
PromotePointerFully -
*)
PROCEDURE PromotePointerFully (sym: CARDINAL) ;
BEGIN
WatchIncludeList(sym, fullydeclared)
END PromotePointerFully ;
(*
CompletelyResolved - returns TRUE if a symbols has been completely resolved
and is not partically declared (such as a record).
*)
PROCEDURE CompletelyResolved (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsElementInSet(GlobalGroup^.FullyDeclared, sym) )
END CompletelyResolved ;
(*
IsTypeQ - returns TRUE if all q(dependants) of, sym,
return TRUE.
*)
PROCEDURE IsTypeQ (sym: CARDINAL; q: IsAction) : BOOLEAN ;
BEGIN
IF IsVar(sym)
THEN
RETURN( IsVarDependants(sym, q) )
ELSIF IsEnumeration(sym)
THEN
RETURN( IsEnumerationDependants(sym, q) )
ELSIF IsFieldEnumeration(sym)
THEN
RETURN( TRUE )
ELSIF IsSubrange(sym)
THEN
RETURN( IsSubrangeDependants(sym, q) )
ELSIF IsPointer(sym)
THEN
RETURN( IsPointerDependants(sym, q) )
ELSIF IsRecord(sym)
THEN
RETURN( IsRecordDependants(sym, q) )
ELSIF IsRecordField(sym)
THEN
RETURN( IsRecordFieldDependants(sym, q) )
ELSIF IsVarient(sym)
THEN
RETURN( IsVarientDependants(sym, q) )
ELSIF IsFieldVarient(sym)
THEN
RETURN( IsVarientFieldDependants(sym, q) )
ELSIF IsArray(sym)
THEN
RETURN( IsArrayDependants(sym, q) )
ELSIF IsProcType(sym)
THEN
RETURN( IsProcTypeDependants(sym, q) )
ELSIF IsUnbounded(sym)
THEN
RETURN( IsUnboundedDependants(sym, q) )
ELSIF IsPartialUnbounded(sym)
THEN
InternalError ('should not be declaring a partial unbounded symbol')
ELSIF IsSet(sym)
THEN
RETURN( IsSetDependants(sym, q) )
ELSIF IsType(sym)
THEN
RETURN( IsTypeDependants(sym, q) )
ELSIF IsConst(sym)
THEN
RETURN( IsConstDependants(sym, q) )
ELSIF IsConstructor(sym) OR IsConstSet(sym)
THEN
(* sym can be a constructor, but at present we have not resolved whether
all dependants are constants.
*)
RETURN( IsConstructorDependants(sym, q) )
ELSIF IsProcedure(sym)
THEN
RETURN( IsProcedureDependants(sym, q) )
ELSE
RETURN( TRUE )
END
END IsTypeQ ;
(*
IsNilTypedArrays - returns TRUE if, sym, is dependant upon a NIL typed array
*)
PROCEDURE IsNilTypedArrays (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsElementInSet(GlobalGroup^.NilTypedArrays, sym) )
END IsNilTypedArrays ;
(*
IsFullyDeclared - returns TRUE if, sym, is fully declared.
*)
PROCEDURE IsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsElementInSet(GlobalGroup^.FullyDeclared, sym) )
END IsFullyDeclared ;
(*
AllDependantsFullyDeclared - returns TRUE if all dependants of,
sym, are declared.
*)
PROCEDURE AllDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsTypeQ(sym, IsFullyDeclared) )
END AllDependantsFullyDeclared ;
(*
NotAllDependantsFullyDeclared - returns TRUE if any dependants of,
sym, are not declared.
*)
PROCEDURE NotAllDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( NOT IsTypeQ(sym, IsFullyDeclared) )
END NotAllDependantsFullyDeclared ;
(*
IsPartiallyDeclared - returns TRUE if, sym, is partially declared.
*)
PROCEDURE IsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsElementInSet(GlobalGroup^.PartiallyDeclared, sym) )
END IsPartiallyDeclared ;
(*
AllDependantsPartiallyDeclared - returns TRUE if all dependants of,
sym, are partially declared.
*)
PROCEDURE AllDependantsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsTypeQ(sym, IsPartiallyDeclared) )
END AllDependantsPartiallyDeclared ;
(*
NotAllDependantsPartiallyDeclared - returns TRUE if any dependants of,
sym, are not partially declared.
*)
PROCEDURE NotAllDependantsPartiallyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( NOT IsTypeQ(sym, IsPartiallyDeclared) )
END NotAllDependantsPartiallyDeclared ;
(*
IsPartiallyOrFullyDeclared - returns TRUE if, sym, is partially or fully declared.
*)
PROCEDURE IsPartiallyOrFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsElementInSet(GlobalGroup^.PartiallyDeclared, sym) OR
IsElementInSet(GlobalGroup^.FullyDeclared, sym) )
END IsPartiallyOrFullyDeclared ;
(*
AllDependantsPartiallyOrFullyDeclared - returns TRUE if all dependants of,
sym, are partially or fully declared.
*)
PROCEDURE AllDependantsPartiallyOrFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsTypeQ(sym, IsPartiallyOrFullyDeclared) )
END AllDependantsPartiallyOrFullyDeclared ;
(*
NotAllDependantsPartiallyOrFullyDeclared - returns TRUE if all dependants of,
sym, are not partially and not fully
declared.
*)
(*
PROCEDURE NotAllDependantsPartiallyOrFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsTypeQ(sym, IsPartiallyOrFullyDeclared) )
END NotAllDependantsPartiallyOrFullyDeclared ;
*)
(*
TypeConstDependantsFullyDeclared - returns TRUE if sym is a constant or
type and its dependants are fully
declared.
*)
PROCEDURE TypeConstDependantsFullyDeclared (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( (NOT IsVar(sym)) AND
(NOT IsRecord(sym)) AND
(NOT IsParameter(sym)) AND
AllDependantsFullyDeclared(sym) )
END TypeConstDependantsFullyDeclared ;
(*
CanBeDeclaredViaPartialDependants - returns TRUE if this symbol
can be declared by partial
dependants. Such a symbol must
be a record, proctype or
an array.
*)
PROCEDURE CanBeDeclaredViaPartialDependants (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( (IsPointer(sym) OR IsProcType(sym)) AND
AllDependantsPartiallyOrFullyDeclared(sym) )
END CanBeDeclaredViaPartialDependants ;
(*
DeclareConstFully - will add, sym, to the fully declared list and
also remove it from the to do list. This is
called indirectly from M2GenGCC as it calculates
constants during quadruple processing.
*)
PROCEDURE DeclareConstFully (sym: CARDINAL) ;
BEGIN
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, todolist) ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, tobesolvedbyquads)
END DeclareConstFully ;
(*
PutToBeSolvedByQuads - places, sym, to this list and returns,
sym.
*)
PROCEDURE PutToBeSolvedByQuads (sym: CARDINAL) ;
BEGIN
WatchIncludeList(sym, tobesolvedbyquads)
END PutToBeSolvedByQuads ;
(*
DeclareTypeConstFully - declare the GCC type and add the double
book keeping entry.
*)
PROCEDURE DeclareTypeConstFully (sym: CARDINAL) ;
VAR
t: tree ;
BEGIN
IF NOT IsElementInSet(GlobalGroup^.ToBeSolvedByQuads, sym)
THEN
IF IsModule(sym) OR IsDefImp(sym)
THEN
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, todolist)
ELSIF IsProcedure(sym)
THEN
DeclareProcedureToGcc(sym) ;
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, todolist)
ELSE
t := TypeConstFullyDeclared(sym) ;
IF t#NIL
THEN
(* add relationship between gccsym and sym *)
PreAddModGcc(sym, t) ;
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, heldbyalignment) ;
WatchRemoveList(sym, finishedalignment) ;
WatchRemoveList(sym, todolist)
END
END
END
END DeclareTypeConstFully ;
(*
DeclareTypeFromPartial - declare the full GCC type from a partial type
and add the double book keeping entry.
*)
PROCEDURE DeclareTypeFromPartial (sym: CARDINAL) ;
VAR
t: tree ;
BEGIN
t := CompleteDeclarationOf(sym) ;
IF t=NIL
THEN
InternalError ('expecting to be able to create a gcc type')
ELSE
AddModGcc(sym, t) ;
WatchIncludeList(sym, fullydeclared) ;
WatchRemoveList(sym, partiallydeclared)
END
END DeclareTypeFromPartial ;
(*
CanBeDeclaredPartiallyViaPartialDependants - returns TRUE if, sym,
can be partially declared via
another partially declared type.
*)
PROCEDURE CanBeDeclaredPartiallyViaPartialDependants (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( IsType(sym) AND AllDependantsPartiallyDeclared(sym) )
END CanBeDeclaredPartiallyViaPartialDependants ;
(*
EmitCircularDependencyError - issue a dependency error.
*)
PROCEDURE EmitCircularDependencyError (sym: CARDINAL) ;
BEGIN
(* Ensure we only issue one dependency message per symbol for this
error classification. *)
IF NOT IsElementInSet (ErrorDepList, sym)
THEN
IncludeElementIntoSet (ErrorDepList, sym) ;
IF IsVar (sym) OR IsParameter (sym)
THEN
MetaError1 ('circular dependency error found when trying to resolve {%1Had}',
sym)
ELSE
MetaError1 ('circular dependency error found when trying to resolve {%1Dad}',
sym)
END
END
END EmitCircularDependencyError ;
TYPE
Rule = (norule, partialtype, arraynil, pointernilarray, arraypartial,
pointerfully, recordkind, recordfully, typeconstfully,
pointerfrompartial, typefrompartial, partialfrompartial,
partialtofully, circulartodo, circularpartial, circularniltyped) ;
VAR
bodyp : WalkAction ;
bodyq : IsAction ;
bodyt : ListType ;
bodyr : Rule ;
recursionCaught,
oneResolved,
noMoreWritten : BOOLEAN ;
(*
WriteRule - writes out the name of the rule.
*)
PROCEDURE WriteRule ;
BEGIN
IF Debugging
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')
ELSE
InternalError ('unknown rule')
END
END
END WriteRule ;
(*
Body -
*)
PROCEDURE Body (sym: CARDINAL) ;
BEGIN
IF bodyq (sym)
THEN
WatchRemoveList (sym, bodyt) ;
bodyp (sym) ;
(* The bodyp (sym) procedure function might have replaced sym into the set. *)
IF NOT IsElementInSet (LookupSet (bodyt), sym)
THEN
noMoreWritten := FALSE ;
oneResolved := TRUE
END
END
END Body ;
(*
ForeachTryDeclare - while q (of one sym in set t) is true
for each symbol in set t,
if q (sym)
then
p (sym)
end
end
end
*)
PROCEDURE ForeachTryDeclare (t: ListType; r: Rule;
q: IsAction; p: WalkAction) : BOOLEAN ;
BEGIN
IF recursionCaught
THEN
InternalError ('caught recursive cycle in ForeachTryDeclare')
END ;
bodyt := t ;
bodyq := q ;
bodyp := p ;
bodyr := r ;
recursionCaught := TRUE ;
oneResolved := FALSE ;
REPEAT
noMoreWritten := TRUE ;
ForeachElementInSetDo (LookupSet (t), Body)
UNTIL noMoreWritten ;
bodyr := norule ;
recursionCaught := FALSE ;
RETURN( oneResolved )
END ForeachTryDeclare ;
(*
DeclaredOutandingTypes - writes out any types that have their
dependants solved. It returns TRUE if
all outstanding types have been written.
*)
PROCEDURE DeclaredOutstandingTypes (ForceComplete: BOOLEAN) : BOOLEAN ;
VAR
finished: BOOLEAN ;
copy : Group ;
BEGIN
copy := NIL ;
finished := FALSE ;
REPEAT
IF Progress AND (copy # NIL)
THEN
IF NOT EqualGroup (copy, GlobalGroup)
THEN
DebugSetNumbers ;
DebugSets
END
END ;
copy := DupGroup (copy) ;
IF ForeachTryDeclare (todolist,
partialtype,
CanDeclareTypePartially,
DeclareTypePartially)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (todolist,
arraynil,
CanDeclareArrayAsNil,
DeclareArrayAsNil)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (todolist,
pointernilarray,
CanDeclarePointerToNilArray,
DeclarePointerToNilArray)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (niltypedarrays,
arraypartial,
CanDeclareArrayPartially,
DeclareArrayPartially)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (niltypedarrays,
pointerfully,
CanPromotePointerFully,
PromotePointerFully)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (heldbyalignment,
recordkind,
CanDeclareRecordKind,
DeclareRecordKind)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (finishedalignment,
recordfully,
CanDeclareRecord,
FinishDeclareRecord)
THEN
(* continue looping *)
ELSIF ForeachTryDeclare (todolist,
typeconstfully,
TypeConstDependantsFullyDeclared,
DeclareTypeConstFully)
THEN
(* Continue looping. *)
ELSIF ForeachTryDeclare (todolist,
typefrompartial,
CanBeDeclaredViaPartialDependants,
DeclareTypeFromPartial)
THEN
(* Continue looping. *)
ELSIF ForeachTryDeclare (partiallydeclared,
partialfrompartial,
CanBeDeclaredPartiallyViaPartialDependants,
DeclareTypePartially)
THEN
(* Continue looping. *)
ELSIF ForeachTryDeclare (partiallydeclared,
partialtofully,
TypeConstDependantsFullyDeclared,
DeclareTypeConstFully)
THEN
(* Continue looping. *)
ELSE
(* Nothing left to do (and constants are resolved elsewhere). *)
finished := TRUE
END
UNTIL finished ;
KillGroup (copy) ;
IF ForceComplete
THEN
IF ForeachTryDeclare (todolist,
circulartodo,
NotAllDependantsFullyDeclared,
EmitCircularDependencyError)
THEN
ELSIF ForeachTryDeclare (partiallydeclared,
circularpartial,
NotAllDependantsPartiallyDeclared,
EmitCircularDependencyError)
THEN
ELSIF ForeachTryDeclare (niltypedarrays,
circularniltyped,
NotAllDependantsPartiallyDeclared,
EmitCircularDependencyError)
THEN
END
END ;
RETURN NoOfElementsInSet (GlobalGroup^.ToDoList) = 0
END DeclaredOutstandingTypes ;
(*
CompleteDeclarationOf - returns the GCC Tree for, sym, if it can
be created from partially or fully declared
dependents.
*)
PROCEDURE CompleteDeclarationOf (sym: CARDINAL) : tree ;
BEGIN
IF IsArray(sym)
THEN
RETURN( DeclareArray(sym) )
ELSIF IsProcType(sym)
THEN
RETURN( DeclareProcType(sym) )
ELSIF IsRecordField(sym)
THEN
RETURN( DeclareRecordField(sym) )
ELSIF IsPointer(sym)
THEN
RETURN( DeclarePointer(sym) )
ELSE
RETURN( NIL )
END
END CompleteDeclarationOf ;
(*
DeclareType - here a type has been created via TYPE foo = bar,
we must tell GCC about it.
*)
PROCEDURE DeclareType (sym: CARDINAL) : tree ;
VAR
t : tree ;
location: location_t ;
BEGIN
IF GetSType(sym)=NulSym
THEN
MetaError1('base type {%1Ua} not understood', sym) ;
InternalError ('base type should have been declared')
ELSE
IF GetSymName(sym)=NulName
THEN
RETURN( tree(Mod2Gcc(GetSType(sym))) )
ELSE
location := TokenToLocation(GetDeclaredMod(sym)) ;
IF GccKnowsAbout(sym)
THEN
t := Mod2Gcc(sym)
ELSE
(* 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 )
END
END
END DeclareType ;
(*
DeclareIntegerConstant - declares an integer constant.
*)
(*
PROCEDURE DeclareIntegerConstant (sym: CARDINAL; value: INTEGER) ;
BEGIN
PreAddModGcc(sym, BuildIntegerConstant(value)) ;
WatchRemoveList(sym, todolist) ;
WatchIncludeList(sym, fullydeclared)
END DeclareIntegerConstant ;
*)
(*
DeclareIntegerFromTree - declares an integer constant from a Tree, value.
*)
PROCEDURE DeclareConstantFromTree (sym: CARDINAL; value: tree) ;
BEGIN
PreAddModGcc(sym, value) ;
WatchRemoveList(sym, todolist) ;
WatchIncludeList(sym, fullydeclared)
END DeclareConstantFromTree ;
(*
DeclareCharConstant - declares a character constant.
*)
PROCEDURE DeclareCharConstant (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
location: location_t ;
BEGIN
Assert (IsConstStringKnown (sym)) ;
location := TokenToLocation(tokenno) ;
PreAddModGcc(sym, BuildCharConstant(location, KeyToCharStar(GetString(sym)))) ;
WatchRemoveList(sym, todolist) ;
WatchIncludeList(sym, fullydeclared)
END DeclareCharConstant ;
(*
DeclareStringConstant - declares a string constant the sym will be known.
*)
PROCEDURE DeclareStringConstant (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
symtree : tree ;
BEGIN
Assert (IsConstStringKnown (sym)) ;
IF IsConstStringM2nul (sym) OR IsConstStringCnul (sym)
THEN
(* in either case the string needs a nul terminator. If the string
is a C variant it will already have had any escape characters applied.
The BuildCStringConstant only adds the nul terminator. *)
symtree := BuildCStringConstant (KeyToCharStar (GetString (sym)),
GetStringLength (tokenno, sym))
ELSE
symtree := BuildStringConstant (KeyToCharStar (GetString (sym)),
GetStringLength (tokenno, sym))
END ;
PreAddModGcc (sym, symtree) ;
WatchRemoveList (sym, todolist) ;
WatchIncludeList (sym, fullydeclared)
END DeclareStringConstant ;
(*
PromoteToString - declare, sym, and then promote it to a string.
Note that if sym is a single character we do
*not* record it as a string
but as a char however we always
return a string constant.
*)
PROCEDURE PromoteToString (tokenno: CARDINAL; sym: CARDINAL) : tree ;
VAR
size: CARDINAL ;
ch : CHAR ;
BEGIN
DeclareConstant (tokenno, sym) ;
IF IsConst (sym) AND (GetSType (sym) = Char)
THEN
PushValue (sym) ;
ch := PopChar (tokenno) ;
RETURN BuildCStringConstant (string (InitStringChar (ch)), 1)
ELSE
Assert (IsConstStringKnown (sym)) ;
size := GetStringLength (tokenno, sym) ;
IF size > 1
THEN
(* It will be already be declared as a string, so return it. *)
RETURN tree (Mod2Gcc (sym))
ELSE
RETURN BuildStringConstant (KeyToCharStar (GetString (sym)),
GetStringLength (tokenno, sym))
END
END
END PromoteToString ;
(*
PromoteToCString - declare, sym, and then promote it to a string.
Note that if sym is a single character we do
*not* record it as a string
but as a char however we always
return a string constant.
*)
PROCEDURE PromoteToCString (tokenno: CARDINAL; sym: CARDINAL) : tree ;
VAR
size: CARDINAL ;
ch : CHAR ;
BEGIN
DeclareConstant (tokenno, sym) ;
Assert (IsConstStringKnown (sym)) ;
IF IsConst (sym) AND (GetSType (sym) = Char)
THEN
PushValue (sym) ;
ch := PopChar (tokenno) ;
RETURN BuildCStringConstant (string (InitStringChar (ch)), 1)
ELSE
size := GetStringLength (tokenno, sym) ;
RETURN BuildCStringConstant (KeyToCharStar (GetString (sym)),
size)
END
END PromoteToCString ;
(*
WalkConstructor - walks all dependants of, sym.
*)
PROCEDURE WalkConstructor (sym: CARDINAL; p: WalkAction) ;
VAR
type: CARDINAL ;
BEGIN
type := GetSType(sym) ;
IF type#NulSym
THEN
WalkDependants(type, p) ;
WalkConstructorDependants(sym, p)
END
END WalkConstructor ;
(*
DeclareConstructor - declares a constructor.
*)
PROCEDURE DeclareConstructor (tokenno: CARDINAL; quad: CARDINAL; sym: CARDINAL) ;
BEGIN
IF sym=NulSym
THEN
InternalError ('trying to declare the NulSym')
END ;
IF IsConstructor (sym) AND (NOT GccKnowsAbout (sym))
THEN
WalkConstructor (sym, TraverseDependants) ;
DeclareTypesConstantsProceduresInRange (GetScope (sym), quad, quad) ;
Assert (IsConstructorDependants (sym, IsFullyDeclared)) ;
PushValue (sym) ;
DeclareConstantFromTree (sym, PopConstructorTree (tokenno))
END
END DeclareConstructor ;
(*
TryDeclareConstructor - try and declare a constructor. If, sym, is a
constructor try and declare it, if we cannot
then enter it into the to do list.
*)
PROCEDURE TryDeclareConstructor (tokenno: CARDINAL; sym: CARDINAL) ;
BEGIN
IF sym#NulSym
THEN
IF IsConstructor(sym) AND (NOT GccKnowsAbout(sym))
THEN
WalkConstructor(sym, TraverseDependants) ;
IF NOT IsElementInSet(GlobalGroup^.ToBeSolvedByQuads, sym)
THEN
TryEvaluateValue(sym) ;
IF IsConstructorDependants(sym, IsFullyDeclared)
THEN
PushValue(sym) ;
DeclareConstantFromTree(sym, PopConstructorTree(tokenno))
END
END
END
END
END TryDeclareConstructor ;
(*
WalkConst - walks all dependants of, sym.
*)
PROCEDURE WalkConst (sym: CARDINAL; p: WalkAction) ;
VAR
type: CARDINAL ;
BEGIN
Assert (IsConst (sym)) ;
type := GetSType (sym) ;
IF type # NulSym
THEN
p (type)
END ;
IF IsConstSet (sym) OR IsConstructor (sym)
THEN
WalkConstructor (sym, p)
END
END WalkConst ;
(*
IsConstDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
*)
PROCEDURE IsConstDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
type: CARDINAL ;
BEGIN
Assert (IsConst (sym)) ;
type := GetSType (sym) ;
IF type # NulSym
THEN
IF NOT q (type)
THEN
RETURN FALSE
END
END ;
IF IsConstSet (sym) OR IsConstructor (sym)
THEN
RETURN IsConstructorDependants (sym, q)
END ;
RETURN IsValueSolved (sym)
END IsConstDependants ;
(*
TryDeclareConstant - try and declare a constant. If, sym, is a
constant try and declare it, if we cannot
then enter it into the to do list.
*)
PROCEDURE TryDeclareConstant (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
type: CARDINAL ;
BEGIN
TryDeclareConstructor(tokenno, sym) ;
IF IsConst(sym)
THEN
TraverseDependants(sym) ;
type := GetSType(sym) ;
IF (type#NulSym) AND (NOT CompletelyResolved(type))
THEN
TraverseDependants(sym) ;
RETURN
END ;
IF IsConstructor(sym) AND (NOT IsConstructorConstant(sym))
THEN
TraverseDependants(sym) ;
RETURN
END ;
IF (IsConstructor(sym) OR IsConstSet(sym)) AND (type=NulSym)
THEN
TraverseDependants(sym) ;
RETURN
END ;
IF IsElementInSet(GlobalGroup^.ToBeSolvedByQuads, sym)
THEN
(* we allow the above rules to be executed even if it is fully declared
so to ensure that types of compiler builtin constants (BitsetSize
etc) are fully declared.
However at this point if, sym, is fully declared we return
*)
IF IsFullyDeclared(sym)
THEN
RETURN
END ;
TraverseDependants(sym)
ELSE
TryDeclareConst(tokenno, sym)
END
END
END TryDeclareConstant ;
(*
IsAnyType - return TRUE if sym is any Modula-2 type.
*)
PROCEDURE IsAnyType (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN (IsRecord(sym) OR IsType(sym) OR IsRecordField(sym) OR
IsPointer(sym) OR IsArray(sym) OR IsSet (sym) OR IsEnumeration (sym) OR
IsPointer (sym))
END IsAnyType ;
(*
TryDeclareType - try and declare a type. If sym is a
type try and declare it, if we cannot
then enter it into the to do list.
*)
PROCEDURE TryDeclareType (type: CARDINAL) ;
BEGIN
IF (type#NulSym) AND IsAnyType (type)
THEN
TraverseDependants (type)
END
END TryDeclareType ;
(*
DeclareConstant - checks to see whether, sym, is a constant and
declares the constant to gcc.
*)
PROCEDURE DeclareConstant (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
type: CARDINAL ;
t : tree ;
BEGIN
IF IsConst(sym)
THEN
TraverseDependants(sym) ;
type := GetSType(sym) ;
Assert((type=NulSym) OR CompletelyResolved(type)) ;
Assert((NOT IsConstructor(sym)) OR IsConstructorConstant(sym)) ;
Assert((type#NulSym) OR (NOT (IsConstructor(sym) OR IsConstSet(sym)))) ;
t := DeclareConst(tokenno, sym) ;
Assert(t#NIL)
END
END DeclareConstant ;
(*
DeclareConstString -
*)
PROCEDURE DeclareConstString (tokenno: CARDINAL; sym: CARDINAL) : BOOLEAN ;
VAR
size: CARDINAL ;
BEGIN
IF IsConstStringKnown (sym)
THEN
size := GetStringLength (tokenno, sym) ;
IF size = 1
THEN
DeclareCharConstant (tokenno, sym)
ELSE
DeclareStringConstant (tokenno, sym)
END ;
RETURN TRUE
END ;
RETURN FALSE
END DeclareConstString ;
(*
TryDeclareConst - try to declare a const to gcc. If it cannot
declare the symbol it places it into the
todolist.
*)
PROCEDURE TryDeclareConst (tokenno: CARDINAL; sym: CARDINAL) ;
VAR
type: CARDINAL ;
BEGIN
IF NOT GccKnowsAbout(sym)
THEN
IF IsConstructor(sym) OR IsConstSet(sym)
THEN
WalkConstructorDependants(sym, TraverseDependants) ;
TryEvaluateValue(sym) ;
IF NOT IsConstructorDependants(sym, IsFullyDeclared)
THEN
TraverseDependants(sym) ;
RETURN
END ;
IF NOT IsConstructorConstant(sym)
THEN
RETURN
END
END ;
IF IsConstString(sym) AND IsConstStringKnown (sym)
THEN
IF DeclareConstString (tokenno, sym)
THEN
END
ELSIF IsValueSolved(sym)
THEN
PushValue(sym) ;
IF IsConstSet(sym)
THEN
DeclareConstantFromTree(sym, PopSetTree(tokenno))
ELSIF IsConstructor(sym)
THEN
DeclareConstantFromTree(sym, PopConstructorTree(tokenno))
ELSIF IsRealType (GetDType (sym)) OR IsRealN (GetDType (sym))
THEN
type := GetDType(sym) ;
DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopRealTree(), TRUE))
ELSIF IsComplexType(GetDType(sym))
THEN
type := GetDType(sym) ;
DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopComplexTree(), TRUE))
ELSE
IF GetSType(sym)=NulSym
THEN
type := ZType
ELSE
type := GetDType(sym)
END ;
DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopIntegerTree(), TRUE))
END
ELSE
TraverseDependants(sym)
END
END
END TryDeclareConst ;
(*
DeclareConst - declares a const to gcc and returns a Tree.
*)
PROCEDURE DeclareConst (tokenno: CARDINAL; sym: CARDINAL) : tree ;
VAR
type: CARDINAL ;
BEGIN
IF GccKnowsAbout(sym)
THEN
RETURN( Mod2Gcc(sym) )
END ;
IF IsConstructor(sym) OR IsConstSet(sym)
THEN
EvaluateValue(sym)
END ;
IF IsConstString(sym)
THEN
IF DeclareConstString (tokenno, sym)
THEN
END
ELSIF IsValueSolved(sym)
THEN
PushValue(sym) ;
IF IsConstSet(sym)
THEN
DeclareConstantFromTree(sym, PopSetTree(tokenno))
ELSIF IsConstructor(sym)
THEN
DeclareConstantFromTree(sym, PopConstructorTree(tokenno))
ELSIF IsRealType(GetDType(sym))
THEN
type := GetDType(sym) ;
DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopRealTree(), TRUE))
ELSIF IsComplexType(GetDType(sym))
THEN
type := GetDType(sym) ;
DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopComplexTree(), TRUE))
ELSE
IF GetSType(sym)=NulSym
THEN
type := ZType
ELSE
type := GetDType(sym)
END ;
DeclareConstantFromTree(sym, BuildConvert(TokenToLocation(tokenno), Mod2Gcc(type), PopIntegerTree(), TRUE))
END
END ;
IF GccKnowsAbout(sym)
THEN
RETURN( Mod2Gcc(sym) )
ELSE
RETURN( NIL )
END
END DeclareConst ;
(*
DeclareParameters -
*)
PROCEDURE DeclareParameters (sym: CARDINAL) ;
BEGIN
DeclareUnboundedProcedureParameters(sym)
END DeclareParameters ;
VAR
unboundedp: WalkAction ;
(*
WalkFamilyOfUnbounded -
*)
PROCEDURE WalkFamilyOfUnbounded (oaf: CARDINAL <* unused *> ; dim: CARDINAL <* unused *> ; unbounded: CARDINAL) ;
BEGIN
IF unbounded # NulSym
THEN
unboundedp (unbounded)
END
END WalkFamilyOfUnbounded ;
(*
WalkAssociatedUnbounded -
*)
PROCEDURE WalkAssociatedUnbounded (sym: CARDINAL; p: WalkAction) ;
VAR
oaf: CARDINAL ;
o : WalkAction ;
BEGIN
oaf := GetOAFamily(sym) ;
o := unboundedp ;
unboundedp := p ;
ForeachOAFamily (oaf, WalkFamilyOfUnbounded) ;
unboundedp := o
END WalkAssociatedUnbounded ;
(*
WalkDependants - walks through all dependants of, Sym,
calling, p, for each dependant.
*)
PROCEDURE WalkDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
WalkAssociatedUnbounded(sym, p) ;
IF IsComponent(sym)
THEN
WalkComponentDependants(sym, p)
ELSIF IsEnumeration(sym)
THEN
WalkEnumerationDependants(sym, p)
ELSIF IsSubrange(sym)
THEN
WalkSubrangeDependants(sym, p)
ELSIF IsPointer(sym)
THEN
WalkPointerDependants(sym, p)
ELSIF IsRecord(sym)
THEN
WalkRecordDependants(sym, p)
ELSIF IsVarient(sym)
THEN
WalkVarientDependants(sym, p)
ELSIF IsRecordField(sym)
THEN
WalkRecordFieldDependants(sym, p)
ELSIF IsFieldVarient(sym)
THEN
WalkVarientFieldDependants(sym, p)
ELSIF IsArray(sym)
THEN
WalkArrayDependants(sym, p)
ELSIF IsProcType(sym)
THEN
WalkProcTypeDependants(sym, p)
ELSIF IsUnbounded(sym)
THEN
WalkUnboundedDependants(sym, p)
ELSIF IsSet(sym)
THEN
WalkSetDependants(sym, p)
ELSIF IsType(sym)
THEN
WalkTypeDependants(sym, p)
ELSIF IsConst(sym)
THEN
WalkConst(sym, p)
ELSIF IsVar(sym)
THEN
WalkVarDependants(sym, p)
ELSIF IsProcedure(sym)
THEN
WalkProcedureDependants(sym, p)
END
END WalkDependants ;
(*
TraverseDependantsInner -
*)
PROCEDURE TraverseDependantsInner (sym: WORD) ;
BEGIN
IF (NOT IsElementInSet(GlobalGroup^.FullyDeclared, sym)) AND
(NOT IsElementInSet(GlobalGroup^.ToDoList, sym))
THEN
WatchIncludeList(sym, todolist)
END ;
IF NOT IsElementInSet(VisitedList, sym)
THEN
IncludeElementIntoSet(VisitedList, sym) ;
WalkDependants(sym, TraverseDependantsInner)
END
END TraverseDependantsInner ;
(*
TraverseDependants - walks, sym, dependants. But it checks
to see that, sym, is not on the
FullyDeclared and not on the ToDoList.
*)
PROCEDURE TraverseDependants (sym: WORD) ;
BEGIN
IF VisitedList=NIL
THEN
VisitedList := InitSet(1) ;
TraverseDependantsInner(sym) ;
VisitedList := KillSet(VisitedList)
ELSE
InternalError ('recursive call to TraverseDependants caught')
END
END TraverseDependants ;
(*
WalkTypeInfo - walks type, sym, and its dependants.
*)
PROCEDURE WalkTypeInfo (sym: WORD) ;
BEGIN
IF IsVarient(sym)
THEN
InternalError ('why have we reached here?')
ELSIF IsVar(sym)
THEN
WalkTypeInfo(GetSType(sym)) ;
IF GetVarBackEndType(sym)#NulSym
THEN
WalkTypeInfo(GetVarBackEndType(sym))
END
ELSIF IsAModula2Type(sym)
THEN
TraverseDependants(sym)
END
END WalkTypeInfo ;
(*
DeclareUnboundedProcedureParameters -
*)
PROCEDURE DeclareUnboundedProcedureParameters (sym: WORD) ;
VAR
param,
type,
p, i : CARDINAL ;
location : location_t ;
BEGIN
IF IsProcedure(sym)
THEN
p := NoOfParamAny (sym) ;
i := p ;
WHILE i>0 DO
IF IsUnboundedParamAny (sym, i)
THEN
param := GetNthParamAny (sym, i) ;
type := GetSType(param) ;
TraverseDependants(type) ;
IF GccKnowsAbout(type)
THEN
location := TokenToLocation(GetDeclaredMod(type)) ;
BuildTypeDeclaration(location, Mod2Gcc(type))
END
ELSE
param := GetNth(sym, i) ;
type := GetSType(param) ;
TraverseDependants(type)
END ;
DEC(i)
END
END
END DeclareUnboundedProcedureParameters ;
(*
WalkUnboundedProcedureParameters -
*)
PROCEDURE WalkUnboundedProcedureParameters (sym: WORD) ;
VAR
param,
type,
p, i: CARDINAL ;
BEGIN
IF IsProcedure (sym)
THEN
p := NoOfParamAny (sym) ;
i := p ;
WHILE i>0 DO
IF IsUnboundedParamAny (sym, i)
THEN
param := GetNthParamAny (sym, i)
ELSE
param := GetNth (sym, i)
END ;
type := GetSType (param) ;
WalkTypeInfo (type) ;
DEC (i)
END
END
END WalkUnboundedProcedureParameters ;
(*
WalkTypesInProcedure - walk all types in procedure, Sym.
*)
PROCEDURE WalkTypesInProcedure (sym: WORD) ;
BEGIN
ForeachLocalSymDo(sym, TraverseDependants)
END WalkTypesInProcedure ;
(*
WalkTypesInModule - declare all types in module, Sym, to GCC.
*)
PROCEDURE WalkTypesInModule (sym: WORD) ;
VAR
n: Name ;
BEGIN
IF Debugging
THEN
n := GetSymName(sym) ;
printf1('Declaring types in MODULE %a\n', n)
END ;
ForeachLocalSymDo(sym, WalkTypeInfo) ;
ForeachLocalSymDo(sym, WalkUnboundedProcedureParameters) ;
ForeachInnerModuleDo(sym, WalkTypesInModule)
END WalkTypesInModule ;
(*
IsRecordFieldDependants - returns TRUE if the record field
symbol, sym, p(dependants) all return TRUE.
*)
PROCEDURE IsRecordFieldDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
align: CARDINAL ;
final: BOOLEAN ;
BEGIN
final := TRUE ;
IF NOT q(GetSType(sym))
THEN
final := FALSE
END ;
align := GetAlignment(sym) ;
IF (align#NulSym) AND (NOT q(align))
THEN
final := FALSE
END ;
RETURN( final )
END IsRecordFieldDependants ;
(*
GetModuleWhereDeclared - returns the module where, Sym, was created.
*)
PROCEDURE GetModuleWhereDeclared (sym: CARDINAL) : CARDINAL ;
VAR
s: CARDINAL ;
BEGIN
s := GetScope(sym) ;
IF (s=NulSym) OR IsDefImp(s) OR
(IsModule(s) AND (GetScope(s)=NulSym))
THEN
RETURN( s )
ELSE
RETURN( GetModuleWhereDeclared(s) )
END
END GetModuleWhereDeclared ;
(*
IsPseudoProcFunc - returns TRUE if Sym is a pseudo function or procedure.
*)
PROCEDURE IsPseudoProcFunc (Sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN(
IsPseudoBaseProcedure(Sym) OR IsPseudoBaseFunction(Sym) OR
IsPseudoSystemFunction(Sym)
)
END IsPseudoProcFunc ;
(*
IsProcedureGccNested - returns TRUE if procedure, sym, will be considered
as nested by GCC.
This will occur if either its outer defining scope
is a procedure or is a module which is inside a
procedure.
*)
PROCEDURE IsProcedureGccNested (sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN(
IsProcedureNested(sym) OR
(IsModule(GetScope(sym)) AND IsModuleWithinProcedure(GetScope(sym)))
)
END IsProcedureGccNested ;
(*
IsExternal -
*)
PROCEDURE IsExternal (sym: CARDINAL) : BOOLEAN ;
VAR
mod: CARDINAL ;
BEGIN
Assert (NOT IsDefImp (sym)) ;
IF IsProcedure (sym) AND IsExtern (sym)
THEN
RETURN TRUE
END ;
mod := GetScope(sym) ;
REPEAT
IF mod=NulSym
THEN
RETURN( FALSE )
ELSIF IsDefImp(mod)
THEN
RETURN( mod#GetMainModule() )
END ;
mod := GetScope(mod)
UNTIL mod=NulSym ;
RETURN( FALSE )
END IsExternal ;
(*
IsExternalToWholeProgram - return TRUE if the symbol, sym, is external to the
sources that we have parsed.
*)
PROCEDURE IsExternalToWholeProgram (sym: CARDINAL) : BOOLEAN ;
VAR
mod: CARDINAL ;
BEGIN
mod := GetScope(sym) ;
REPEAT
IF mod=NulSym
THEN
RETURN( FALSE )
ELSIF IsDefImp(mod)
THEN
(* return TRUE if we have no source file. *)
RETURN( GetModuleFile(mod)=NIL )
END ;
mod := GetScope(mod)
UNTIL mod=NulSym ;
RETURN( FALSE )
END IsExternalToWholeProgram ;
(*
DeclareProcedureToGccWholeProgram -
*)
PROCEDURE DeclareProcedureToGccWholeProgram (Sym: CARDINAL) ;
VAR
returnType,
GccParam : tree ;
scope,
Variable,
p, i : CARDINAL ;
b, e : CARDINAL ;
begin, end,
location : location_t ;
BEGIN
IF (NOT GccKnowsAbout(Sym)) AND (NOT IsPseudoProcFunc(Sym))
THEN
BuildStartFunctionDeclaration(UsesVarArgs(Sym)) ;
p := NoOfParamAny (Sym) ;
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)
THEN
GccParam := BuildParameterDeclaration(location,
KeyToCharStar(GetSymName(Variable)),
Mod2Gcc(GetLType(Variable)),
FALSE)
ELSE
GccParam := BuildParameterDeclaration(location,
KeyToCharStar(GetSymName(Variable)),
Mod2Gcc(GetLType(Variable)),
IsVarParamAny (Sym, i))
END ;
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
THEN
returnType := NIL
ELSE
returnType := Mod2Gcc(GetSType(Sym))
END ;
PreAddModGcc(Sym, BuildEndFunctionDeclaration(begin, end,
KeyToCharStar(GetFullSymName(Sym)),
returnType,
IsExternalToWholeProgram(Sym),
IsProcedureGccNested(Sym),
IsExported(GetModuleWhereDeclared(Sym), Sym),
IsProcedureAnyNoReturn(Sym))) ;
PopBinding(scope) ;
WatchRemoveList(Sym, todolist) ;
WatchIncludeList(Sym, fullydeclared)
END
END DeclareProcedureToGccWholeProgram ;
(*
DeclareProcedureToGccSeparateProgram -
*)
PROCEDURE DeclareProcedureToGccSeparateProgram (Sym: CARDINAL) ;
VAR
returnType,
GccParam : tree ;
scope,
Variable,
p, i : CARDINAL ;
b, e : CARDINAL ;
begin, end,
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) ;
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)
THEN
GccParam := BuildParameterDeclaration(location,
KeyToCharStar(GetSymName(Variable)),
Mod2Gcc(GetLType(Variable)),
FALSE)
ELSE
GccParam := BuildParameterDeclaration(location,
KeyToCharStar(GetSymName(Variable)),
Mod2Gcc(GetLType(Variable)),
IsVarParamAny (Sym, i))
END ;
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
THEN
returnType := NIL
ELSE
returnType := Mod2Gcc(GetSType(Sym))
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)
END
END DeclareProcedureToGccSeparateProgram ;
(*
DeclareProcedureToGcc - traverses all parameters and interfaces to gm2gcc.
*)
PROCEDURE DeclareProcedureToGcc (sym: CARDINAL) ;
BEGIN
IF sym # NulSym
THEN
IF WholeProgram
THEN
DeclareProcedureToGccWholeProgram (sym)
ELSE
DeclareProcedureToGccSeparateProgram (sym)
END
END
END DeclareProcedureToGcc ;
(*
DeclareProcedure - declares procedure, sym, or all procedures inside
module sym.
*)
PROCEDURE DeclareProcedure (sym: WORD) ;
BEGIN
IF IsProcedure(sym)
THEN
DeclareProcedureToGcc(sym)
ELSIF IsModule(sym) OR IsDefImp(sym)
THEN
ForeachProcedureDo(sym, DeclareProcedure)
ELSE
InternalError ('expecting procedure')
END
END DeclareProcedure ;
(*
FoldConstants - a wrapper for ResolveConstantExpressions.
*)
PROCEDURE FoldConstants (bb: BasicBlock) ;
BEGIN
IF ResolveConstantExpressions (DeclareConstFully, bb)
THEN
ConstantResolved := TRUE
END
END FoldConstants ;
(*
ActivateWatch - activate a watch for any symbol (lista xor listb).
*)
PROCEDURE ActivateWatch (lista, listb: Set) ;
VAR
smallest,
largest : Set ;
n, sym : CARDINAL ;
BEGIN
IF NoOfElementsInSet (lista) # NoOfElementsInSet (listb)
THEN
IF NoOfElementsInSet (lista) > NoOfElementsInSet (listb)
THEN
largest := lista ;
smallest := listb
ELSE
largest := listb ;
smallest := lista
END ;
printf0 ("adding the following symbols to the watch list as the declarator has detected an internal bug: ") ;
sym := 1 ;
n := FinalSymbol () ;
WHILE sym <= n DO
IF (IsElementInSet (largest, sym) AND (NOT IsElementInSet (smallest, sym))) OR
((NOT IsElementInSet (largest, sym)) AND IsElementInSet (smallest, sym))
THEN
AddSymToWatch (sym) ;
printf1 ("%d ", sym)
END ;
INC (sym)
END ;
printf0 ("\n")
END
END ActivateWatch ;
(*
DeclareTypesConstantsProceduresInRange -
*)
PROCEDURE DeclareTypesConstantsProceduresInRange (scope, start, end: CARDINAL) ;
CONST
DebugLoop = 1000 ;
VAR
copy: Group ;
loop: CARDINAL ;
sb : ScopeBlock ;
bb : BasicBlock ;
BEGIN
IF TraceQuadruples
THEN
DisplayQuadRange (scope, start, end)
END ;
loop := 0 ;
copy := NIL ;
sb := InitScopeBlock (scope) ;
REPEAT
(* Throw away any unreachable quad. *)
bb := InitBasicBlocks (sb) ;
KillBasicBlocks (bb) ;
(* Now iterate over remaining quads in scope attempting to resolve constants. *)
copy := DupGroup (copy) ;
bb := InitBasicBlocks (sb) ;
ConstantResolved := FALSE ;
ForeachBasicBlockDo (bb, FoldConstants) ;
KillBasicBlocks (bb) ;
(* And now types. *)
IF DeclaredOutstandingTypes (FALSE)
THEN
END ;
IF loop = DebugLoop
THEN
IF TraceQuadruples
THEN
DisplayQuadRange (scope, start, end)
END ;
ActivateWatch (copy^.ToDoList, GlobalGroup^.ToDoList) ;
loop := 0
END ;
INC (loop)
UNTIL (NOT ConstantResolved) AND EqualGroup (copy, GlobalGroup) ;
KillGroup (copy) ;
bb := InitBasicBlocks (sb) ;
KillBasicBlocks (bb) ;
KillScopeBlock (sb)
END DeclareTypesConstantsProceduresInRange ;
(*
SkipModuleScope - skips all module scopes for, scope.
It returns either NulSym or a procedure sym.
*)
PROCEDURE SkipModuleScope (scope: CARDINAL) : CARDINAL ;
BEGIN
IF (scope=NulSym) OR IsProcedure(scope)
THEN
RETURN( scope )
ELSE
RETURN( SkipModuleScope(GetScope(scope)) )
END
END SkipModuleScope ;
(*
PushBinding -
*)
PROCEDURE PushBinding (scope: CARDINAL) ;
BEGIN
scope := SkipModuleScope(scope) ;
IF scope=NulSym
THEN
pushGlobalScope
ELSE
pushFunctionScope(Mod2Gcc(scope))
END
END PushBinding ;
(*
PopBinding -
*)
PROCEDURE PopBinding (scope: CARDINAL) ;
BEGIN
scope := SkipModuleScope(scope) ;
IF scope=NulSym
THEN
popGlobalScope
ELSE
Assert(IsProcedure(scope)) ;
finishFunctionDecl(TokenToLocation(GetDeclaredMod(scope)), Mod2Gcc(scope)) ;
Assert (popFunctionScope () # NIL)
END
END PopBinding ;
(*
DeclareTypesConstantsProcedures -
*)
PROCEDURE DeclareTypesConstantsProcedures (scope: CARDINAL) ;
VAR
copy: Group ;
sb : ScopeBlock ;
BEGIN
IF Debugging
THEN
printf0 ("declaring types constants in: ") ; PrintTerse (scope)
END ;
copy := NIL ;
sb := InitScopeBlock (scope) ;
PushBinding (scope) ;
REPEAT
copy := DupGroup (copy) ;
ForeachScopeBlockDo3 (sb, DeclareTypesConstantsProceduresInRange)
UNTIL EqualGroup (copy, GlobalGroup) ;
KillGroup (copy) ;
PopBinding (scope) ;
KillScopeBlock (sb)
END DeclareTypesConstantsProcedures ;
(*
AssertAllTypesDeclared - asserts that all types for variables are declared in, scope.
*)
PROCEDURE AssertAllTypesDeclared (scope: CARDINAL) ;
VAR
n, Var: CARDINAL ;
failed: BOOLEAN ;
BEGIN
failed := FALSE ;
n := 1 ;
Var := GetNth(scope, n) ;
WHILE Var#NulSym DO
IF NOT TypeDependentsDeclared (Var, TRUE)
THEN
failed := TRUE
END ;
INC(n) ;
Var := GetNth(scope, n)
END ;
IF failed
THEN
FlushErrors
END
END AssertAllTypesDeclared ;
(*
DeclareModuleInit - declare all the ctor related functions within
a module.
*)
PROCEDURE DeclareModuleInit (moduleSym: WORD) ;
VAR
ctor, init, fini, dep: CARDINAL ;
BEGIN
GetModuleCtors (moduleSym, ctor, init, fini, dep) ;
DeclareProcedureToGcc (ctor) ;
DeclareProcedureToGcc (init) ;
DeclareProcedureToGcc (fini) ;
DeclareProcedureToGcc (dep)
END DeclareModuleInit ;
(*
StartDeclareProcedureScope -
*)
PROCEDURE StartDeclareProcedureScope (scope: CARDINAL) ;
BEGIN
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)
END StartDeclareProcedureScope ;
(*
StartDeclareModuleScopeSeparate -
*)
PROCEDURE StartDeclareModuleScopeSeparate (scope: CARDINAL) ;
BEGIN
IF scope=GetMainModule()
THEN
ForeachModuleDo(WalkTypesInModule) ; (* will populate the TYPE and CONST ToDo list *)
DeclareTypesConstantsProcedures(scope) ; (* will resolved TYPEs and CONSTs on the ToDo *)
(* lists. *)
ForeachModuleDo(DeclareProcedure) ;
(* Now that all types have been resolved it is safe to declare
variables. *)
AssertAllTypesDeclared(scope) ;
DeclareGlobalVariables(scope) ;
ForeachImportedDo(scope, DeclareImportedVariables) ;
(* Now it is safe to declare all procedures. *)
ForeachProcedureDo(scope, DeclareProcedure) ;
ForeachInnerModuleDo(scope, WalkTypesInModule) ;
ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ;
ForeachInnerModuleDo(scope, StartDeclareScope) ;
DeclareModuleInit(scope)
ELSE
DeclareTypesConstantsProcedures(scope) ;
AssertAllTypesDeclared(scope) ;
ForeachProcedureDo(scope, DeclareProcedure) ;
DeclareModuleInit(scope) ;
ForeachInnerModuleDo(scope, StartDeclareScope)
END
END StartDeclareModuleScopeSeparate ;
(*
StartDeclareModuleScopeWholeProgram -
*)
PROCEDURE StartDeclareModuleScopeWholeProgram (scope: CARDINAL) ;
BEGIN
IF IsSourceSeen(scope)
THEN
ForeachModuleDo(WalkTypesInModule) ; (* will populate the TYPE and CONST ToDo list *)
DeclareTypesConstantsProcedures(scope) ; (* will resolved TYPEs and CONSTs on the ToDo *)
(* lists. *)
ForeachModuleDo(DeclareProcedure) ;
ForeachModuleDo(DeclareModuleInit) ;
(* Now that all types have been resolved it is safe to declare
variables. *)
AssertAllTypesDeclared(scope) ;
DeclareGlobalVariablesWholeProgram(scope) ;
ForeachImportedDo(scope, DeclareImportedVariablesWholeProgram) ;
(* Now it is safe to declare all procedures. *)
ForeachProcedureDo(scope, DeclareProcedure) ;
ForeachInnerModuleDo(scope, WalkTypesInModule) ;
ForeachInnerModuleDo(scope, DeclareTypesConstantsProcedures) ;
ForeachInnerModuleDo(scope, StartDeclareScope) ;
DeclareModuleInit(scope)
ELSE
DeclareTypesConstantsProcedures(scope) ;
AssertAllTypesDeclared(scope) ;
ForeachProcedureDo(scope, DeclareProcedure) ;
DeclareModuleInit(scope) ;
ForeachInnerModuleDo(scope, StartDeclareScope)
END
END StartDeclareModuleScopeWholeProgram ;
(*
StartDeclareModuleScope -
*)
PROCEDURE StartDeclareModuleScope (scope: CARDINAL) ;
BEGIN
IF WholeProgram
THEN
StartDeclareModuleScopeWholeProgram(scope)
ELSE
StartDeclareModuleScopeSeparate(scope)
END
END StartDeclareModuleScope ;
(*
StartDeclareScope - declares types, variables associated with this scope.
*)
PROCEDURE StartDeclareScope (scope: CARDINAL) ;
VAR
n: Name ;
BEGIN
IF Debugging
THEN
n := GetSymName (scope) ;
printf1 ('declaring symbols in BLOCK %a\n', n)
END ;
IF IsProcedure (scope)
THEN
StartDeclareProcedureScope (scope)
ELSE
StartDeclareModuleScope (scope)
END ;
IF Debugging
THEN
n := GetSymName (scope) ;
printf1('\nEND declaring symbols in BLOCK %a\n', n)
END
END StartDeclareScope ;
(*
EndDeclareScope -
*)
PROCEDURE EndDeclareScope ;
BEGIN
(* no need to do anything *)
END EndDeclareScope ;
(*
IncludeDumpSymbol - include sym into the watch list and all syms dependants.
*)
PROCEDURE IncludeDumpSymbol (sym: CARDINAL) ;
BEGIN
IF sym # NulSym
THEN
AddSymToWatch (sym)
(*
fprintf0 (GetDumpFile (), "\n") ;
PrintVerbose (sym) ;
fprintf0 (GetDumpFile (), "\n")
*)
END
END IncludeDumpSymbol ;
(*
DumpResolver - dumps the m2 representation of sym.
*)
PROCEDURE DumpResolver (sym: CARDINAL) ;
BEGIN
fprintf1 (GetDumpFile (), "dump filtered symbol %d and dependants\n", sym) ;
PrintVerbose (sym) ;
END DumpResolver ;
(*
DumpFilteredResolver - dumps the gimple or tree representation of all watched symbols.
*)
PROCEDURE DumpFilteredResolver ;
BEGIN
ForeachElementInSetDo (WatchList, DumpResolver)
END DumpFilteredResolver ;
(*
DumpDefinitive - dumps the m2 and m2 gimple representation of sym.
*)
PROCEDURE DumpDefinitive (sym: CARDINAL) ;
VAR
fd: INTEGER ;
BEGIN
fprintf1 (GetDumpFile (), "\nm2 symbol synopsis: %d\n", sym) ;
PrintVerbose (sym) ;
IF GccKnowsAbout (sym)
THEN
fprintf1 (GetDumpFile (), "\nm2 gimple: %d", sym) ;
FIO.FlushBuffer (GetDumpFile ()) ;
fd := FIO.GetUnixFileDescriptor (GetDumpFile ()) ;
DumpGimpleFd (fd, Mod2Gcc (sym))
ELSE
fprintf1 (GetDumpFile (), "\nno m2 gimple for %d\n", sym)
END
END DumpDefinitive ;
(*
DumpFilteredDefinitive - dumps the gimple or tree representation of all watched symbols.
*)
PROCEDURE DumpFilteredDefinitive ;
BEGIN
ForeachElementInSetDo (WatchList, DumpDefinitive)
END DumpFilteredDefinitive ;
(*
PreAddModGcc - adds a relationship between sym and tree.
*)
PROCEDURE PreAddModGcc (sym: CARDINAL; tree: tree) ;
BEGIN
AddModGcc (sym, tree)
END PreAddModGcc ;
(*
DeclareDefaultType - declares a default type, sym, with, name.
*)
PROCEDURE DeclareDefaultType (sym: CARDINAL; name: ARRAY OF CHAR; gcctype: tree) ;
VAR
t : tree ;
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 *)
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.
*)
IF IsSubrange(sym)
THEN
GetSubrange(sym, high, low) ;
DeclareConstant(GetDeclaredMod(sym), high) ;
DeclareConstant(GetDeclaredMod(sym), low)
ELSIF IsSet(sym)
THEN
IF IsSubrange(GetSType(sym))
THEN
IF NOT GccKnowsAbout(GetSType(sym))
THEN
(* 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)
ELSIF IsEnumeration(GetSType(sym))
THEN
IF NOT GccKnowsAbout(GetSType(sym))
THEN
(* only true for internal types of course *)
InternalError ('enumeration type within the set type must be declared before the set type')
END
END
END
END DeclareDefaultType ;
(*
DeclareBoolean - declares the Boolean type together with true and false.
*)
PROCEDURE DeclareBoolean ;
BEGIN
AddModGcc(Boolean, GetBooleanType()) ;
AddModGcc(True, GetBooleanTrue()) ;
AddModGcc(False, GetBooleanFalse()) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, Boolean) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, True) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, False) ;
WalkAssociatedUnbounded(Boolean, TraverseDependants)
END DeclareBoolean ;
(*
DeclareFixedSizedType - declares the GNU Modula-2 fixed types
(if the back end support such a type).
*)
PROCEDURE DeclareFixedSizedType (name: ARRAY OF CHAR; type: CARDINAL; t: tree) ;
VAR
location : location_t ;
typetype,
low, high: CARDINAL ;
BEGIN
IF type#NulSym
THEN
IF IsSet(type) AND (NOT GccKnowsAbout(GetSType(type)))
THEN
typetype := GetSType(type) ;
GetSubrange(typetype, high, low) ;
DeclareConstant(GetDeclaredMod(type), high) ;
DeclareConstant(GetDeclaredMod(type), low) ;
location := TokenToLocation(GetDeclaredMod(typetype)) ;
PreAddModGcc(typetype, BuildSubrangeType(location,
KeyToCharStar(GetFullSymName(typetype)),
Mod2Gcc(GetSType(typetype)),
Mod2Gcc(low), Mod2Gcc(high))) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, typetype) ;
WalkAssociatedUnbounded(typetype, TraverseDependants)
END ;
(* gcc back end supports, type *)
DeclareDefaultType(type, name, t)
END
END DeclareFixedSizedType ;
(*
DeclareDefaultSimpleTypes - declares the simple types.
*)
PROCEDURE DeclareDefaultSimpleTypes ;
BEGIN
AddModGcc(ZType, GetM2ZType()) ;
AddModGcc(RType, GetM2RType()) ;
AddModGcc(CType, GetM2CType()) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, ZType) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, RType) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, CType) ;
DeclareDefaultType(Cardinal , "CARDINAL" , GetM2CardinalType()) ;
DeclareDefaultType(Integer , "INTEGER" , GetM2IntegerType()) ;
DeclareDefaultType(Char , "CHAR" , GetM2CharType()) ;
DeclareDefaultType(Loc , "LOC" , GetISOLocType()) ;
IF Iso
THEN
DeclareDefaultType(Byte , "BYTE" , GetISOByteType()) ;
DeclareDefaultType(Word , "WORD" , GetISOWordType())
ELSE
DeclareDefaultType(Byte , "BYTE" , GetByteType()) ;
DeclareDefaultType(Word , "WORD" , GetWordType())
END ;
DeclareDefaultType(Proc , "PROC" , GetProcType()) ;
DeclareDefaultType(Address , "ADDRESS" , GetPointerType()) ;
DeclareDefaultType(LongInt , "LONGINT" , GetM2LongIntType()) ;
DeclareDefaultType(LongCard , "LONGCARD" , GetM2LongCardType()) ;
DeclareDefaultType(ShortInt , "SHORTINT" , GetM2ShortIntType()) ;
DeclareDefaultType(ShortCard , "SHORTCARD" , GetM2ShortCardType()) ;
DeclareDefaultType(ShortReal , "SHORTREAL" , GetM2ShortRealType()) ;
DeclareDefaultType(Real , "REAL" , GetM2RealType()) ;
DeclareDefaultType(LongReal , "LONGREAL" , GetM2LongRealType()) ;
DeclareDefaultType(Bitnum , "BITNUM" , GetBitnumType()) ;
DeclareDefaultType(Bitset , "BITSET" , GetBitsetType()) ;
DeclareDefaultType(Complex , "COMPLEX" , GetM2ComplexType()) ;
DeclareDefaultType(LongComplex , "LONGCOMPLEX" , GetM2LongComplexType()) ;
DeclareDefaultType(ShortComplex, "SHORTCOMPLEX", GetM2ShortComplexType()) ;
DeclareDefaultType(CSizeT , "CSIZE_T" , GetCSizeTType()) ;
DeclareDefaultType(CSSizeT , "CSSIZE_T" , GetCSSizeTType()) ;
DeclareDefaultType(COffT , "COFF_T" , GetCOffTType()) ;
DeclareBoolean ;
DeclareFixedSizedType("INTEGER8" , IntegerN(8) , GetM2Integer8()) ;
DeclareFixedSizedType("INTEGER16" , IntegerN(16) , GetM2Integer16()) ;
DeclareFixedSizedType("INTEGER32" , IntegerN(32) , GetM2Integer32()) ;
DeclareFixedSizedType("INTEGER64" , IntegerN(64) , GetM2Integer64()) ;
DeclareFixedSizedType("CARDINAL8" , CardinalN(8) , GetM2Cardinal8()) ;
DeclareFixedSizedType("CARDINAL16", CardinalN(16), GetM2Cardinal16()) ;
DeclareFixedSizedType("CARDINAL32", CardinalN(32), GetM2Cardinal32()) ;
DeclareFixedSizedType("CARDINAL64", CardinalN(64), GetM2Cardinal64()) ;
DeclareFixedSizedType("WORD16" , WordN(16) , GetM2Word16()) ;
DeclareFixedSizedType("WORD32" , WordN(32) , GetM2Word32()) ;
DeclareFixedSizedType("WORD64" , WordN(64) , GetM2Word64()) ;
DeclareFixedSizedType("BITSET8" , SetN(8) , GetM2Bitset8()) ;
DeclareFixedSizedType("BITSET16" , SetN(16) , GetM2Bitset16()) ;
DeclareFixedSizedType("BITSET32" , SetN(32) , GetM2Bitset32()) ;
DeclareFixedSizedType("REAL32" , RealN(32) , GetM2Real32()) ;
DeclareFixedSizedType("REAL64" , RealN(64) , GetM2Real64()) ;
DeclareFixedSizedType("REAL96" , RealN(96) , GetM2Real96()) ;
DeclareFixedSizedType("REAL128" , RealN(128) , GetM2Real128()) ;
DeclareFixedSizedType("COMPLEX32" , ComplexN(32) , GetM2Complex32()) ;
DeclareFixedSizedType("COMPLEX64" , ComplexN(64) , GetM2Complex64()) ;
DeclareFixedSizedType("COMPLEX96" , ComplexN(96) , GetM2Complex96()) ;
DeclareFixedSizedType("COMPLEX128", ComplexN(128), GetM2Complex128())
END DeclareDefaultSimpleTypes ;
(*
DeclarePackedBoolean -
*)
PROCEDURE DeclarePackedBoolean ;
VAR
e: CARDINAL ;
BEGIN
e := GetPackedEquivalent(Boolean) ;
AddModGcc(e, GetPackedBooleanType()) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, e)
END DeclarePackedBoolean ;
(*
DeclarePackedDefaultSimpleTypes -
*)
PROCEDURE DeclarePackedDefaultSimpleTypes ;
BEGIN
DeclarePackedBoolean
END DeclarePackedDefaultSimpleTypes ;
(*
DeclareDefaultTypes - makes default types known to GCC
*)
PROCEDURE DeclareDefaultTypes ;
BEGIN
IF NOT HaveInitDefaultTypes
THEN
HaveInitDefaultTypes := TRUE ;
pushGlobalScope ;
DeclareDefaultSimpleTypes ;
DeclarePackedDefaultSimpleTypes ;
popGlobalScope
END
END DeclareDefaultTypes ;
(*
DeclareDefaultConstants - make default constants known to GCC
*)
PROCEDURE DeclareDefaultConstants ;
BEGIN
AddModGcc(Nil, GetPointerZero(BuiltinsLocation ())) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, Nil)
END DeclareDefaultConstants ;
(*
FindContext - returns the scope where the symbol
should be created.
Symbols created in a module will
return the global context tree, but symbols created
in a module which is declared inside
a procedure will return the procedure Tree.
*)
PROCEDURE FindContext (sym: CARDINAL) : tree ;
BEGIN
sym := GetProcedureScope(sym) ;
IF sym=NulSym
THEN
RETURN( GetGlobalContext() )
ELSE
RETURN( Mod2Gcc(sym) )
END
END FindContext ;
(*
IsEffectivelyImported - returns TRUE if symbol, Sym, was
effectively imported into ModSym.
*)
PROCEDURE IsEffectivelyImported (ModSym, sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN(
IsImported(ModSym, sym) OR
(IsImported(ModSym, GetModuleWhereDeclared(sym)) AND
IsExported(GetModuleWhereDeclared(sym), sym))
)
END IsEffectivelyImported ;
(*
FindOuterModule - returns the out most module where, sym,
was declared. It returns NulSym if the
symbol or the module was declared inside
a procedure.
*)
PROCEDURE FindOuterModule (sym: CARDINAL) : CARDINAL ;
BEGIN
sym := GetScope(sym) ;
WHILE (NOT IsDefImp(sym)) DO
IF IsModule(sym)
THEN
IF GetScope(sym)=NulSym
THEN
RETURN( sym )
ELSE
sym := GetScope(sym)
END
ELSIF IsProcedure(sym)
THEN
sym := GetScope(sym)
END
END ;
RETURN( sym )
END FindOuterModule ;
(*
DoVariableDeclaration - create a corresponding gcc variable and add the association
between the front end symbol var and the gcc tree.
*)
PROCEDURE DoVariableDeclaration (var: CARDINAL; name: ADDRESS;
isImported, isExported,
isTemporary, isGlobal: BOOLEAN;
scope: tree) ;
BEGIN
IF NOT (IsComponent (var) OR IsVarHeap (var))
THEN
IF TypeDependentsDeclared (var, TRUE)
THEN
PrepareGCCVarDeclaration (var, name, isImported, isExported,
isTemporary, isGlobal, scope)
END
END
END DoVariableDeclaration ;
(*
TypeDependentsDeclared - return TRUE if all type dependents of variable
have been declared.
*)
PROCEDURE TypeDependentsDeclared (variable: CARDINAL; errorMessage: BOOLEAN) : BOOLEAN ;
VAR
type: CARDINAL ;
BEGIN
type := GetSType (variable) ;
IF AllDependantsFullyDeclared (type)
THEN
RETURN TRUE
ELSE
IF errorMessage
THEN
EmitCircularDependencyError (variable) ;
ForeachElementInSetDo (GlobalGroup^.ToDoList, EmitCircularDependencyError)
END
END ;
RETURN FALSE
END TypeDependentsDeclared ;
(*
PrepareGCCVarDeclaration -
*)
PROCEDURE PrepareGCCVarDeclaration (var: CARDINAL; name: ADDRESS;
isImported, isExported,
isTemporary, isGlobal: BOOLEAN;
scope: tree) ;
VAR
type : tree ;
varType : CARDINAL ;
location: location_t ;
BEGIN
IF GetMode (var) = LeftValue
THEN
(*
There are two issues to deal with:
(i) LeftValue is really a pointer to GetSType (var), which is built
here.
(ii) Front end might have specified the back end use a particular
data type, in which case we use the specified type.
We do not add an extra pointer if this is the case.
*)
varType := SkipType (GetVarBackEndType (var)) ;
IF varType=NulSym
THEN
(* We have not explicity told back end the type, so build it. *)
varType := GetSType (var) ;
IF IsVariableAtAddress (var)
THEN
type := BuildConstPointerType (Mod2Gcc (varType))
ELSE
type := BuildPointerType (Mod2Gcc (varType))
END
ELSE
(* We have been requested to use varType. *)
type := Mod2Gcc (varType)
END ;
Assert (AllDependantsFullyDeclared (varType))
ELSE
type := Mod2Gcc (GetDType (var))
END ;
location := TokenToLocation (GetDeclaredMod (var)) ;
PreAddModGcc (var, DeclareKnownVariable (location,
name, type,
isExported, isImported, isTemporary,
isGlobal, scope, NIL)) ;
WatchRemoveList (var, todolist) ;
WatchIncludeList (var, fullydeclared)
END PrepareGCCVarDeclaration ;
(*
IsGlobal - is the variable not in a procedure scope.
*)
PROCEDURE IsGlobal (sym: CARDINAL) : BOOLEAN ;
VAR
s: CARDINAL ;
BEGIN
s := GetScope(sym) ;
WHILE (s#NulSym) AND (NOT IsDefImp (s)) AND (NOT IsModule (s)) DO
IF IsProcedure (s)
THEN
RETURN FALSE
END ;
s := GetScope (s)
END ;
RETURN TRUE
END IsGlobal ;
(*
DeclareVariable - declares a global variable to GCC.
*)
PROCEDURE DeclareVariable (ModSym, variable: CARDINAL) ;
VAR
scope: tree ;
decl : CARDINAL ;
BEGIN
IF NOT GccKnowsAbout (variable)
THEN
scope := FindContext (ModSym) ;
decl := FindOuterModule (variable) ;
PushBinding (ModSym) ;
DoVariableDeclaration (variable,
KeyToCharStar (GetFullSymName (variable)),
(* in Modula-2 we are allowed to import from ourselves, but we do not present this to GCC *)
IsEffectivelyImported(ModSym, variable) AND (GetMainModule () # decl),
IsExported(ModSym, variable),
IsTemporary (variable),
IsGlobal (variable),
scope) ;
PopBinding (ModSym)
END
END DeclareVariable ;
(*
DeclareVariableWholeProgram - declares a global variable to GCC when using -fm2-whole-program.
*)
PROCEDURE DeclareVariableWholeProgram (mainModule, variable: CARDINAL) ;
VAR
scope: tree ;
decl : CARDINAL ;
BEGIN
IF NOT GccKnowsAbout (variable)
THEN
scope := FindContext (mainModule) ;
decl := FindOuterModule (variable) ;
PushBinding (mainModule) ;
DoVariableDeclaration (variable,
KeyToCharStar (GetFullSymName (variable)),
(NOT IsSourceSeen (decl)) AND
IsEffectivelyImported (mainModule, variable) AND (GetMainModule () # decl),
IsExported (mainModule, variable),
IsTemporary (variable),
IsGlobal (variable),
scope) ;
PopBinding (mainModule)
END
END DeclareVariableWholeProgram ;
(*
DeclareGlobalVariablesWholeProgram -
*)
PROCEDURE DeclareGlobalVariablesWholeProgram (ModSym: CARDINAL) ;
VAR
n, Variable: CARDINAL ;
BEGIN
n := 1 ;
Variable := GetNth (ModSym, n) ;
WHILE Variable # NulSym DO
DeclareVariableWholeProgram (ModSym, Variable) ;
INC (n) ;
Variable := GetNth (ModSym, n)
END ;
ForeachInnerModuleDo(ModSym, DeclareGlobalVariablesWholeProgram)
END DeclareGlobalVariablesWholeProgram ;
(*
DeclareGlobalVariables - lists the Global variables for
Module ModSym together with their offset.
*)
PROCEDURE DeclareGlobalVariables (ModSym: CARDINAL) ;
VAR
n, Variable: CARDINAL ;
BEGIN
n := 1 ;
Variable := GetNth (ModSym, n) ;
WHILE Variable # NulSym DO
DeclareVariable (ModSym, Variable) ;
INC (n) ;
Variable := GetNth (ModSym, n)
END ;
ForeachInnerModuleDo (ModSym, DeclareGlobalVariables)
END DeclareGlobalVariables ;
(*
DeclareImportedVariables - declares all imported variables to GM2.
*)
PROCEDURE DeclareImportedVariables (sym: WORD) ;
BEGIN
IF IsVar (sym)
THEN
DeclareVariable (GetMainModule (), sym)
ELSIF IsDefImp (sym)
THEN
ForeachExportedDo (sym, DeclareImportedVariables)
END
END DeclareImportedVariables ;
(*
DeclareImportedVariablesWholeProgram - declares all imported variables.
*)
PROCEDURE DeclareImportedVariablesWholeProgram (sym: WORD) ;
BEGIN
IF IsVar (sym)
THEN
IF NOT IsSourceSeen (FindOuterModule (sym))
THEN
(* import is necessary, even for -fm2-whole-program as we
cannot see the source. *)
DeclareVariableWholeProgram (GetMainModule (), sym)
END
ELSIF IsDefImp (sym)
THEN
ForeachExportedDo (sym, DeclareImportedVariablesWholeProgram)
END
END DeclareImportedVariablesWholeProgram ;
(*
DeclareLocalVariable - declare a local variable var.
*)
PROCEDURE DeclareLocalVariable (var: CARDINAL) ;
BEGIN
DoVariableDeclaration (var,
KeyToCharStar (GetFullSymName (var)),
FALSE, (* local variables cannot be imported *)
FALSE, (* or exported *)
IsTemporary (var),
FALSE, (* and are not global *)
Mod2Gcc (GetScope (var)))
END DeclareLocalVariable ;
(*
DeclareLocalVariables - declares Local variables for procedure.
*)
PROCEDURE DeclareLocalVariables (procedure: CARDINAL) ;
VAR
i, var: CARDINAL ;
BEGIN
i := NoOfParamAny (procedure) + 1 ;
var := GetNth (procedure, i) ;
WHILE var # NulSym DO
Assert (procedure = GetScope (var)) ;
DeclareLocalVariable (var) ;
INC (i) ;
var := GetNth (procedure, i)
END
END DeclareLocalVariables ;
(*
DeclareModuleVariables - declares Module variables for a module
which was declared inside a procedure.
*)
PROCEDURE DeclareModuleVariables (sym: CARDINAL) ;
VAR
scope : tree ;
i, Var: CARDINAL ;
BEGIN
i := 1 ;
scope := Mod2Gcc (GetProcedureScope (sym)) ;
Var := GetNth (sym, i) ;
WHILE Var # NulSym DO
DoVariableDeclaration (Var,
KeyToCharStar (GetFullSymName (Var)),
FALSE, (* inner module variables cannot be imported *)
FALSE, (* or exported (as far as GCC is concerned) *)
IsTemporary (Var),
FALSE, (* and are not global *)
scope) ;
INC (i) ;
Var := GetNth (sym, i)
END
END DeclareModuleVariables ;
(*
DeclareFieldValue -
*)
PROCEDURE DeclareFieldValue (sym: CARDINAL; value: tree; VAR list: tree) : tree ;
VAR
location: location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
IF (GetModuleWhereDeclared(sym)=NulSym) OR
(GetModuleWhereDeclared(sym)=GetMainModule())
THEN
RETURN( BuildEnumerator(location, KeyToCharStar(GetSymName(sym)), value, list) )
ELSE
RETURN( BuildEnumerator(location, KeyToCharStar(GetFullScopeAsmName(sym)), value, list) )
END
END DeclareFieldValue ;
(*
DeclareFieldEnumeration - declares an enumerator within the current enumeration type.
*)
PROCEDURE DeclareFieldEnumeration (sym: WORD) : tree ;
VAR
type : CARDINAL ;
field,
enumlist: tree ;
BEGIN
(* add relationship between gccSym and sym *)
type := GetSType (sym) ;
enumlist := GetEnumList (type) ;
PushValue (sym) ;
field := DeclareFieldValue (sym, PopIntegerTree (), enumlist) ;
PutEnumList (type, enumlist) ;
RETURN field
END DeclareFieldEnumeration ;
(*
DeclareEnumeration - declare an enumerated type.
*)
PROCEDURE DeclareEnumeration (sym: WORD) : tree ;
VAR
enumlist,
gccenum : tree ;
location: location_t ;
BEGIN
location := TokenToLocation (GetDeclaredMod (sym)) ;
gccenum := BuildStartEnumeration (location, KeyToCharStar (GetFullSymName (sym)), FALSE) ;
enumlist := GetEnumList (sym) ;
RETURN BuildEndEnumeration (location, gccenum, enumlist)
END DeclareEnumeration ;
(*
DeclareSubrangeNarrow - will return cardinal, integer, or type depending on whether
low..high fits in the C data type.
*)
PROCEDURE DeclareSubrangeNarrow (location: location_t;
high, low: CARDINAL; type: tree) : tree ;
VAR
m2low, m2high,
lowtree,
hightree : tree ;
BEGIN
(* No zero alignment, therefore the front end will prioritize subranges to match
unsigned int, int, or ZTYPE assuming the low..high range fits. *)
lowtree := Mod2Gcc (low) ;
hightree := Mod2Gcc (high) ;
IF CompareTrees (lowtree, GetIntegerZero (location)) >= 0
THEN
(* low..high is always positive, can we use unsigned int? *)
m2high := GetMaxFrom (location, GetM2CardinalType ()) ;
IF CompareTrees (hightree, m2high) <= 0
THEN
RETURN GetM2CardinalType ()
END
ELSE
(* Must be a signed subrange base, can we use int? *)
m2high := GetMaxFrom (location, GetM2IntegerType ()) ;
m2low := GetMinFrom (location, GetM2IntegerType ()) ;
IF (CompareTrees (lowtree, m2low) >= 0) AND (CompareTrees (hightree, m2high) <= 0)
THEN
RETURN GetM2IntegerType ()
END
END ;
(* Fall back to the ZType. *)
RETURN type
END DeclareSubrangeNarrow ;
(*
DeclareSubrange - declare a subrange type.
*)
PROCEDURE DeclareSubrange (sym: CARDINAL) : tree ;
VAR
type,
gccsym : tree ;
align,
high, low: CARDINAL ;
location: location_t ;
BEGIN
location := TokenToLocation (GetDeclaredMod (sym)) ;
GetSubrange (sym, high, low) ;
align := GetAlignment (sym) ;
type := Mod2Gcc (GetSType (sym)) ;
IF align # NulSym
THEN
IF AreConstantsEqual (GetIntegerZero (location), Mod2Gcc (align))
THEN
type := BuildSmallestTypeRange (location, Mod2Gcc (low), Mod2Gcc (high))
ELSE
MetaError1 ('a non-zero alignment in a subrange type {%1Wa} is currently not implemented and will be ignored',
sym)
END
ELSIF GetSType (sym) = ZType
THEN
(* Can we narrow the ZType subrange to CARDINAL or INTEGER? *)
type := DeclareSubrangeNarrow (location, high, low, type)
END ;
gccsym := BuildSubrangeType (location,
KeyToCharStar (GetFullSymName (sym)),
type, Mod2Gcc (low), Mod2Gcc (high)) ;
RETURN gccsym
END DeclareSubrange ;
(*
IncludeGetNth -
*)
PROCEDURE IncludeGetNth (l: List; sym: CARDINAL) ;
VAR
i: CARDINAL ;
BEGIN
fprintf0 (GetDumpFile (), ' ListOfFields [') ;
i := 1 ;
WHILE GetNth (sym, i) # NulSym DO
IF i>1
THEN
fprintf0 (GetDumpFile (), ', ')
END ;
IncludeItemIntoList (l, GetNth(sym, i)) ;
PrintTerse (GetNth (sym, i)) ;
INC (i)
END ;
fprintf0 (GetDumpFile (), ']')
END IncludeGetNth ;
(*
IncludeType -
*)
PROCEDURE IncludeType (l: List; sym: CARDINAL) ;
VAR
t: CARDINAL ;
BEGIN
t := GetSType(sym) ;
IF t#NulSym
THEN
fprintf0 (GetDumpFile(), ' type [') ;
PrintTerse(t) ;
IncludeItemIntoList(l, t) ;
fprintf0 (GetDumpFile(), ']') ;
t := GetVarBackEndType(sym) ;
IF t#NulSym
THEN
fprintf0 (GetDumpFile(), ' gcc type [') ;
PrintTerse(t) ;
IncludeItemIntoList(l, t) ;
fprintf0 (GetDumpFile(), ']')
END
END
END IncludeType ;
(*
IncludeSubscript -
*)
PROCEDURE IncludeSubscript (l: List; sym: CARDINAL) ;
VAR
t: CARDINAL ;
BEGIN
t := GetArraySubscript(sym) ;
IF t#NulSym
THEN
fprintf0 (GetDumpFile(), ' subrange [') ;
PrintTerse(t) ;
IncludeItemIntoList(l, t) ;
fprintf0 (GetDumpFile(), ']') ;
END
END IncludeSubscript ;
(*
PrintLocalSymbol -
*)
PROCEDURE PrintLocalSymbol (sym: CARDINAL) ;
BEGIN
PrintTerse(sym) ; fprintf0 (GetDumpFile(), ', ')
END PrintLocalSymbol ;
(*
PrintLocalSymbols -
*)
PROCEDURE PrintLocalSymbols (sym: CARDINAL) ;
BEGIN
fprintf0 (GetDumpFile(), 'Local Symbols {') ;
ForeachLocalSymDo(sym, PrintLocalSymbol) ;
fprintf0 (GetDumpFile(), '}')
END PrintLocalSymbols ;
(*
IncludeGetVarient -
*)
PROCEDURE IncludeGetVarient (l: List; sym: CARDINAL) ;
BEGIN
IF GetVarient(sym)#NulSym
THEN
fprintf0 (GetDumpFile(), ' Varient [') ;
PrintTerse(GetVarient(sym)) ;
fprintf0 (GetDumpFile(), ']') ;
IncludeItemIntoList(l, GetVarient(sym))
END
END IncludeGetVarient ;
(*
IncludeUnbounded - includes the record component of an unbounded type.
*)
PROCEDURE IncludeUnbounded (l: List; sym: CARDINAL) ;
BEGIN
IF GetUnboundedRecordType(sym)#NulSym
THEN
IncludeItemIntoList(l, GetUnboundedRecordType(sym))
END
END IncludeUnbounded ;
(*
IncludePartialUnbounded - includes the type component of a partial unbounded symbol.
*)
PROCEDURE IncludePartialUnbounded (l: List; sym: CARDINAL) ;
BEGIN
IF GetSType(sym)#NulSym
THEN
IncludeItemIntoList(l, GetSType(sym))
END
END IncludePartialUnbounded ;
(*
PrintDeclared - prints out where, sym, was declared.
*)
PROCEDURE PrintDeclared (sym: CARDINAL) ;
VAR
filename: String ;
lineno,
tokenno : CARDINAL ;
BEGIN
tokenno := GetDeclaredMod(sym) ;
filename := FindFileNameFromToken(tokenno, 0) ;
lineno := TokenToLineNo(tokenno, 0) ;
fprintf2 (GetDumpFile (), " declared in %s:%d", filename, lineno)
END PrintDeclared ;
(*
PrintAlignment -
*)
PROCEDURE PrintAlignment (sym: CARDINAL) ;
VAR
align: CARDINAL ;
BEGIN
IF IsRecord(sym) OR IsType(sym) OR IsRecordField(sym) OR IsPointer(sym) OR IsArray(sym)
THEN
align := GetAlignment(sym) ;
IF align#NulSym
THEN
fprintf1 (GetDumpFile(), " aligned [%d]", align)
END
END
END PrintAlignment ;
(*
IncludeGetParent -
*)
PROCEDURE IncludeGetParent (l: List; sym: CARDINAL) ;
BEGIN
fprintf0 (GetDumpFile(), ' Parent [') ;
IncludeItemIntoList(l, GetParent(sym)) ;
PrintTerse(GetParent(sym)) ;
fprintf0 (GetDumpFile(), ']')
END IncludeGetParent ;
(*
PrintDecl -
*)
PROCEDURE PrintDecl (sym: CARDINAL) ;
BEGIN
IF IsDeclaredPackedResolved(sym)
THEN
IF IsDeclaredPacked(sym)
THEN
fprintf0 (GetDumpFile(), ' packed')
ELSE
fprintf0 (GetDumpFile(), ' unpacked')
END
ELSE
fprintf0 (GetDumpFile(), ' unknown if packed')
END
END PrintDecl ;
(*
PrintScope - displays the scope and line number of declaration of symbol, sym.
*)
PROCEDURE PrintScope (sym: CARDINAL) ;
VAR
name : Name ;
scope,
line : CARDINAL ;
BEGIN
line := TokenToLineNo (GetDeclaredMod (sym), 0) ;
scope := GetScope (sym) ;
name := GetSymName (scope) ;
fprintf3 (GetDumpFile (), ' scope %a:%d %d', name, line, scope)
END PrintScope ;
(*
PrintKind -
*)
PROCEDURE PrintKind (kind: ProcedureKind) ;
VAR
s: String ;
BEGIN
s := GetProcedureKindDesc (kind) ;
fprintf1 (GetDumpFile (), "%s", s) ;
s := KillString (s)
END PrintKind ;
(*
PrintProcedureParameters -
*)
PROCEDURE PrintProcedureParameters (sym: CARDINAL; kind: ProcedureKind) ;
VAR
typeName,
paramName: Name ;
p, i, n,
type : CARDINAL ;
BEGIN
fprintf0 (GetDumpFile (), ' (') ;
n := NoOfParam (sym, kind) ;
i := 1 ;
WHILE i <= n DO
IF i > 1
THEN
fprintf0 (GetDumpFile (), '; ')
END ;
IF IsVarParam (sym, kind, i)
THEN
fprintf0 (GetDumpFile (), 'VAR ')
END ;
p := GetNthParam (sym, kind, i) ;
paramName := GetSymName (p) ;
type := GetType (p) ;
typeName := GetSymName (type) ;
IF IsUnboundedParam (sym, kind, i)
THEN
fprintf2 (GetDumpFile (), '%a: ARRAY OF %a', paramName, typeName)
ELSE
fprintf2 (GetDumpFile (), '%a: %a', paramName, typeName)
END ;
INC (i)
END ;
fprintf0 (GetDumpFile (), ')')
END PrintProcedureParameters ;
(*
PrintProcedureReturnType -
*)
PROCEDURE PrintProcedureReturnType (sym: CARDINAL) ;
VAR
typeName: Name ;
BEGIN
IF GetType (sym) # NulSym
THEN
typeName := GetSymName (GetType (sym)) ;
fprintf1 (GetDumpFile (), ' : %a', typeName)
END ;
fprintf0 (GetDumpFile (), ' ;')
END PrintProcedureReturnType ;
(*
PrintProcedure -
*)
PROCEDURE PrintProcedure (sym: CARDINAL) ;
VAR
n : Name ;
kind: ProcedureKind ;
BEGIN
n := GetSymName (sym) ;
fprintf2 (GetDumpFile (), 'sym %d IsProcedure (%a)', sym, n);
IF IsProcedureReachable(sym)
THEN
fprintf0 (GetDumpFile(), ' IsProcedureReachable')
END ;
PrintScope (sym) ;
IF IsExtern (sym)
THEN
fprintf0 (GetDumpFile (), ' extern')
END ;
IF IsPublic (sym)
THEN
fprintf0 (GetDumpFile (), ' public')
END ;
IF IsCtor (sym)
THEN
fprintf0 (GetDumpFile (), ' ctor')
END ;
PrintDeclared (sym) ;
fprintf0 (GetDumpFile (), '\n') ;
FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO
fprintf0 (GetDumpFile (), 'parameters ') ;
PrintKind (kind) ;
IF GetProcedureParametersDefined (sym, kind)
THEN
fprintf0 (GetDumpFile (), ' defined') ;
PrintProcedureParameters (sym, kind) ;
PrintProcedureReturnType (sym)
ELSE
fprintf0 (GetDumpFile (), ' undefined')
END ;
fprintf0 (GetDumpFile (), '\n')
END ;
fprintf0 (GetDumpFile (), ' Associated proctype: ') ;
PrintProcType (GetProcedureProcType (sym))
END PrintProcedure ;
(*
PrintProcTypeParameters -
*)
PROCEDURE PrintProcTypeParameters (sym: CARDINAL) ;
VAR
typeName : Name ;
p, i, n,
type : CARDINAL ;
BEGIN
fprintf0 (GetDumpFile (), ' (') ;
n := NoOfParam (sym, ProperProcedure) ;
i := 1 ;
WHILE i <= n DO
IF i > 1
THEN
fprintf0 (GetDumpFile (), '; ')
END ;
IF IsVarParam (sym, ProperProcedure, i)
THEN
fprintf0 (GetDumpFile (), 'VAR ')
END ;
p := GetNthParam (sym, ProperProcedure, i) ;
type := GetType (p) ;
typeName := GetSymName (type) ;
IF IsUnboundedParam (sym, ProperProcedure, i)
THEN
fprintf1 (GetDumpFile (), 'ARRAY OF %a', typeName)
ELSE
fprintf1 (GetDumpFile (), '%a', typeName)
END ;
INC (i)
END ;
fprintf0 (GetDumpFile (), ')')
END PrintProcTypeParameters ;
(*
PrintProcType -
*)
PROCEDURE PrintProcType (sym: CARDINAL) ;
VAR
n: Name ;
BEGIN
n := GetSymName (sym) ;
fprintf2 (GetDumpFile (), 'sym %d IsProcType (%a)', sym, n);
PrintScope (sym) ;
PrintDeclared (sym) ;
fprintf0 (GetDumpFile (), '\n') ;
fprintf0 (GetDumpFile (), 'parameters ') ;
PrintProcTypeParameters (sym) ;
PrintProcedureReturnType (sym) ;
fprintf0 (GetDumpFile (), '\n')
END PrintProcType ;
(*
PrintString -
*)
PROCEDURE PrintString (sym: CARDINAL) ;
VAR
len : CARDINAL ;
tokenno: CARDINAL ;
BEGIN
IF IsConstStringKnown (sym)
THEN
IF IsConstStringM2 (sym)
THEN
fprintf0 (GetDumpFile (), 'a Modula-2 string')
ELSIF IsConstStringC (sym)
THEN
fprintf0 (GetDumpFile (), ' a C string')
ELSIF IsConstStringM2nul (sym)
THEN
fprintf0 (GetDumpFile (), ' a nul terminated Modula-2 string')
ELSIF IsConstStringCnul (sym)
THEN
fprintf0 (GetDumpFile (), ' a nul terminated C string')
END ;
tokenno := GetDeclaredMod (sym) ;
len := GetStringLength (tokenno, sym) ;
fprintf1 (GetDumpFile (), ' length %d', len)
ELSE
fprintf0 (GetDumpFile (), 'is not currently known')
END
END PrintString ;
(*
PrintVerboseFromList - prints the, i, th element in the list, l.
*)
PROCEDURE PrintVerboseFromList (l: List; i: CARDINAL) ;
VAR
type,
low,
high,
sym : CARDINAL ;
n, n2 : Name ;
BEGIN
sym := GetItemFromList(l, i) ;
n := GetSymName(sym) ;
IF IsError(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsError (%a)', sym, n)
ELSIF IsDefImp(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsDefImp (%a)', sym, n) ;
IF IsDefinitionForC(sym)
THEN
fprintf0 (GetDumpFile(), 'and IsDefinitionForC')
END ;
IF IsHiddenTypeDeclared(sym)
THEN
fprintf0 (GetDumpFile(), ' IsHiddenTypeDeclared')
END ;
ForeachProcedureDo (sym, PrintProcedure)
ELSIF IsModule(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsModule (%a)', sym, n) ;
IF IsModuleWithinProcedure(sym)
THEN
fprintf0 (GetDumpFile(), ' and IsModuleWithinProcedure')
END
ELSIF IsInnerModule(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsInnerModule (%a)', sym, n)
ELSIF IsUnknown(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsUnknown (%a)', sym, n)
ELSIF IsType(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsType (%a)', sym, n) ;
IncludeType(l, sym) ;
PrintAlignment(sym)
ELSIF IsProcedure(sym)
THEN
PrintProcedure (sym)
ELSIF IsParameter(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsParameter (%a)', sym, n) ;
IF GetParameterShadowVar(sym)=NulSym
THEN
fprintf0 (GetDumpFile(), ' no shadow local variable')
ELSE
fprintf0 (GetDumpFile(), ' shadow ') ;
IncludeType(l, GetParameterShadowVar(sym))
(* PrintVerboseFromList(l, GetParameterShadowVar(sym)) *)
END ;
IncludeType(l, sym)
ELSIF IsPointer(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsPointer (%a)', sym, n) ;
IncludeType(l, sym) ;
PrintAlignment(sym)
ELSIF IsRecord(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsRecord (%a)', sym, n) ;
PrintLocalSymbols(sym) ;
IncludeGetNth(l, sym) ;
PrintAlignment(sym) ;
PrintDecl(sym)
ELSIF IsVarient(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsVarient (%a)', sym, n) ;
PrintDecl(sym) ;
IncludeGetNth(l, sym) ;
IncludeGetVarient(l, sym) ;
IncludeGetParent(l, sym)
ELSIF IsFieldVarient(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsFieldVarient (%a)', sym, n) ;
PrintDecl(sym) ;
IncludeGetNth(l, sym) ;
IncludeGetVarient(l, sym) ;
IncludeGetParent(l, sym)
ELSIF IsFieldEnumeration(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsFieldEnumeration (%a)', sym, n)
ELSIF IsArray(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsArray (%a)', sym, n) ;
IncludeSubscript(l, sym) ;
IncludeType(l, sym) ;
PrintAlignment(sym)
ELSIF IsEnumeration(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsEnumeration (%a)', sym, n)
ELSIF IsSet(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsSet (%a)', sym, n) ;
IncludeType(l, sym)
ELSIF IsUnbounded(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsUnbounded (%a)', sym, n) ;
IncludeUnbounded(l, sym)
ELSIF IsPartialUnbounded(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsPartialUnbounded (%a)', sym, n) ;
IncludePartialUnbounded(l, sym)
ELSIF IsRecordField(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsRecordField (%a)', sym, n) ;
IF IsRecordFieldAVarientTag(sym)
THEN
fprintf0 (GetDumpFile(), ' variant tag')
END ;
IncludeType(l, sym) ;
IncludeGetVarient(l, sym) ;
IncludeGetParent(l, sym) ;
PrintAlignment(sym) ;
PrintDecl(sym)
ELSIF IsProcType(sym)
THEN
PrintProcType (sym)
ELSIF IsVar(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsVar (%a) declared in ', sym, n) ;
PrintScope (sym) ;
fprintf0 (GetDumpFile (), 'mode ') ;
CASE GetMode(sym) OF
LeftValue : fprintf0 (GetDumpFile(), 'l ') |
RightValue : fprintf0 (GetDumpFile(), 'r ') |
ImmediateValue: fprintf0 (GetDumpFile(), 'i ') |
NoValue : fprintf0 (GetDumpFile(), 'n ')
END ;
IF IsTemporary(sym)
THEN
fprintf0 (GetDumpFile(), 'temporary ')
END ;
IF IsComponent(sym)
THEN
fprintf0 (GetDumpFile(), 'component ')
END ;
IF IsVarHeap (sym)
THEN
fprintf0 (GetDumpFile(), 'heap ')
END ;
fprintf0 (GetDumpFile (), '\n') ;
PrintInitialized (sym) ;
IncludeType(l, sym)
ELSIF IsConst(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsConst (%a)', sym, n) ;
IF IsConstString(sym)
THEN
fprintf1 (GetDumpFile(), ' also IsConstString (%a)', n) ;
PrintString (sym)
ELSIF IsConstructor(sym)
THEN
fprintf0 (GetDumpFile(), ' constant constructor ') ;
IncludeType(l, sym)
ELSIF IsConstSet(sym)
THEN
fprintf0 (GetDumpFile(), ' constant constructor set ') ;
IncludeType(l, sym)
ELSE
IncludeType(l, sym)
END
ELSIF IsConstructor(sym)
THEN
fprintf2 (GetDumpFile(), 'sym %d IsConstructor (non constant) (%a)', sym, n) ;
IncludeType(l, sym)
ELSIF IsConstLit(sym)
THEN
fprintf2 (GetDumpFile(), 'sym %d IsConstLit (%a)', sym, n)
ELSIF IsDummy(sym)
THEN
fprintf2 (GetDumpFile(), 'sym %d IsDummy (%a)', sym, n)
ELSIF IsTemporary(sym)
THEN
fprintf2 (GetDumpFile(), 'sym %d IsTemporary (%a)', sym, n)
ELSIF IsVarAParam(sym)
THEN
fprintf2 (GetDumpFile(), 'sym %d IsVarAParam (%a)', sym, n)
ELSIF IsSubscript(sym)
THEN
fprintf2 (GetDumpFile(), 'sym %d IsSubscript (%a)', sym, n)
ELSIF IsSubrange(sym)
THEN
GetSubrange(sym, high, low) ;
fprintf2 (GetDumpFile(), 'sym %d IsSubrange (%a)', sym, n) ;
IF (low#NulSym) AND (high#NulSym)
THEN
type := GetSType(sym) ;
IF type#NulSym
THEN
IncludeType(l, sym) ;
n := GetSymName(type) ;
fprintf1 (GetDumpFile(), ' %a', n)
END ;
n := GetSymName(low) ;
n2 := GetSymName(high) ;
fprintf2 (GetDumpFile (), '[%a..%a]', n, n2)
END
ELSIF IsProcedureVariable(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsProcedureVariable (%a)', sym, n)
ELSIF IsProcedureNested(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsProcedureNested (%a)', sym, n)
ELSIF IsAModula2Type(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsAModula2Type (%a)', sym, n)
ELSIF IsObject(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsObject (%a)', sym, n)
ELSIF IsTuple(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsTuple (%a)', sym, n) ;
low := GetNth(sym, 1) ;
high := GetNth(sym, 2) ;
fprintf2 (GetDumpFile (), '%d, %d\n', low, high)
ELSIF IsGnuAsm(sym)
THEN
IF IsGnuAsmVolatile(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsGnuAsmVolatile (%a)', sym, n)
ELSE
fprintf2 (GetDumpFile (), 'sym %d IsGnuAsm (%a)', sym, n)
END
ELSIF IsComponent(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsComponent (%a) ', sym, n) ;
i := 1 ;
REPEAT
type := GetNth(sym, i) ;
IF type#NulSym
THEN
IncludeItemIntoList(l, type) ;
n := GetSymName(type) ;
fprintf2 (GetDumpFile (), "[%a %d] ", n, type) ;
INC(i)
END ;
UNTIL type=NulSym
END ;
IF IsHiddenType(sym)
THEN
fprintf0 (GetDumpFile(), ' IsHiddenType')
END ;
fprintf0 (GetDumpFile(), '\n')
END PrintVerboseFromList ;
(*
PrintVerbose - prints limited information about a symbol.
*)
PROCEDURE PrintVerbose (sym: CARDINAL) ;
VAR
l: List ;
i: CARDINAL ;
BEGIN
InitList (l) ;
IncludeItemIntoList (l, sym) ;
i := 1 ;
WHILE i<=NoOfItemsInList (l) DO
PrintVerboseFromList (l, i) ;
INC (i)
END ;
KillList (l)
END PrintVerbose ;
(*
PrintSym - prints limited information about a symbol.
This procedure is externally visible.
*)
PROCEDURE PrintSym (sym: CARDINAL) ;
BEGIN
printf1 ('information about symbol: %d\n', sym) ;
fprintf0 (GetDumpFile (), '==============================\n') ;
PrintVerbose (sym)
END PrintSym ;
(* ********************************
(*
PrintSymbol - prints limited information about a symbol.
*)
PROCEDURE PrintSymbol (sym: CARDINAL) ;
BEGIN
PrintTerse(sym) ;
fprintf0 (GetDumpFile(), '\n')
END PrintSymbol ;
******************************************* *)
(*
PrintTerse -
*)
PROCEDURE PrintTerse (sym: CARDINAL) ;
VAR
n: Name ;
BEGIN
n := GetSymName(sym) ;
IF IsError(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsError (%a)', sym, n)
ELSIF IsDefImp(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsDefImp (%a)', sym, n) ;
IF IsDefinitionForC(sym)
THEN
fprintf0 (GetDumpFile(), 'and IsDefinitionForC')
END ;
IF IsHiddenTypeDeclared(sym)
THEN
fprintf0 (GetDumpFile(), ' IsHiddenTypeDeclared')
END
ELSIF IsModule(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsModule (%a)', sym, n) ;
IF IsModuleWithinProcedure(sym)
THEN
fprintf0 (GetDumpFile(), ' and IsModuleWithinProcedure')
END
ELSIF IsInnerModule(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsInnerModule (%a)', sym, n)
ELSIF IsUnknown(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsUnknown (%a)', sym, n)
ELSIF IsType(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsType (%a)', sym, n)
ELSIF IsProcedure(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsProcedure (%a)', sym, n);
IF IsProcedureReachable(sym)
THEN
fprintf0 (GetDumpFile(), ' and IsProcedureReachable')
END
ELSIF IsParameter(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsParameter (%a)', sym, n)
ELSIF IsPointer(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsPointer (%a)', sym, n)
ELSIF IsRecord(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsRecord (%a)', sym, n)
ELSIF IsVarient(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsVarient (%a)', sym, n)
ELSIF IsFieldVarient(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsFieldVarient (%a)', sym, n)
ELSIF IsFieldEnumeration(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsFieldEnumeration (%a)', sym, n)
ELSIF IsArray(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsArray (%a)', sym, n)
ELSIF IsEnumeration(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsEnumeration (%a)', sym, n)
ELSIF IsSet(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsSet (%a)', sym, n)
ELSIF IsUnbounded(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsUnbounded (%a)', sym, n)
ELSIF IsRecordField(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsRecordField (%a)', sym, n)
ELSIF IsProcType(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsProcType (%a)', sym, n)
ELSIF IsVar(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsVar (%a)', sym, n)
ELSIF IsConstString(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsConstString (%a)', sym, n)
ELSIF IsConst(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsConst (%a)', sym, n)
ELSIF IsConstLit(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsConstLit (%a)', sym, n)
ELSIF IsDummy(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsDummy (%a)', sym, n)
ELSIF IsTemporary(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsTemporary (%a)', sym, n)
ELSIF IsVarAParam(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsVarAParam (%a)', sym, n)
ELSIF IsSubscript(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsSubscript (%a)', sym, n)
ELSIF IsSubrange(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsSubrange (%a)', sym, n)
ELSIF IsProcedureVariable(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsProcedureVariable (%a)', sym, n)
ELSIF IsProcedureNested(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsProcedureNested (%a)', sym, n)
ELSIF IsAModula2Type(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsAModula2Type (%a)', sym, n)
ELSIF IsGnuAsm(sym)
THEN
fprintf2 (GetDumpFile (), 'sym %d IsGnuAsm (%a)', sym, n)
ELSIF IsImport (sym)
THEN
fprintf1 (GetDumpFile(), 'sym %d IsImport', sym)
ELSIF IsImportStatement (sym)
THEN
fprintf1 (GetDumpFile(), 'sym %d IsImportStatement', sym)
END ;
IF IsHiddenType(sym)
THEN
fprintf0 (GetDumpFile(), ' IsHiddenType')
END
END PrintTerse ;
(*
CheckAlignment -
*)
PROCEDURE CheckAlignment (type: tree; sym: CARDINAL) : tree ;
VAR
align: CARDINAL ;
BEGIN
align := GetAlignment(sym) ;
IF align#NulSym
THEN
PushInt(0) ;
PushValue(align) ;
IF NOT Equ(GetDeclaredMod(sym))
THEN
RETURN( SetAlignment(type, Mod2Gcc(GetAlignment(sym))) )
END
END ;
RETURN( type )
END CheckAlignment ;
(*
CheckPragma -
*)
PROCEDURE CheckPragma (type: tree; sym: CARDINAL) : tree ;
BEGIN
IF IsDeclaredPacked (sym)
THEN
IF IsRecordField (sym) OR IsFieldVarient (sym)
THEN
type := SetDeclPacked (type)
ELSIF IsRecord (sym) OR IsVarient (sym)
THEN
type := SetTypePacked (type)
END
END ;
RETURN CheckAlignment (type, sym)
END CheckPragma ;
(*
IsZero - returns TRUE if symbol, sym, is zero.
*)
PROCEDURE IsZero (sym: CARDINAL) : BOOLEAN ;
BEGIN
PushIntegerTree(Mod2Gcc(sym)) ;
PushInt(0) ;
RETURN( Equ(GetDeclaredMod(sym)) )
END IsZero ;
(*
SetFieldPacked - sets Varient, VarientField and RecordField symbols
as packed.
*)
PROCEDURE SetFieldPacked (field: CARDINAL) ;
BEGIN
IF IsVarient(field) OR IsFieldVarient(field) OR IsRecordField(field)
THEN
PutDeclaredPacked(field, TRUE)
END
END SetFieldPacked ;
(*
RecordPacked - indicates that record, sym, and its fields
are all packed.
*)
PROCEDURE RecordPacked (sym: CARDINAL) ;
BEGIN
PutDeclaredPacked(sym, TRUE) ;
WalkRecordDependants(sym, SetFieldPacked)
END RecordPacked ;
(*
SetFieldNotPacked - sets Varient, VarientField and RecordField symbols
as not packed.
*)
PROCEDURE SetFieldNotPacked (field: CARDINAL) ;
BEGIN
IF IsVarient(field) OR IsFieldVarient(field) OR IsRecordField(field)
THEN
PutDeclaredPacked(field, FALSE)
END
END SetFieldNotPacked ;
(*
RecordNotPacked - indicates that record, sym, and its fields
are all not packed.
*)
PROCEDURE RecordNotPacked (sym: CARDINAL) ;
BEGIN
PutDeclaredPacked(sym, FALSE) ;
WalkRecordDependants(sym, SetFieldNotPacked)
END RecordNotPacked ;
(*
DetermineIfRecordPacked -
*)
PROCEDURE DetermineIfRecordPacked (sym: CARDINAL) ;
VAR
defaultAlignment: CARDINAL ;
BEGIN
defaultAlignment := GetDefaultRecordFieldAlignment(sym) ;
IF (defaultAlignment#NulSym) AND IsZero(defaultAlignment)
THEN
RecordPacked(sym)
ELSE
RecordNotPacked(sym)
END
END DetermineIfRecordPacked ;
(*
DeclarePackedSubrange -
*)
PROCEDURE DeclarePackedSubrange (equiv, sym: CARDINAL) ;
VAR
type,
gccsym : tree ;
high, low: CARDINAL ;
location : location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
GetSubrange(sym, high, low) ;
type := BuildSmallestTypeRange(location, Mod2Gcc(low), Mod2Gcc(high)) ;
gccsym := BuildSubrangeType(location, KeyToCharStar(GetFullSymName(sym)),
type, Mod2Gcc(low), Mod2Gcc(high)) ;
AddModGcc(equiv, gccsym)
END DeclarePackedSubrange ;
(*
DeclarePackedSet -
*)
PROCEDURE DeclarePackedSet (equiv, sym: CARDINAL) ;
VAR
highLimit,
range,
gccsym : tree ;
type,
high, low: CARDINAL ;
location: location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
Assert(IsSet(sym)) ;
type := GetDType(sym) ;
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) ;
range := BuildSmallestTypeRange(location, GetIntegerZero(location), highLimit) ;
gccsym := BuildSubrangeType(location, KeyToCharStar(GetFullSymName(sym)),
range, GetIntegerZero(location), highLimit) ;
AddModGcc(equiv, gccsym)
END DeclarePackedSet ;
(*
DeclareFieldEnumeration - declares an enumerator within the current enumeration type.
*)
PROCEDURE DeclarePackedFieldEnumeration (sym: WORD) ;
VAR
equiv,
type : CARDINAL ;
field,
enumlist: tree ;
BEGIN
(* add relationship between gccSym and sym *)
type := GetSType (sym) ;
equiv := GetPackedEquivalent (type) ;
enumlist := GetEnumList (equiv) ;
PushValue (sym) ;
field := DeclareFieldValue (sym, PopIntegerTree(), enumlist) ;
Assert (field # NIL) ;
PutEnumList (equiv, enumlist)
END DeclarePackedFieldEnumeration ;
(*
DeclarePackedEnumeration -
*)
PROCEDURE DeclarePackedEnumeration (equiv, sym: CARDINAL) ;
VAR
enumlist,
gccenum : tree ;
location: location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
gccenum := BuildStartEnumeration(location, KeyToCharStar(GetFullSymName(sym)), TRUE) ;
ForeachLocalSymDo(sym, DeclarePackedFieldEnumeration) ;
enumlist := GetEnumList(equiv) ;
gccenum := BuildEndEnumeration(location, gccenum, enumlist) ;
AddModGcc(equiv, gccenum)
END DeclarePackedEnumeration ;
(*
DeclarePackedType -
*)
PROCEDURE DeclarePackedType (equiv, sym: CARDINAL) ;
VAR
type: CARDINAL ;
BEGIN
type := GetSType(sym) ;
IF type=NulSym
THEN
IF sym=Boolean
THEN
AddModGcc(equiv, GetPackedBooleanType())
ELSE
AddModGcc(equiv, Mod2Gcc(sym))
END
ELSE
DeclarePackedType(GetPackedEquivalent(type), type) ;
AddModGcc(equiv, Mod2Gcc(GetPackedEquivalent(type)))
END
END DeclarePackedType ;
(*
doDeclareEquivalent -
*)
PROCEDURE doDeclareEquivalent (sym: CARDINAL; p: doDeclareProcedure) : tree ;
VAR
equiv: CARDINAL ;
BEGIN
equiv := GetPackedEquivalent(sym) ;
IF NOT GccKnowsAbout(equiv)
THEN
p(equiv, sym) ;
IncludeElementIntoSet(GlobalGroup^.FullyDeclared, equiv)
END ;
RETURN( Mod2Gcc(equiv) )
END doDeclareEquivalent ;
(*
PossiblyPacked -
*)
PROCEDURE PossiblyPacked (sym: CARDINAL; isPacked: BOOLEAN) : tree ;
BEGIN
IF isPacked
THEN
IF IsSubrange(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedSubrange) )
ELSIF IsType(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedType) )
ELSIF IsEnumeration(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedEnumeration) )
ELSIF IsSet(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedSet) )
END
END ;
RETURN( Mod2Gcc(sym) )
END PossiblyPacked ;
(*
GetPackedType - returns a possibly packed type for field.
*)
PROCEDURE GetPackedType (sym: CARDINAL) : tree ;
BEGIN
IF IsSubrange(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedSubrange) )
ELSIF IsType(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedType) )
ELSIF IsEnumeration(sym)
THEN
RETURN( doDeclareEquivalent(sym, DeclarePackedEnumeration) )
END ;
RETURN( Mod2Gcc(sym) )
END GetPackedType ;
(*
MaybeAlignField - checks to see whether, field, is packed or aligned and it updates
the offsets if appropriate.
*)
PROCEDURE MaybeAlignField (field: CARDINAL; VAR byteOffset, bitOffset: tree) : tree ;
VAR
f, ftype,
nbits : tree ;
location: location_t ;
BEGIN
f := Mod2Gcc(field) ;
IF IsDeclaredPacked(field)
THEN
location := TokenToLocation(GetDeclaredMod(field)) ;
f := SetDeclPacked(f) ;
ftype := GetPackedType(GetSType(field)) ;
nbits := BuildTBitSize(location, ftype) ;
f := SetRecordFieldOffset(f, byteOffset, bitOffset, ftype, nbits) ;
bitOffset := BuildAdd(location, bitOffset, nbits, FALSE) ;
RETURN( f )
ELSE
RETURN( CheckAlignment(f, field) )
END
END MaybeAlignField ;
(*
DeclareRecord - declares a record and its fields to gcc.
The final gcc record type is returned.
*)
PROCEDURE DeclareRecord (Sym: CARDINAL) : tree ;
VAR
Field : CARDINAL ;
i : CARDINAL ;
nbits,
ftype,
field,
byteOffset,
bitOffset,
FieldList,
RecordType: tree ;
location : location_t ;
BEGIN
i := 1 ;
FieldList := tree(NIL) ;
RecordType := DoStartDeclaration(Sym, BuildStartRecord) ;
location := TokenToLocation(GetDeclaredMod(Sym)) ;
byteOffset := GetIntegerZero(location) ;
bitOffset := GetIntegerZero(location) ;
REPEAT
Field := GetNth(Sym, i) ;
IF Field#NulSym
THEN
IF IsRecordField(Field) AND IsRecordFieldAVarientTag(Field) AND (GetSymName(Field)=NulName)
THEN
(* do not include a nameless tag into the C struct *)
ELSIF IsVarient(Field)
THEN
Field := Chained(Field) ;
field := Mod2Gcc(Field) ;
IF IsDeclaredPacked(Field)
THEN
location := TokenToLocation(GetDeclaredMod(Field)) ;
field := SetDeclPacked(field) ;
ftype := GetPackedType(GetSType(Field)) ;
nbits := BuildTBitSize(location, ftype) ;
field := SetRecordFieldOffset(field, byteOffset, bitOffset, ftype, nbits) ;
bitOffset := BuildAdd(location, bitOffset, nbits, FALSE) ;
byteOffset := BuildAdd(location, byteOffset,
BuildDivTrunc(location, bitOffset, BuildIntegerConstant(8), FALSE),
FALSE) ;
bitOffset := BuildModTrunc(location, bitOffset, BuildIntegerConstant(8), FALSE)
END ;
FieldList := ChainOn(FieldList, field)
ELSE
IF Debugging
THEN
printf0('chaining ') ; PrintTerse(Field) ; printf0('\n')
END ;
FieldList := ChainOn(FieldList, MaybeAlignField(Chained(Field), byteOffset, bitOffset))
END
END ;
INC(i)
UNTIL Field=NulSym ;
WatchRemoveList(Sym, partiallydeclared) ;
WatchRemoveList(Sym, heldbyalignment) ;
WatchRemoveList(Sym, finishedalignment) ;
location := TokenToLocation(GetDeclaredMod(Sym)) ;
RETURN( BuildEndRecord(location, RecordType, FieldList, IsDeclaredPacked(Sym)) )
END DeclareRecord ;
(*
DeclareRecordField -
*)
PROCEDURE DeclareRecordField (sym: CARDINAL) : tree ;
VAR
field,
GccFieldType: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
GccFieldType := PossiblyPacked(GetSType(sym), IsDeclaredPacked(sym)) ;
field := BuildFieldRecord(location, KeyToCharStar(GetFullSymName(sym)), GccFieldType) ;
RETURN( field )
END DeclareRecordField ;
(*
DeclareVarient - declares a record and its fields to gcc.
The final gcc record type is returned.
*)
PROCEDURE DeclareVarient (sym: CARDINAL) : tree ;
VAR
Field : CARDINAL ;
i : CARDINAL ;
byteOffset,
bitOffset,
FieldList,
VarientType : tree ;
location : location_t ;
BEGIN
i := 1 ;
FieldList := tree(NIL) ;
VarientType := DoStartDeclaration(sym, BuildStartVarient) ;
location := TokenToLocation(GetDeclaredMod(sym)) ;
byteOffset := GetIntegerZero(location) ;
bitOffset := GetIntegerZero(location) ;
WHILE GetNth(sym, i)#NulSym DO
Field := GetNth(sym, i) ;
IF IsRecordField(Field) AND IsRecordFieldAVarientTag(Field) AND (GetSymName(Field)=NulName)
THEN
(* do not include a nameless tag into the C struct *)
ELSE
IF Debugging
THEN
printf0('chaining ') ; PrintTerse(Field) ; printf0('\n')
END ;
FieldList := ChainOn(FieldList, MaybeAlignField(Chained(Field), byteOffset, bitOffset))
END ;
INC(i)
END ;
WatchRemoveList(sym, partiallydeclared) ;
WatchRemoveList(sym, heldbyalignment) ;
WatchRemoveList(sym, finishedalignment) ;
VarientType := BuildEndVarient(location, VarientType, FieldList, IsDeclaredPacked(sym)) ;
RETURN( VarientType )
END DeclareVarient ;
(*
DeclareFieldVarient -
*)
PROCEDURE DeclareFieldVarient (sym: CARDINAL) : tree ;
VAR
i, f : CARDINAL ;
VarientList,
VarientType,
byteOffset,
bitOffset,
GccFieldType: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(GetDeclaredMod(sym)) ;
i := 1 ;
VarientList := tree(NIL) ;
VarientType := DoStartDeclaration(sym, BuildStartFieldVarient) ;
(* no need to store the [sym, RecordType] tuple as it is stored by DeclareRecord which calls us *)
byteOffset := GetIntegerZero(location) ;
bitOffset := GetIntegerZero(location) ;
WHILE GetNth(sym, i)#NulSym DO
f := GetNth(sym, i) ;
IF IsFieldVarient(f) AND IsEmptyFieldVarient(f)
THEN
(* do not include empty varient fields (created via 'else end' in variant records *)
ELSE
IF Debugging
THEN
printf0('chaining ') ; PrintTerse(f) ; printf0('\n')
END ;
VarientList := ChainOn(VarientList, MaybeAlignField(Chained(f), byteOffset, bitOffset))
END ;
INC(i)
END ;
WatchRemoveList(sym, partiallydeclared) ;
GccFieldType := BuildEndFieldVarient(location, VarientType, VarientList, IsDeclaredPacked(sym)) ;
RETURN( GccFieldType )
END DeclareFieldVarient ;
(*
DeclarePointer - declares a pointer type to gcc and returns the Tree.
*)
PROCEDURE DeclarePointer (sym: CARDINAL) : tree ;
BEGIN
RETURN( BuildPointerType(Mod2Gcc(GetSType(sym))) )
END DeclarePointer ;
(*
DeclareUnbounded - builds an unbounded type and returns the gcc tree.
*)
PROCEDURE DeclareUnbounded (sym: CARDINAL) : tree ;
VAR
record: CARDINAL ;
BEGIN
Assert(IsUnbounded(sym)) ;
IF GccKnowsAbout(sym)
THEN
RETURN( Mod2Gcc(sym) )
ELSE
record := GetUnboundedRecordType(sym) ;
Assert(IsRecord(record)) ;
Assert(AllDependantsFullyDeclared(record)) ;
IF (NOT GccKnowsAbout(record))
THEN
DeclareTypeConstFully(record) ;
WatchRemoveList(record, todolist)
END ;
RETURN( Mod2Gcc(record) )
END
END DeclareUnbounded ;
(*
BuildIndex -
*)
PROCEDURE BuildIndex (tokenno: CARDINAL; array: CARDINAL) : tree ;
VAR
Subscript: CARDINAL ;
Type,
High, Low: CARDINAL ;
n,
low, high: tree ;
location : location_t ;
BEGIN
location := TokenToLocation(tokenno) ;
Subscript := GetArraySubscript (array) ;
Assert (IsSubscript (Subscript)) ;
Type := GetDType (Subscript) ;
Low := GetTypeMin (Type) ;
High := GetTypeMax (Type) ;
DeclareConstant (tokenno, Low) ;
DeclareConstant (tokenno, High) ;
low := Mod2Gcc (Low) ;
high := Mod2Gcc (High) ;
IF ExceedsTypeRange (GetIntegerType (), low, high)
THEN
location := TokenToLocation (tokenno) ;
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))
ELSE
PutArrayLarge (array) ;
RETURN BuildArrayIndexType (GetIntegerZero (location), n)
END
ELSE
low := BuildConvert (location, GetIntegerType (), low, FALSE) ;
high := BuildConvert (location, GetIntegerType (), high, FALSE) ;
RETURN BuildArrayIndexType (low, high)
END
END BuildIndex ;
(*
DeclareArray - declares an array to gcc and returns the gcc tree.
*)
PROCEDURE DeclareArray (Sym: CARDINAL) : tree ;
VAR
typeOfArray: CARDINAL ;
ArrayType,
GccArray,
GccIndex : tree ;
Subscript : CARDINAL ;
tokenno : CARDINAL ;
location : location_t ;
BEGIN
Assert(IsArray(Sym)) ;
tokenno := GetDeclaredMod(Sym) ;
location := TokenToLocation(tokenno) ;
Subscript := GetArraySubscript(Sym) ;
typeOfArray := GetDType(Sym) ;
GccArray := Mod2Gcc(typeOfArray) ;
GccIndex := BuildIndex(tokenno, Sym) ;
IF GccKnowsAbout(Sym)
THEN
ArrayType := Mod2Gcc(Sym)
ELSE
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) ;
GccArray := BuildEndArrayType(ArrayType, GccArray, GccIndex, typeOfArray) ;
Assert(GccArray=ArrayType) ;
RETURN( GccArray )
END DeclareArray ;
(*
DeclareProcType - declares a procedure type to gcc and returns the gcc type tree.
*)
PROCEDURE DeclareProcType (Sym: CARDINAL) : tree ;
VAR
i, p,
Parameter,
ReturnType: CARDINAL ;
func,
GccParam : tree ;
location : location_t ;
BEGIN
ReturnType := GetSType(Sym) ;
func := DoStartDeclaration(Sym, BuildStartFunctionType) ;
InitFunctionTypeParameters ;
p := NoOfParamAny (Sym) ;
i := p ;
WHILE i > 0 DO
Parameter := GetNthParamAny (Sym, i) ;
location := TokenToLocation (GetDeclaredMod (Parameter)) ;
GccParam := BuildProcTypeParameterDeclaration (location, Mod2Gcc (GetSType (Parameter)), IsVarParamAny (Sym, i)) ;
PreAddModGcc(Parameter, GccParam) ;
DEC(i)
END ;
IF ReturnType = NulSym
THEN
RETURN( BuildEndFunctionType (func, NIL, UsesVarArgs(Sym)) )
ELSE
RETURN( BuildEndFunctionType (func, Mod2Gcc(ReturnType), UsesVarArgs(Sym)) )
END
END DeclareProcType ;
VAR
MaxEnumerationField,
MinEnumerationField: CARDINAL ;
(*
FindMinMaxEnum - finds the minimum and maximum enumeration fields.
*)
PROCEDURE FindMinMaxEnum (field: WORD) ;
BEGIN
IF MaxEnumerationField=NulSym
THEN
MaxEnumerationField := field
ELSE
PushValue(field) ;
PushValue(MaxEnumerationField) ;
IF Gre(GetDeclaredMod(field))
THEN
MaxEnumerationField := field
END
END ;
IF MinEnumerationField=NulSym
THEN
MinEnumerationField := field
ELSE
PushValue(field) ;
PushValue(MinEnumerationField) ;
IF Less(GetDeclaredMod(field))
THEN
MinEnumerationField := field
END
END
END FindMinMaxEnum ;
(*
GetTypeMin -
*)
PROCEDURE GetTypeMin (type: CARDINAL) : CARDINAL ;
VAR
min, max: CARDINAL ;
BEGIN
IF IsSubrange(type)
THEN
GetSubrange(type, max, min) ;
RETURN( min )
ELSIF IsSet(type)
THEN
RETURN( GetTypeMin(GetSType(type)) )
ELSIF IsEnumeration(type)
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MinEnumerationField )
ELSIF IsBaseType(type)
THEN
GetBaseTypeMinMax(type, min, max) ;
RETURN( min )
ELSIF IsSystemType(type)
THEN
GetSystemTypeMinMax(type, min, max) ;
RETURN( min )
ELSIF GetSType(type)=NulSym
THEN
MetaError1('unable to obtain the MIN value for type {%1as}', type) ;
RETURN NulSym
ELSE
RETURN( GetTypeMin(GetSType(type)) )
END
END GetTypeMin ;
(*
GetTypeMax -
*)
PROCEDURE GetTypeMax (type: CARDINAL) : CARDINAL ;
VAR
min, max: CARDINAL ;
BEGIN
IF IsSubrange(type)
THEN
GetSubrange(type, max, min) ;
RETURN( max )
ELSIF IsSet(type)
THEN
RETURN( GetTypeMax(GetSType(type)) )
ELSIF IsEnumeration(type)
THEN
MinEnumerationField := NulSym ;
MaxEnumerationField := NulSym ;
ForeachLocalSymDo (type, FindMinMaxEnum) ;
RETURN( MaxEnumerationField )
ELSIF IsBaseType(type)
THEN
GetBaseTypeMinMax(type, min, max) ;
RETURN( max )
ELSIF IsSystemType(type)
THEN
GetSystemTypeMinMax(type, min, max) ;
RETURN( max )
ELSIF GetSType(type)=NulSym
THEN
MetaError1('unable to obtain the MAX value for type {%1as}', type) ;
RETURN NulSym
ELSE
RETURN( GetTypeMax(GetSType(type)) )
END
END GetTypeMax ;
(*
PushNoOfBits - pushes the integer value of the number of bits required
to maintain a set of type.
*)
PROCEDURE PushNoOfBits (type: CARDINAL; low, high: CARDINAL) ;
BEGIN
PushValue(high) ;
ConvertToType(type) ;
PushValue(low) ;
ConvertToType(type) ;
Sub ;
ConvertToType(Cardinal)
END PushNoOfBits ;
(*
DeclareLargeSet - n is the name of the set.
type is the subrange type (or simple type)
low and high are the limits of the subrange.
*)
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 = 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.
*)
PROCEDURE DeclareLargeOrSmallSet (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)
ELSE
(* PutSetLarge(sym) ; *)
RETURN DeclareLargeSet (n, type, low, high) (* --fixme-- finish packed here as well. *)
END
END DeclareLargeOrSmallSet ;
(*
DeclareSet - declares a set type to gcc and returns a Tree.
*)
PROCEDURE DeclareSet (sym: CARDINAL) : tree ;
VAR
gccsym : tree ;
type,
high, low: CARDINAL ;
BEGIN
type := GetDType(sym) ;
IF IsSubrange(type)
THEN
GetSubrange(type, high, low) ;
gccsym := DeclareLargeOrSmallSet(sym, GetFullSymName(sym), GetSType(type), low, high)
ELSE
gccsym := DeclareLargeOrSmallSet(sym, GetFullSymName(sym), type, GetTypeMin(type), GetTypeMax(type))
END ;
RETURN( gccsym )
END DeclareSet ;
(*
CheckResolveSubrange - checks to see whether we can determine
the subrange type. We are able to do
this once low, high and the type are known.
*)
PROCEDURE CheckResolveSubrange (sym: CARDINAL) ;
VAR
tokenno : CARDINAL;
size, high, low, type: CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
tokenno := GetDeclaredMod (sym) ;
type := GetSType(sym) ;
IF type=NulSym
THEN
IF GccKnowsAbout(low) AND GccKnowsAbout(high)
THEN
IF IsConstString (low) AND IsConstStringKnown (low)
THEN
size := GetStringLength (tokenno, low) ;
IF size <= 1
THEN
PutSubrange(sym, low, high, Char)
ELSE
MetaError1 ('cannot have a subrange of a string type {%1Uad}',
sym)
END
ELSIF IsFieldEnumeration(low)
THEN
IF GetSType(low)=GetSType(high)
THEN
PutSubrange(sym, low, high, GetSType(low))
ELSE
MetaError1('subrange limits must be of the same type {%1Uad}', sym)
END
ELSIF IsValueSolved(low)
THEN
IF GetSType(low)=LongReal
THEN
MetaError1('cannot have a subrange of a SHORTREAL, REAL or LONGREAL type {%1Uad}', sym)
ELSE
PutSubrange(sym, low, high, MixTypes(GetSType(low), GetSType(high), GetDeclaredMod(sym)))
END
END
END
END
END CheckResolveSubrange ;
(*
TypeConstFullyDeclared - all, sym, dependents are declared, so create and
return the GCC Tree equivalent.
*)
PROCEDURE TypeConstFullyDeclared (sym: CARDINAL) : tree ;
VAR
t: tree ;
BEGIN
IF IsEnumeration(sym)
THEN
t := DeclareEnumeration(sym)
ELSIF IsFieldEnumeration(sym)
THEN
t := DeclareFieldEnumeration(sym)
ELSIF IsSubrange(sym)
THEN
t := DeclareSubrange(sym)
ELSIF IsRecord(sym)
THEN
t := CheckPragma(DeclareRecord(sym), sym)
ELSIF IsRecordField(sym)
THEN
t := CheckPragma(DeclareRecordField(sym), sym)
ELSIF IsFieldVarient(sym)
THEN
t := DeclareFieldVarient(sym)
ELSIF IsVarient(sym)
THEN
t := DeclareVarient(sym)
ELSIF IsPointer(sym)
THEN
t := CheckAlignment(DeclarePointer(sym), sym)
ELSIF IsUnbounded(sym)
THEN
t := DeclareUnbounded(sym)
ELSIF IsArray(sym)
THEN
t := CheckAlignment(DeclareArray(sym), sym)
ELSIF IsProcType(sym)
THEN
t := DeclareProcType(sym)
ELSIF IsSet(sym)
THEN
t := DeclareSet(sym)
ELSIF IsConst(sym)
THEN
IF IsConstructor(sym)
THEN
PushValue(sym) ;
ChangeToConstructor(GetDeclaredMod(sym), GetSType(sym)) ;
PopValue(sym) ;
EvaluateValue(sym) ;
PutConstructorSolved(sym) ;
ELSIF IsConstSet(sym)
THEN
EvaluateValue(sym)
END ;
IF NOT IsValueSolved(sym)
THEN
RETURN( NIL )
END ;
t := DeclareConst(GetDeclaredMod(sym), sym) ;
Assert(t#NIL)
ELSIF IsConstructor(sym)
THEN
(* not yet known as a constant *)
RETURN( NIL )
ELSE
t := DeclareType(sym) ;
IF IsType(sym)
THEN
t := CheckAlignment(t, sym)
END
END ;
RETURN RememberType (t)
END TypeConstFullyDeclared ;
(*
IsBaseType - returns true if a type, Sym, is a base type and
we use predefined GDB information to represent this
type.
*)
PROCEDURE IsBaseType (Sym: CARDINAL) : BOOLEAN ;
BEGIN
RETURN( (Sym=Cardinal) OR (Sym=Integer) OR
(Sym=Char) OR (Sym=Proc) )
END IsBaseType ;
(*
IsFieldEnumerationDependants - sets enumDeps to FALSE if action(Sym)
is also FALSE.
*)
PROCEDURE IsFieldEnumerationDependants (Sym: WORD) ;
BEGIN
IF NOT action(Sym)
THEN
enumDeps := FALSE
END
END IsFieldEnumerationDependants ;
(*
IsEnumerationDependants - returns true if the enumeration
p(dependants) all return true.
*)
PROCEDURE IsEnumerationDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
BEGIN
action := q ;
enumDeps := TRUE ;
ForeachLocalSymDo (sym, IsFieldEnumerationDependants) ;
RETURN( enumDeps )
END IsEnumerationDependants ;
(*
WalkEnumerationDependants - returns walks all dependants of Sym.
*)
PROCEDURE WalkEnumerationDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
ForeachLocalSymDo (sym, p)
END WalkEnumerationDependants ;
(*
WalkSubrangeDependants - calls p(dependants) for each dependant of, sym.
*)
PROCEDURE WalkSubrangeDependants (sym: CARDINAL; p: WalkAction) ;
VAR
type, align,
high, low : CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
CheckResolveSubrange (sym) ;
type := GetSType(sym) ;
IF type#NulSym
THEN
p(type)
END ;
(* low and high are not types but constants and they are resolved by M2GenGCC *)
p(low) ;
p(high) ;
align := GetAlignment (sym) ;
IF align # NulSym
THEN
p(align)
END
END WalkSubrangeDependants ;
(*
IsSubrangeDependants - returns TRUE if the subrange
q(dependants) all return TRUE.
*)
PROCEDURE IsSubrangeDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result : BOOLEAN ;
align,
type,
high, low: CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
(* low and high are not types but constants and they are resolved by M2GenGCC *)
CheckResolveSubrange(sym) ;
result := TRUE ;
type := GetSType(sym) ;
IF (type=NulSym) OR (NOT q(type))
THEN
result := FALSE
END ;
IF NOT q(low)
THEN
result := FALSE
END ;
IF NOT q(high)
THEN
result := FALSE
END ;
align := GetAlignment(sym) ;
IF (align#NulSym) AND (NOT q(align))
THEN
result := FALSE
END ;
RETURN( result )
END IsSubrangeDependants ;
(*
WalkComponentDependants -
*)
PROCEDURE WalkComponentDependants (sym: CARDINAL; p: WalkAction) ;
VAR
i : CARDINAL ;
type: CARDINAL ;
BEGIN
(* need to walk record and field *)
i := 1 ;
REPEAT
type := GetNth(sym, i) ;
IF type#NulSym
THEN
IF IsVar(type)
THEN
p(GetSType(type))
ELSE
p(type)
END ;
INC(i)
END
UNTIL type=NulSym
END WalkComponentDependants ;
(*
IsComponentDependants -
*)
PROCEDURE IsComponentDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
type : CARDINAL ;
i : CARDINAL ;
result: BOOLEAN ;
BEGIN
(* need to check record is completely resolved *)
result := TRUE ;
i := 1 ;
REPEAT
type := GetNth(sym, i) ;
IF type#NulSym
THEN
IF IsVar(type)
THEN
type := GetSType(type)
END ;
IF NOT q(type)
THEN
result := FALSE
END ;
INC(i)
END
UNTIL type=NulSym ;
RETURN( result )
END IsComponentDependants ;
(*
WalkVarDependants - walks all dependants of sym.
*)
PROCEDURE WalkVarDependants (sym: CARDINAL; p: WalkAction) ;
VAR
type: CARDINAL ;
BEGIN
p(GetSType(sym)) ;
IF IsComponent(sym)
THEN
WalkComponentDependants(sym, p)
END ;
type := GetVarBackEndType(sym) ;
IF type#NulSym
THEN
p(type)
END
END WalkVarDependants ;
(*
IsVarDependants - returns TRUE if the pointer symbol, sym,
p(dependants) all return TRUE.
*)
PROCEDURE IsVarDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
type : CARDINAL ;
result: BOOLEAN ;
BEGIN
result := TRUE ;
IF NOT q(GetSType(sym))
THEN
result := FALSE
END ;
IF IsComponent(sym)
THEN
IF NOT IsComponentDependants(sym, q)
THEN
result := FALSE
END
END ;
type := GetVarBackEndType(sym) ;
IF type#NulSym
THEN
IF NOT q(type)
THEN
result := FALSE
END
END ;
RETURN( result )
END IsVarDependants ;
(*
WalkPointerDependants - walks all dependants of sym.
*)
PROCEDURE WalkPointerDependants (sym: CARDINAL; p: WalkAction) ;
VAR
align: CARDINAL ;
BEGIN
p(GetSType(sym)) ;
align := GetAlignment(sym) ;
IF align#NulSym
THEN
p(align)
END
END WalkPointerDependants ;
(*
IsPointerDependants - returns TRUE if the pointer symbol, sym,
p(dependants) all return TRUE.
*)
PROCEDURE IsPointerDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
align: CARDINAL ;
final: BOOLEAN ;
BEGIN
final := TRUE ;
IF NOT q(GetSType(sym))
THEN
final := FALSE
END ;
align := GetAlignment (sym) ;
IF final AND (align # NulSym)
THEN
IF NOT q(align)
THEN
final := FALSE
END
END ;
RETURN final
END IsPointerDependants ;
(*
IsRecordAlignment -
*)
PROCEDURE IsRecordAlignment (sym: CARDINAL; q: IsAction) : BOOLEAN ;
BEGIN
IF GetDefaultRecordFieldAlignment(sym)#NulSym
THEN
IF NOT q(GetDefaultRecordFieldAlignment(sym))
THEN
RETURN( FALSE )
END
END ;
RETURN( TRUE )
END IsRecordAlignment ;
(*
IsRecordDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
*)
PROCEDURE IsRecordDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result: BOOLEAN ;
i : CARDINAL ;
field : CARDINAL ;
BEGIN
result := IsRecordAlignment(sym, q) ;
i := 1 ;
REPEAT
field := GetNth(sym, i) ;
IF field#NulSym
THEN
IF IsRecordField(field)
THEN
IF (NOT IsRecordFieldAVarientTag(field)) OR (GetSymName(field)#NulName)
THEN
IF NOT q(field)
THEN
result := FALSE
END
END
ELSIF IsVarient(field)
THEN
IF NOT q(field)
THEN
result := FALSE
END
ELSIF IsFieldVarient(field)
THEN
InternalError ('should not see a field varient')
ELSE
InternalError ('unknown symbol in record')
END
END ;
INC(i)
UNTIL field=NulSym ;
RETURN( result )
END IsRecordDependants ;
(*
WalkRecordAlignment - walks the alignment constant associated with
record, sym.
*)
PROCEDURE WalkRecordAlignment (sym: CARDINAL; p: WalkAction) ;
BEGIN
IF GetDefaultRecordFieldAlignment(sym)#NulSym
THEN
p(GetDefaultRecordFieldAlignment(sym))
END
END WalkRecordAlignment ;
(*
WalkRecordDependants - walks symbol, sym, dependants. It only
walks the fields if the alignment is
unused or fully declared.
*)
PROCEDURE WalkRecordDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
WalkRecordAlignment(sym, p) ;
WalkRecordDependants2(sym, p)
END WalkRecordDependants ;
(*
WalkRecordFieldDependants -
*)
PROCEDURE WalkRecordFieldDependants (sym: CARDINAL; p: WalkAction) ;
VAR
v : CARDINAL ;
align: CARDINAL ;
BEGIN
Assert(IsRecordField(sym)) ;
p(GetSType(sym)) ;
v := GetVarient(sym) ;
IF v#NulSym
THEN
p(v)
END ;
align := GetAlignment(sym) ;
IF align#NulSym
THEN
p(align)
END
END WalkRecordFieldDependants ;
(*
WalkRecordDependants2 - walks the fields of record, sym, calling
p on every dependant.
*)
PROCEDURE WalkRecordDependants2 (sym: CARDINAL; p: WalkAction) ;
VAR
i : CARDINAL ;
Field: CARDINAL ;
BEGIN
i := 1 ;
WHILE GetNth(sym, i)#NulSym DO
Field := GetNth(sym, i) ;
p(Field) ;
IF IsRecordField(Field)
THEN
WalkRecordFieldDependants(Field, p)
ELSIF IsVarient(Field)
THEN
WalkVarientDependants(Field, p)
ELSIF IsFieldVarient(Field)
THEN
InternalError ('should not see a field varient')
ELSE
InternalError ('unknown symbol in record')
END ;
INC(i)
END
END WalkRecordDependants2 ;
(*
IsVarientAlignment -
*)
PROCEDURE IsVarientAlignment (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
align: CARDINAL ;
BEGIN
sym := GetRecordOfVarient(sym) ;
align := GetDefaultRecordFieldAlignment(sym) ;
IF (align#NulSym) AND (NOT q(align))
THEN
RETURN( FALSE )
END ;
RETURN( TRUE )
END IsVarientAlignment ;
(*
IsVarientDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
*)
PROCEDURE IsVarientDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result: BOOLEAN ;
i : CARDINAL ;
Field : CARDINAL ;
BEGIN
result := IsVarientAlignment(sym, q) ;
i := 1 ;
WHILE GetNth(sym, i)#NulSym DO
Field := GetNth(sym, i) ;
Assert(IsFieldVarient(Field)) ;
IF NOT q(Field)
THEN
result := FALSE
END ;
INC(i)
END ;
RETURN( result )
END IsVarientDependants ;
(*
WalkVarientAlignment -
*)
PROCEDURE WalkVarientAlignment (sym: CARDINAL; p: WalkAction) ;
VAR
align: CARDINAL ;
BEGIN
sym := GetRecordOfVarient(sym) ;
align := GetDefaultRecordFieldAlignment(sym) ;
IF align#NulSym
THEN
p(align)
END
END WalkVarientAlignment ;
(*
WalkVarientDependants - walks symbol, sym, dependants.
*)
PROCEDURE WalkVarientDependants (sym: CARDINAL; p: WalkAction) ;
VAR
i : CARDINAL ;
v,
Field: CARDINAL ;
BEGIN
WalkVarientAlignment(sym, p) ;
IF GetSType(sym)#NulSym
THEN
p(GetSType(sym))
END ;
v := GetVarient(sym) ;
IF v#NulSym
THEN
p(v)
END ;
i := 1 ;
WHILE GetNth(sym, i)#NulSym DO
Field := GetNth(sym, i) ;
Assert(IsFieldVarient(Field)) ; (* field varients do _not_ have a type *)
p(Field) ;
WalkVarientFieldDependants(Field, p) ;
INC(i)
END
END WalkVarientDependants ;
(*
IsVarientFieldDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
*)
PROCEDURE IsVarientFieldDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
i : CARDINAL ;
type,
Field : CARDINAL ;
result: BOOLEAN ;
BEGIN
i := 1 ;
result := IsVarientAlignment(sym, q) ;
WHILE GetNth(sym, i)#NulSym DO
Field := GetNth(sym, i) ;
IF NOT q(Field)
THEN
result := FALSE
END ;
type := GetSType(Field) ;
IF type#NulSym
THEN
IF NOT q(type)
THEN
result := FALSE
END
END ;
INC(i)
END ;
RETURN( result )
END IsVarientFieldDependants ;
(*
WalkVarientFieldDependants -
*)
PROCEDURE WalkVarientFieldDependants (sym: CARDINAL; p: WalkAction) ;
VAR
i : CARDINAL ;
type,
Field: CARDINAL ;
BEGIN
WalkVarientAlignment(sym, p) ;
i := 1 ;
WHILE GetNth(sym, i)#NulSym DO
Field := GetNth(sym, i) ;
p(Field) ;
type := GetSType(Field) ;
IF type#NulSym
THEN
p(type)
END ;
INC(i)
END
END WalkVarientFieldDependants ;
(*
IsArrayDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
*)
PROCEDURE IsArrayDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result : BOOLEAN ;
align : CARDINAL ;
subscript: CARDINAL ;
high, low: CARDINAL ;
type : CARDINAL ;
BEGIN
result := TRUE ;
Assert(IsArray(sym)) ;
type := GetSType(sym) ;
IF NOT q(type)
THEN
result := FALSE
END ;
subscript := GetArraySubscript(sym) ;
IF subscript#NulSym
THEN
Assert(IsSubscript(subscript)) ;
type := GetSType(subscript) ;
IF NOT q(type)
THEN
result := FALSE
END ;
type := SkipType(type) ;
(* the array might be declared as ARRAY type OF foo *)
low := GetTypeMin(type) ;
high := GetTypeMax(type) ;
IF NOT q(low)
THEN
result := FALSE
END ;
IF NOT q(high)
THEN
result := FALSE
END ;
align := GetAlignment(sym) ;
IF (align#NulSym) AND (NOT q(align))
THEN
result := FALSE
END
END ;
RETURN( result )
END IsArrayDependants ;
(*
WalkArrayDependants - walks symbol, sym, dependants.
*)
PROCEDURE WalkArrayDependants (sym: CARDINAL; p: WalkAction) ;
VAR
align : CARDINAL ;
subscript: CARDINAL ;
high, low: CARDINAL ;
type : CARDINAL ;
BEGIN
Assert(IsArray(sym)) ;
type := GetSType(sym) ;
p(type) ;
subscript := GetArraySubscript(sym) ;
IF subscript#NulSym
THEN
Assert(IsSubscript(subscript)) ;
type := GetSType(subscript) ;
p(type) ;
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
END
END WalkArrayDependants ;
(*
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 ;
BEGIN
result := TRUE ;
Assert(IsSet(sym)) ;
type := GetDType(sym) ;
IF NOT q(type)
THEN
result := FALSE
END ;
low := GetTypeMin(type) ;
high := GetTypeMax(type) ;
IF NOT q(low)
THEN
result := FALSE
END ;
IF NOT q(high)
THEN
result := FALSE
END ;
RETURN( result )
END IsSetDependants ;
(*
WalkSetDependants - walks dependants, sym.
*)
PROCEDURE WalkSetDependants (sym: CARDINAL; p: WalkAction) ;
VAR
type, low, high: CARDINAL ;
BEGIN
Assert(IsSet(sym)) ;
type := GetDType(sym) ;
p(type) ;
low := GetTypeMin(type) ;
p(low) ;
high := GetTypeMax(type) ;
p(high)
END WalkSetDependants ;
(*
IsProcTypeDependants -
*)
PROCEDURE IsProcTypeDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
i, p, son : CARDINAL ;
ParamType,
ReturnType: CARDINAL ;
result : BOOLEAN ;
BEGIN
result := TRUE ;
Assert(IsProcType(sym)) ;
i := 1 ;
ReturnType := GetSType(sym) ;
p := NoOfParamAny (sym) ;
WHILE i<=p DO
son := GetNthParamAny (sym, i) ;
ParamType := GetSType(son) ;
IF NOT q(ParamType)
THEN
result := FALSE
END ;
INC(i)
END ;
IF (ReturnType=NulSym) OR q(ReturnType)
THEN
RETURN( result )
ELSE
RETURN( FALSE )
END
END IsProcTypeDependants ;
(*
WalkProcTypeDependants - walks dependants, sym.
*)
PROCEDURE WalkProcTypeDependants (sym: CARDINAL; p: WalkAction) ;
VAR
i, n, son : CARDINAL ;
ParamType,
ReturnType: CARDINAL ;
BEGIN
Assert(IsProcType(sym)) ;
i := 1 ;
ReturnType := GetSType(sym) ;
n := NoOfParamAny (sym) ;
WHILE i<=n DO
son := GetNthParamAny (sym, i) ;
ParamType := GetSType(son) ;
p(ParamType) ;
INC(i)
END ;
IF ReturnType#NulSym
THEN
p(ReturnType)
END
END WalkProcTypeDependants ;
(*
IsProcedureDependants -
*)
PROCEDURE IsProcedureDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
i, son : CARDINAL ;
type,
ReturnType: CARDINAL ;
result : BOOLEAN ;
BEGIN
result := TRUE ;
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)
THEN
result := FALSE
END ;
INC(i)
END ;
IF (ReturnType=NulSym) OR q(ReturnType)
THEN
RETURN( result )
ELSE
RETURN( FALSE )
END
END IsProcedureDependants ;
(*
WalkProcedureDependants - walks dependants, sym.
*)
PROCEDURE WalkProcedureDependants (sym: CARDINAL; p: WalkAction) ;
VAR
i, son : CARDINAL ;
type,
ReturnType: CARDINAL ;
BEGIN
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)
END ;
IF ReturnType#NulSym
THEN
p(ReturnType)
END
END WalkProcedureDependants ;
(*
IsUnboundedDependants - returns TRUE if the symbol, sym,
q(dependants) all return TRUE.
*)
PROCEDURE IsUnboundedDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result: BOOLEAN ;
BEGIN
result := TRUE ;
IF NOT q(GetUnboundedRecordType(sym))
THEN
result := FALSE
END ;
IF NOT q(Cardinal)
THEN
result := FALSE
END ;
IF NOT q(GetSType(sym))
THEN
result := FALSE
END ;
RETURN( result )
END IsUnboundedDependants ;
(*
WalkUnboundedDependants - walks the dependants of, sym.
*)
PROCEDURE WalkUnboundedDependants (sym: CARDINAL; p: WalkAction) ;
BEGIN
p(GetUnboundedRecordType(sym)) ;
p(Cardinal) ;
p(GetSType(sym))
END WalkUnboundedDependants ;
(*
IsTypeDependants - returns TRUE if all q(dependants) return
TRUE.
*)
PROCEDURE IsTypeDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
align: CARDINAL ;
type : CARDINAL ;
final: BOOLEAN ;
BEGIN
type := GetSType(sym) ;
final := TRUE ;
IF (type#NulSym) AND (NOT q(type))
THEN
final := FALSE
END ;
align := GetAlignment(sym) ;
IF (align#NulSym) AND (NOT q(align))
THEN
final := FALSE
END ;
RETURN( final )
END IsTypeDependants ;
(*
WalkTypeDependants - walks all dependants of, sym.
*)
PROCEDURE WalkTypeDependants (sym: CARDINAL; p: WalkAction) ;
VAR
align: CARDINAL ;
type : CARDINAL ;
BEGIN
type := GetSType(sym) ;
IF type#NulSym
THEN
p(type)
END ;
align := GetAlignment(sym) ;
IF align#NulSym
THEN
p(align)
END
END WalkTypeDependants ;
(*
PoisonSymbols - poisons all gcc symbols from procedure, sym.
A debugging aid.
*)
PROCEDURE PoisonSymbols (sym: CARDINAL) ;
BEGIN
IF IsProcedure(sym)
THEN
ForeachLocalSymDo(sym, Poison)
END
END PoisonSymbols ;
(*
ConstantKnownAndUsed -
*)
PROCEDURE ConstantKnownAndUsed (sym: CARDINAL; t: tree) ;
BEGIN
DeclareConstantFromTree(sym, RememberConstant(t))
END ConstantKnownAndUsed ;
(*
InitDeclarations - initializes default types and the source filename.
*)
PROCEDURE InitDeclarations ;
BEGIN
DeclareDefaultTypes ;
DeclareDefaultConstants
END InitDeclarations ;
BEGIN
FreeGroup := NIL ;
GlobalGroup := InitGroup () ;
ErrorDepList := InitSet (1) ;
ChainedList := InitSet(1) ;
WatchList := InitSet(1) ;
VisitedList := NIL ;
EnumerationIndex := InitIndex(1) ;
HaveInitDefaultTypes := FALSE ;
recursionCaught := FALSE
END M2GCCDeclare.