-- PackListImpl.Mesa  
--   Last edited by Lewis on  3-Jan-81 18:01:31
--   Last edited by Sweet on September 16, 1980  12:48 PM
--   Last edited by Levin on July 6, 1982 4:30 pm

DIRECTORY
  Alloc USING [AddNotify, Bounds, DropNotify, Handle, Notifier],
  BcdDefs USING [MTIndex, Namee, NameRecord, NTIndex, NTRecord],
  CodePackProcs USING [
    AnyProcs, EnumerateSegments, EnumerateCodePacks, EnumerateModules,
    EnumerateProcs, ModuleIndex, SubStringForOPIndex],
  CharIO USING [CR, PutChar, PutString],
  FramePackModules USING [EnumerateFramePacks, EnumerateModules],
  PackagerDefs USING [
    globalData, packsstype, packsttype, packmdtype, packtreetype,
    packctreetype],
  PackEnviron USING [BcdStringHandle],
  PackList,
  PackageSymbols USING [OPIndex],
  SourceBcd USING [
    bcdBases, bcdLimits, CTreeIndex, IsTableCompiled, LookupName,
    NullCTreeIndex],
  Strings USING [String, SubString, SubStringDescriptor],
  SymTabDefs USING [HTIndex, HTNull],
  SymTabOps USING [SubStringForHash],
  Table USING [Base],
  Time USING [Append, Current, Packed, Unpack],
  Tree: FROM "PackTree" USING [Index, Link, NodeName, NullIndex];

PackListImpl: PROGRAM
    IMPORTS Alloc, CharIO, PackagerDefs, SourceBcd, SymTabOps, Time,
      CodePackProcs, FramePackModules
    EXPORTS PackList =
  BEGIN  OPEN PackagerDefs;

  PackListError: ERROR = CODE;

  SubString: TYPE = Strings.SubString;
  SubStringDescriptor: TYPE = Strings.SubStringDescriptor;


 -- ********************* Print code and frame packs *********************

  Print: PUBLIC PROC =
    BEGIN
    table ← PackagerDefs.globalData.ownTable;
    table.AddNotify[UpdateBases];
    PrintHeading[];
    PrintCodePackProcs[];
    PrintFramePackModules[];
    table.DropNotify[UpdateBases];
    table ← NIL;
    END;

 
  table: Alloc.Handle ← NIL;
  stb, tb, mdb, ctreeb: Table.Base;
  pssb: PackEnviron.BcdStringHandle;

  UpdateBases: Alloc.Notifier =
    BEGIN
    pssb   ← base[PackagerDefs.packsstype];     -- packed string table
    tb     ← base[PackagerDefs.packtreetype];   -- parse tree table
    stb    ← base[PackagerDefs.packsttype];     -- semantic entry table
    ctreeb ← base[PackagerDefs.packctreetype];  -- config tree table
    mdb    ← base[PackagerDefs.packmdtype];     -- code pack module table
    END;

  PrintHeading: PROC =
    BEGIN
    WriteString["-- File "L];  WriteString[globalData.packListFileName];
    WriteCR[];  
    WriteString["-- Created by Packager from "L]; 
    WriteString[globalData.packName]; 
    WriteString[" on "L]; 
    WriteTime[Time.Current[]];  WriteCR[];  
    END; 


 -- ********************* Code Pack Procedure Printing *********************

  PrintCodePackProcs: PROC =
    {CodePackProcs.EnumerateSegments[PrintOneCodeSegment]};

  PrintOneCodeSegment: PROC [segNode: Tree.Index] RETURNS [stop: BOOLEAN] =
    BEGIN
    IF segNode # Tree.NullIndex THEN 
      BEGIN
      WriteCR[];
      WITH tb[segNode].son[1] SELECT FROM
	hash => WriteHTI[index];
	ENDCASE;
      WriteString[": SEGMENT ="L];  WriteCR[]; 
      WriteString["  BEGIN"L];  WriteCR[];  
      CodePackProcs.EnumerateCodePacks[segNode, PrintOneCodePack];
      WriteString["  END;"L];  WriteCR[];
      END;  
    RETURN[FALSE]; 
    END;

  PrintOneCodePack: PROC [cpNode: Tree.Index] RETURNS [stop: BOOLEAN] =
    BEGIN
    IF cpNode # Tree.NullIndex THEN  
      BEGIN
      WriteCR[];  
      WriteString["  "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];
      WriteCR[]; 
      WriteString["    BEGIN"L];  WriteCR[];  
      CodePackProcs.EnumerateModules[cpNode, PrintOneCodePackModule];
      WriteString["    END;"L];  WriteCR[];  
      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["["L];  WriteCR[];
      firstProc ← TRUE;  numProcsPrinted ← 0;
      WriteString["      "L];
      CodePackProcs.EnumerateProcs[module, PrintCodePackProc];
      WriteString["];"L];  WriteCR[];  
      END
    ELSE IF SourceBcd.IsTableCompiled[mti] THEN 
      BEGIN
      WriteString["    "L];
      PrintModulePrototypeName[mti];  
      WriteString[";"L];  WriteCR[];  
      END;
    RETURN[FALSE]; 
    END; 

  PrintModulePrototypeName: PROC [module: BcdDefs.MTIndex] =
    BEGIN
    name: BcdDefs.NameRecord;
    ctreeb: Table.Base;
    firstNode, n: SourceBcd.CTreeIndex;
    
    WriteQualifiedName: PROC [cNode: SourceBcd.CTreeIndex] =
      BEGIN
      IF ctreeb[cNode].father # SourceBcd.NullCTreeIndex THEN
        {WriteQualifiedName[ctreeb[cNode].father];  WriteChar['.]};
      WriteName[ctreeb[cNode].prototypeName];
      END;

    ctreeb ← table.Bounds[PackagerDefs.packctreetype].base;
    name ← SourceBcd.bcdBases.mtb[module].name;
    firstNode ← SourceBcd.LookupName[name, prototype];
    IF firstNode = SourceBcd.NullCTreeIndex THEN ERROR PackListError;
    IF ctreeb[firstNode].prototypePrev = SourceBcd.NullCTreeIndex THEN
      WriteName[name]
    ELSE
      BEGIN  -- name is not unique, so find and print correct qualified name
      FOR n ← firstNode, ctreeb[n].prototypePrev 
       UNTIL n = SourceBcd.NullCTreeIndex DO
        WITH ctreeb[n].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: Strings.SubString ← @procIdSSDesc;
      procIdSSDesc: Strings.SubStringDescriptor;
    IF ~firstProc THEN WriteString[", "L];
    firstProc ← FALSE;
    IF (numProcsPrinted ← numProcsPrinted+1) > 5 THEN 
      {WriteCR[];  WriteString["      "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
      WriteCR[];
      WITH tb[fpNode].son[1] SELECT FROM
  	hash => WriteHTI[index];
  	ENDCASE;
      WriteString[": FRAME PACK ="L];  WriteCR[]; 
      WriteString["  BEGIN"L];  WriteCR[];  
      FramePackModules.EnumerateModules[fpNode, PrintOneFramePackModule];
      WriteString["  END;"L];  WriteCR[];
      END;  
    RETURN[FALSE]; 
    END;

  PrintOneFramePackModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
    BEGIN
    WriteString["  "L];  PrintModuleInstanceName[mti];  WriteChar[';];
    WriteCR[];
    RETURN[FALSE]; 
    END; 

  PrintModuleInstanceName: PROC [module: BcdDefs.MTIndex] =
    BEGIN
    name: BcdDefs.NameRecord;
    ctreeb: Table.Base;
    firstNode, n: SourceBcd.CTreeIndex;
    
    WriteQualifiedName: PROC [cNode: SourceBcd.CTreeIndex] =
      BEGIN
      IF ctreeb[cNode].father # SourceBcd.NullCTreeIndex THEN
        {WriteQualifiedName[ctreeb[cNode].father];  WriteChar['.]};
      WITH ctreeb[cNode] SELECT FROM
        instance  => WriteName[instanceName];
        prototype => WriteName[prototypeName];
        ENDCASE
      END;

    ctreeb ← table.Bounds[PackagerDefs.packctreetype].base;
    name ← SourceBcd.bcdBases.mtb[module].name;
    firstNode ← SourceBcd.LookupName[name, instance];
    IF firstNode = SourceBcd.NullCTreeIndex THEN ERROR PackListError;
    IF ctreeb[firstNode].instancePrev = SourceBcd.NullCTreeIndex THEN
      WriteName[name]
    ELSE
      BEGIN  -- name is not unique, so find and print correct qualified name
      FOR n ← firstNode, ctreeb[n].instancePrev 
       UNTIL n = SourceBcd.NullCTreeIndex DO
        WITH ctreeb[n].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[globalData.packListStream, c]};

  WriteString: PROC [s: Strings.String] = INLINE 
    {CharIO.PutString[globalData.packListStream, s]};

  WriteSubString: PROC [ss: SubString] =
    BEGIN
    i: CARDINAL;
    FOR i IN [ss.offset..ss.offset+ss.length) 
      DO WriteChar[ss.base[i]] ENDLOOP;
    END;

  WriteCR: PROC = INLINE {WriteChar[CharIO.CR]};

  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: SymTabDefs.HTIndex] =
    BEGIN
    ss: Strings.SubString = @desc;
      desc: Strings.SubStringDescriptor;
    IF hti = SymTabDefs.HTNull THEN WriteString["(anonymous)"L]
    ELSE {SymTabOps.SubStringForHash[ss, hti];  WriteSubString[ss]};
    END;

  END.