-- 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.