-- PackListImpl.mesa
-- Last edited by Lewis on 27-Oct-81 15:12:11
-- Last edited by Satterthwaite, December 29, 1982 11:50 am
DIRECTORY
Alloc USING [AddNotify, DropNotify, Handle, Notifier],
BcdDefs USING [MTIndex, Namee, NameRecord, NTIndex, NTRecord],
CodePackProcs USING [
AnyProcs, EnumerateSegments, EnumerateCodePacks, EnumerateModules,
EnumerateProcs, ModuleIndex, SubStringForOPIndex],
CharIO USING [PutChar, PutString],
FramePackModules USING [EnumerateFramePacks, EnumerateModules],
HashOps USING [HTIndex, htNull, SubStringForHash],
PackagerDefs USING [globalData, GlobalData, packtreetype],
PackList,
PackageSymbols USING [OPIndex],
SourceBcd USING [
bcdBases, bcdLimits, BcdTableLoc, CTreeIndex, Father, Index, IsTableCompiled,
LookupName, Name, nullCTreeIndex, Prev],
String USING [SubString, SubStringDescriptor],
Table USING [Base],
Time USING [Append, Current, Packed, Unpack],
Tree: FROM "PackTree" USING [Index, Link, NodeName, nullIndex];
PackListImpl: PROGRAM
IMPORTS
Alloc, CharIO, HashOps, PackagerDefs, SourceBcd, Time,
CodePackProcs, FramePackModules
EXPORTS PackList =
BEGIN
PackListError: ERROR = CODE;
SubString: TYPE = String.SubString;
SubStringDescriptor: TYPE = String.SubStringDescriptor;
gd: PackagerDefs.GlobalData ← NIL;
table: Alloc.Handle ← NIL;
tb: Table.Base;
UpdateBases: Alloc.Notifier = {tb ← base[PackagerDefs.packtreetype]}; -- parse tree table
-- ********************* Print code and frame packs *********************
Print: PUBLIC PROC = {
gd ← PackagerDefs.globalData;
table ← gd.ownTable;
table.AddNotify[UpdateBases];
PrintHeading[];
PrintCodePackProcs[];
PrintFramePackModules[];
table.DropNotify[UpdateBases];
table ← NIL; gd ← NIL};
PrintHeading: PROC = {
WriteString["-- File "L]; WriteString[gd.packListFileName];
WriteString["\n-- Created by Packager from "L];
WriteString[gd.packName];
WriteString[" on "L];
WriteTime[Time.Current[]]; WriteChar['\n]};
-- ********************* Code Pack Procedure Printing *********************
PrintCodePackProcs: PROC =
{CodePackProcs.EnumerateSegments[PrintOneCodeSegment]};
PrintOneCodeSegment: PROC [segNode: Tree.Index] RETURNS [stop: BOOLEAN] =
BEGIN
IF segNode # Tree.nullIndex THEN
BEGIN
WriteChar['\n];
WITH tb[segNode].son[1] SELECT FROM
hash => WriteHTI[index];
ENDCASE;
WriteString[": SEGMENT =\n"L];
WriteString[" BEGIN\n"L];
CodePackProcs.EnumerateCodePacks[segNode, PrintOneCodePack];
WriteString[" END;\n"L];
END;
RETURN[FALSE];
END;
PrintOneCodePack: PROC [cpNode: Tree.Index] RETURNS [stop: BOOLEAN] =
BEGIN
IF cpNode # Tree.nullIndex THEN
BEGIN
WriteString["\n "L];
WITH tb[cpNode].son[1] SELECT FROM
hash => WriteHTI[index];
ENDCASE;
IF tb[cpNode].name = discardCodePack THEN
WriteString[": DISCARD CODE PACK ="L]
ELSE WriteString[": CODE PACK ="L];
WriteString["\n BEGIN\n"L];
CodePackProcs.EnumerateModules[cpNode, PrintOneCodePackModule];
WriteString[" END;\n"L];
END;
RETURN[FALSE];
END;
firstProc: BOOLEAN;
numProcsPrinted: CARDINAL;
PrintOneCodePackModule: PROC [
mti: BcdDefs.MTIndex, module: CodePackProcs.ModuleIndex]
RETURNS [stop: BOOLEAN] =
BEGIN
IF CodePackProcs.AnyProcs[module] THEN
BEGIN
WriteString[" "L];
PrintModulePrototypeName[mti];
WriteString["[\n"L];
firstProc ← TRUE; numProcsPrinted ← 0;
WriteString[" "L];
CodePackProcs.EnumerateProcs[module, PrintCodePackProc];
WriteString["];\n"L];
END
ELSE IF SourceBcd.IsTableCompiled[mti] THEN
BEGIN
WriteString[" "L];
PrintModulePrototypeName[mti];
WriteString[";\n"L];
END;
RETURN[FALSE];
END;
PrintModulePrototypeName: PROC [module: BcdDefs.MTIndex] =
BEGIN
name: BcdDefs.NameRecord;
firstNode, n: SourceBcd.CTreeIndex;
WriteQualifiedName: PROC [cNode: SourceBcd.CTreeIndex] =
BEGIN
IF cNode.Father # SourceBcd.nullCTreeIndex THEN
{WriteQualifiedName[cNode.Father]; WriteChar['.]};
WriteName[cNode.Name[$prototype]];
END;
name ← SourceBcd.bcdBases.mtb[module].name;
firstNode ← SourceBcd.LookupName[name, prototype];
IF firstNode = SourceBcd.nullCTreeIndex THEN ERROR PackListError;
IF firstNode.Prev[$prototype] = SourceBcd.nullCTreeIndex THEN
WriteName[name]
ELSE
BEGIN -- name is not unique, so find and print correct qualified name
FOR n ← firstNode, n.Prev[$prototype] UNTIL n = SourceBcd.nullCTreeIndex DO
index: SourceBcd.BcdTableLoc = n.Index;
WITH index SELECT FROM
module => IF mti = module THEN {WriteQualifiedName[n]; RETURN};
ENDCASE;
ENDLOOP;
ERROR PackListError; -- could not find the module to print out
END;
END;
PrintCodePackProc: PROC [
opi: PackageSymbols.OPIndex] RETURNS [stop: BOOLEAN] =
BEGIN
procIdSS: String.SubString ← @procIdSSDesc;
procIdSSDesc: String.SubStringDescriptor;
IF ~firstProc THEN WriteString[", "L];
firstProc ← FALSE;
IF (numProcsPrinted ← numProcsPrinted+1) > 5 THEN
{WriteString["\n "L]; numProcsPrinted ← 1};
CodePackProcs.SubStringForOPIndex[procIdSS, opi];
WriteSubString[procIdSS];
RETURN[FALSE];
END;
-- ********************* Frame Pack Module Printing *********************
PrintFramePackModules: PROC =
{FramePackModules.EnumerateFramePacks[PrintOneFramePack]};
PrintOneFramePack: PROC [fpNode: Tree.Index] RETURNS [stop: BOOLEAN] =
BEGIN
IF fpNode # Tree.nullIndex THEN
BEGIN
WriteChar['\n];
WITH tb[fpNode].son[1] SELECT FROM
hash => WriteHTI[index];
ENDCASE;
WriteString[": FRAME PACK =\n"L];
WriteString[" BEGIN\n"L];
FramePackModules.EnumerateModules[fpNode, PrintOneFramePackModule];
WriteString[" END;\n"L];
END;
RETURN[FALSE];
END;
PrintOneFramePackModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
BEGIN
WriteString[" "L]; PrintModuleInstanceName[mti]; WriteString[";\n"L];
RETURN[FALSE];
END;
PrintModuleInstanceName: PROC [module: BcdDefs.MTIndex] =
BEGIN
name: BcdDefs.NameRecord;
firstNode, n: SourceBcd.CTreeIndex;
WriteQualifiedName: PROC [cNode: SourceBcd.CTreeIndex] =
BEGIN
IF cNode.Father # SourceBcd.nullCTreeIndex THEN
{WriteQualifiedName[cNode.Father]; WriteChar['.]};
WriteName[cNode.Name[$instance]];
END;
name ← SourceBcd.bcdBases.mtb[module].name;
firstNode ← SourceBcd.LookupName[name, instance];
IF firstNode = SourceBcd.nullCTreeIndex THEN ERROR PackListError;
IF firstNode.Prev[$instance] = SourceBcd.nullCTreeIndex THEN
WriteName[name]
ELSE
BEGIN -- name is not unique, so find and print correct qualified name
FOR n ← firstNode, n.Prev[$instance] UNTIL n = SourceBcd.nullCTreeIndex DO
index: SourceBcd.BcdTableLoc = n.Index;
WITH index SELECT FROM
module => IF mti = module THEN {WriteQualifiedName[n]; RETURN};
ENDCASE;
ENDLOOP;
ERROR PackListError; -- could not find the module to print out
END;
END;
-- ************************ Utility Writes ************************
WriteChar: PROC [c: CHARACTER] = INLINE
{CharIO.PutChar[gd.packListStream, c]};
WriteString: PROC [s: LONG STRING] = INLINE
{CharIO.PutString[gd.packListStream, s]};
WriteSubString: PROC [ss: SubString] =
BEGIN
FOR i: CARDINAL IN [ss.offset..ss.offset+ss.length)
DO WriteChar[ss.base[i]] ENDLOOP;
END;
WriteTime: PROC [t: Time.Packed] =
BEGIN
s: STRING ← [20];
Time.Append[s, Time.Unpack[t]];
WriteString[s];
END;
WriteName: PROC [name: BcdDefs.NameRecord] =
BEGIN
nameSubStr: SubString ← @nameDesc;
nameDesc: SubStringDescriptor;
nameDesc ← SubStringDescriptor[base: @SourceBcd.bcdBases.ssb.string,
offset: name, length: SourceBcd.bcdBases.ssb.size[name]];
WriteSubString[nameSubStr];
END;
WriteNameFromTable: PROC [n: BcdDefs.Namee] =
BEGIN OPEN BcdDefs;
nti: NTIndex ← FIRST[NTIndex];
UNTIL nti = SourceBcd.bcdLimits.nt DO
IF SourceBcd.bcdBases.ntb[nti].item = n THEN
{WriteName[SourceBcd.bcdBases.ntb[nti].name]; EXIT};
nti ← nti + SIZE[NTRecord];
ENDLOOP;
END;
WriteHTI: PROC [hti: HashOps.HTIndex] =
BEGIN
desc: String.SubStringDescriptor;
ss: String.SubString = @desc;
IF hti = HashOps.htNull THEN WriteString["(anonymous)"L]
ELSE {HashOps.SubStringForHash[ss, hti]; WriteSubString[ss]};
END;
END.