-- PackDebugImpl.mesa  
--  last edited by JGS   on 17-Sep-82 14:09:18
--  last edited by Satterthwaite, January 12, 1983 11:31 am

DIRECTORY
  Alloc USING [AddNotify, DropNotify, Handle, Notifier],
  BcdDefs USING [
    CTIndex, CTNull, CTRecord, EVIndex, EVNull, FTIndex, FTNull, FTRecord, FTSelf,
    LFNull, MTIndex, MTRecord, Namee, NameRecord, NTIndex, NTRecord, NullName,
    SGIndex, VersionID, VersionStamp],
  BcdOps USING [CTHandle, MTHandle, NameString, SGHandle],
  CodePackProcs USING [ModuleIndex],
  CharIO USING [
    NumberFormat, PutChar, PutDecimal, PutNumber, PutOctal, PutString],
  HashOps USING [HTIndex, htNull, SubStringForHash],
  PackDebug,
  PackagerDefs USING [globalData, packsttype, packtreetype],
  ProcessingOrder USING [Enumerate],
  SemanticEntry USING [STIndex],
  SourceBcd USING [
    bcdBases, bcdHeader, bcdLimits, BcdTableLoc, CTreeIndex, nullCTreeIndex,
    EnumerateSons, Index, Kind, Link, Name, Prev, SharedProtoName,
    EnumerateModules, EnumerateModulesInConfig, EnumerateConfigs],
  String USING [SubString, SubStringDescriptor],
  Table USING [Base, Limit],
  Time USING [Append, Packed, Unpack],
  Tree: FROM "PackTree" USING [Index, Link, NodeName, Scan, nullIndex],
  TreeOps: FROM "PackTreeOps" USING [ScanSons];

PackDebugImpl: PROGRAM
    IMPORTS 
      Alloc, CharIO, HashOps, PackagerDefs, SourceBcd, Time,
      TreeOps, ProcessingOrder
    EXPORTS PackDebug =
  BEGIN  OPEN PackagerDefs;

  SubString: TYPE = String.SubString;
 
  table: Alloc.Handle _ NIL;
  
  stb, tb: Table.Base;

  UpdateBases: Alloc.Notifier = {
    tb     _ base[PackagerDefs.packtreetype];   -- parse tree table
    stb    _ base[PackagerDefs.packsttype]};     -- semantic entry table


 -- Initialization and Finalization

  Initialize: PUBLIC PROC = {
    table _ PackagerDefs.globalData.ownTable;
    table.AddNotify[UpdateBases]};

  Finalize: PUBLIC PROC = {
    table.DropNotify[UpdateBases];
    table _ NIL};
    

 -- Utility Writes

  WriteChar: PROC [c: CHARACTER] = {CharIO.PutChar[globalData.errorStream, c]};

  WriteString: PROC [s: STRING] = {CharIO.PutString[globalData.errorStream, s]};

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

  WriteTime: PROC [t: Time.Packed] = {
    s: STRING _ [20];
    Time.Append[s, Time.Unpack[t]];
    WriteString[s]};

  Indent: PROC [n: CARDINAL] = {
    THROUGH [1..n/8] DO WriteChar['\t] ENDLOOP;
    THROUGH [1..n MOD 8] DO WriteChar[' ] ENDLOOP};

  Tab: PROC [n: CARDINAL] = {WriteChar['\n]; Indent[n]};


 -- Annotated printing

  WriteDecimal: PROC [id: STRING, n: INTEGER] = {
    IF id # NIL THEN WriteString[id];
    CharIO.PutDecimal[PackagerDefs.globalData.errorStream, n]};

  WriteOctal: PROC [id: STRING, n: UNSPECIFIED] = {
    IF id # NIL THEN WriteString[id];
    CharIO.PutOctal[PackagerDefs.globalData.errorStream, n]};

  WriteIndex: PROC [id: STRING, index: UNSPECIFIED] = {
    IF id # NIL THEN WriteString[id];
    PrintIndex[index]};


 -- Utility Prints

  PrintMachine: PROC [stamp: BcdDefs.VersionStamp] = {
    octal: CharIO.NumberFormat = [8,FALSE,FALSE,1];
    CharIO.PutNumber[PackagerDefs.globalData.errorStream, stamp.net, octal];
    WriteChar['#];
    CharIO.PutNumber[PackagerDefs.globalData.errorStream, stamp.host, octal];
    WriteChar['#]};

  PrintFileName: PROC [fti: BcdDefs.FTIndex] = {
    SELECT fti FROM
      BcdDefs.FTNull => WriteString["(null)"L];
      BcdDefs.FTSelf => WriteString["(self)"L];
      ENDCASE => WriteName[SourceBcd.bcdBases.ftb[fti].name]};

  PrintFileVersion: PROC [fti: BcdDefs.FTIndex] = {
    OPEN SourceBcd.bcdBases.ftb[fti];
    WriteChar['(];
    IF version.time = 0 THEN WriteString ["Null Version"L]
    ELSE
      BEGIN
      WriteTime[LOOPHOLE[version.time]];
      WriteChar[' ];  PrintMachine[version];
      END;
    WriteChar[')]};

  PrintIndex: PROC [index: UNSPECIFIED] = {
    WriteChar['[];
    IF index = Table.Limit-1
      THEN WriteString["Null"L]
      ELSE CharIO.PutDecimal[PackagerDefs.globalData.errorStream, index];
    WriteChar[']]};

  PrintNamee: PROC [n: BcdDefs.Namee] = {
    WriteChar['[];
    WITH n SELECT FROM
      config => {
        WriteString["cti: "L];
	CharIO.PutDecimal[PackagerDefs.globalData.errorStream, LOOPHOLE[cti]]}; 
      module => {
        WriteString["mti: "L];
	CharIO.PutDecimal[PackagerDefs.globalData.errorStream, LOOPHOLE[mti]]}; 
      import => {
        WriteString["impi: "L];
	CharIO.PutDecimal[PackagerDefs.globalData.errorStream, LOOPHOLE[impi]]}; 
      export => {
        WriteString["expi: "L];
	CharIO.PutDecimal[PackagerDefs.globalData.errorStream, LOOPHOLE[expi]]};
      ENDCASE; 
    WriteChar[']]};

  WriteNameFromTable: PROC [n: BcdDefs.Namee] = {
    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};


 -- ********************** Parse Tree Printing ********************** 

  PrintTree: PUBLIC PROC = {
    WriteString["\n\n--Parse Tree--\n"L];
    PrintSubTree[PackagerDefs.globalData.root, 0];  WriteChar['\n];  WriteChar['\n]};

  PrintSubTree: PROC [t: Tree.Link, nBlanks: CARDINAL] = {
    OPEN Tree;

    Printer: Tree.Scan = {
      node: Tree.Index;
      Tab[nBlanks];
      WITH s: t SELECT FROM
        hash    => WriteHTI[s.index];
        symbol  => WriteSymbol[s.index]; 
        literal => WriteCodePackProcs[s.index]; 
        subtree => {
          node _ s.index;
          IF node = Tree.nullIndex THEN WriteString["<empty>"L]
          ELSE {
            OPEN tb[node];
            WriteNodeName[name];  PrintIndex[node];
            WriteOctal[", source["L, info];  WriteChar[']];
            SELECT name FROM
	      allComp, compItems, exceptItems, exceptPacks,
              itemsExceptPacks, exceptPacksItems, 
	      mainOfPL, evOfPL, catchOfPL => {
	        WriteString[", cp"L];  PrintIndex[cp];
                WriteString[", seg"L];  PrintIndex[seg]};
	      ENDCASE;
            IF attrs[$exceptMAIN] THEN SELECT name FROM
	      codePack, unnamedCodePack, discardCodePack =>
                WriteString[", except MAIN"L];
	      ENDCASE;
            IF attrs[$exceptEV] THEN SELECT name FROM
	      codePack, unnamedCodePack, discardCodePack =>
                WriteString[", except ENTRY VECTOR"L];
	      ENDCASE;
            IF attrs[$exceptCatch] THEN SELECT name FROM
	      codePack, unnamedCodePack, discardCodePack =>
                WriteString[", except CATCH CODE"L];
	      ENDCASE;
            IF attrs[$superceded] THEN SELECT name FROM
	      codeSeg, codePack, unnamedCodePack, merge, mergeFP,
	      discardCodePack => 
	        WriteString[", superceded"L];
	      ENDCASE;
            IF attrs[$placed] THEN SELECT name FROM
	      codeSeg, codePack, unnamedCodePack, merge, mergeFP,
              discardCodePack => 
	        WriteString[", placed"L];
	      ENDCASE;
            nBlanks _ nBlanks + 2;
            TreeOps.ScanSons[s, Printer];
            nBlanks _ nBlanks - 2}};
        ENDCASE};

    [] _ Printer[t]};

  WriteHTI: PROC [hti: HashOps.HTIndex] =
    BEGIN
    ss: String.SubString = @desc;
      desc: String.SubStringDescriptor;
    IF hti = HashOps.htNull
      THEN WriteString["(anonymous)"L]
      ELSE {HashOps.SubStringForHash[ss, hti];  WriteSubString[ss]};
    END;

  WriteNodeName: PROC [n: Tree.NodeName] =
    BEGIN
    NodePrintName: ARRAY Tree.NodeName OF STRING = [
      "list"L, 
      "code segment"L,
      "code pack"L, "unnamed code pack"L, "discard code pack"L,
      "frame pack"L,
      "merge segment"L, "merge frame pack"L,
      "allComp"L, "compItems"L, "exceptItems"L, "exceptPacks"L,
      "itemsExceptPacks"L, "exceptPacks&Items"L,
      "MAIN of pl"L, "EV of pl"L, "CATCH CODE of pl"L, 
      "component"L, "MAIN"L, "ENTRY VECTOR"L, "CATCH CODE"L,
      "none"L];
    WriteString[NodePrintName[n]];
    END;

  WriteSymbol: PROC [sym: SemanticEntry.STIndex] =
    BEGIN
    WriteIndex["symbol"L, sym];
    WriteChar[' ];  WriteHTI[stb[sym].hti];
    WriteIndex[", parse tree"L, stb[sym].treeNode];
    WITH stb[sym] SELECT FROM
      unknown => WriteString[" <unknown>"L];
      config => 
        BEGIN
        WriteIndex[", config: cti"L, cti];  
        WriteIndex[", cNode"L, cNode];
        END;
      module => 
        BEGIN
        WriteIndex[", module: mti"L, mti];  
        WriteIndex[", mNode"L, mNode];
        END;
      segment => 
        WriteString[", segment"L];
      codePack => 
        WriteString[", code pack"L];
      framePack => 
        WriteString[", frame pack"L];
      ENDCASE;
    END;

  WriteCodePackProcs: PROC [mi: CodePackProcs.ModuleIndex] =
    BEGIN
    WriteIndex["code pack procs"L, mi];
    END;


-- ********************** Source Bcd Table Printing **********************

  PrintSourceBcd: PUBLIC PROC =
    BEGIN
    WriteString["\n\n--Source Bcd--\n"L];
    PrintHeader[];
    WriteString["Configurations:"L];
    SourceBcd.EnumerateConfigs[PrintConfig];
    WriteString["\n\nModules:"L];
    SourceBcd.EnumerateModules[PrintModule];
    WriteChar['\n];
    PrintFiles[];
    END;
    
  PrintHeader: PROC =
    BEGIN OPEN bcd: SourceBcd.bcdHeader;
    WriteString["  Configured "L];  WriteTime[LOOPHOLE[bcd.version.time]];
    IF bcd.source # BcdDefs.NullName THEN {
      WriteString[" from "L];  WriteName[bcd.source]};
    WriteString[" by "L];  PrintMachine[bcd.version];
    IF bcd.versionIdent # BcdDefs.VersionID THEN
      WriteDecimal["  Obsolete VersionID = "L, bcd.versionIdent];
    WriteString["\n  Configured by "L];  WriteTime[LOOPHOLE[bcd.creator.time]];
    WriteChar[' ];  PrintMachine[bcd.creator];
    WriteString["\n  "L];
    IF ~bcd.definitions THEN WriteChar['~];  
    WriteString["definitions, "L];
    IF ~bcd.repackaged THEN WriteChar['~];  
    WriteString["repackaged, "L];
    IF ~bcd.tableCompiled THEN WriteChar['~];  
    WriteString["tableCompiled"L];
    WriteDecimal["\n\n  Configurations: "L, bcd.nConfigs];
    WriteDecimal[", Modules: "L, bcd.nModules];
    WriteDecimal[", Imports: "L, bcd.nImports];
    WriteDecimal[", Exports: "L, bcd.nExports];
    WriteDecimal[", Dummy: "L, bcd.firstdummy];
    WriteDecimal[", #Dummies: "L, bcd.nDummies];
    WriteChar['\n];  WriteChar['\n];
    END;

  PrintConfig: PROC [cti: BcdDefs.CTIndex] RETURNS [stop: BOOLEAN] = {
    OPEN BcdDefs;
    config: BcdOps.CTHandle = @SourceBcd.bcdBases.ctb[cti];
    Tab[2];
    WriteName[config.name];  PrintIndex[cti];
    IF config.namedInstance THEN {
      WriteString[", instance: "L];  WriteNameFromTable[[config[cti]]]};
    WriteString[", file: "L];  PrintFileName[config.file];
    PrintIndex[config.file];
    IF config.config # CTNull THEN {
      WriteString[", parent: "L];  
      WriteName[SourceBcd.bcdBases.ctb[config.config].name];
      PrintIndex[config.config]};
    IF config.nControls # 0 THEN {
      WriteString[", controls:"L];
      FOR i: CARDINAL IN [0..config.nControls) DO
        IF i MOD 6 = 0 THEN Tab[6] ELSE WriteChar[' ];
        WriteNameFromTable[config.controls[i]];
        PrintNamee[config.controls[i]];
        IF i+1 # config.nControls THEN WriteChar[',];
        ENDLOOP};
    RETURN[FALSE]};

  PrintModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] = {
    OPEN BcdDefs;
    module: BcdOps.MTHandle = @SourceBcd.bcdBases.mtb[mti];
    Tab[2];
    WriteName[module.name];  PrintIndex[mti];
    IF module.namedInstance THEN
      {WriteString[", instance: "L];  WriteNameFromTable[[module[mti]]]};
    WriteString[", file: "L];  
    PrintFileName[module.file];  PrintIndex[module.file];
    IF module.config # CTNull THEN {
      WriteString[", config: "L];
      WriteName[SourceBcd.bcdBases.ctb[module.config].name];
      PrintIndex[module.config]};
    Tab[4];
    WriteDecimal["framesize: "L, module.framesize];
    WriteDecimal[", gfi: "L, module.gfi];
    WriteDecimal[", ngfi: "L, module.ngfi];
    WriteString[", links: "L];
    WriteString[
      (SELECT module.linkLoc FROM
        frame   => "frame"L,
	code    => "code"L,
	ENDCASE => "dontcare"L)];
    Tab[4];
    WriteString["code: "L];  PrintSegment[module.code.sgi];
    WriteOctal[", offset: "L, module.code.offset];
    WriteOctal[", length: "L, module.code.length];
    IF module.code.linkspace THEN WriteString [", space available for links"L];
    Tab[4];
    WriteString["symbols: "L];  PrintSegment[module.sseg];
    IF module.variables # EVNull THEN {
      Tab[4];  WriteIndex["variables: "L, module.variables]};
    Tab[4];
    WriteDecimal[
      "number of links: "L, 
      (IF module.links = LFNull THEN 0
       ELSE SourceBcd.bcdBases.lfb[module.links].length)];
    Tab[4];
    IF ~module.packageable THEN WriteChar['~];
    WriteString["packageable, "L];
    IF ~module.tableCompiled THEN WriteChar['~];
    WriteString["tableCompiled, "L];
    IF ~module.residentFrame THEN WriteChar['~];
    WriteString["residentFrame"L];
    RETURN[FALSE]};

  PrintSegment: PROC [sgi: BcdDefs.SGIndex] = {
    sd: BcdOps.SGHandle = @SourceBcd.bcdBases.sgb[sgi];
    PrintFileName[sd.file];  PrintIndex[sgi];
    WriteDecimal[", [base: "L, sd.base]; WriteDecimal[", pages: "L, sd.pages];
    IF sd.extraPages # 0 THEN WriteDecimal["+"L, sd.extraPages];
    WriteChar[']]};

  PrintFiles: PROC = {
    OPEN BcdDefs;
    fti: FTIndex _ FIRST[FTIndex];
    WriteString["\nFiles:"L];
    UNTIL fti = SourceBcd.bcdLimits.ft DO 
      PrintFile[fti]; 
      fti _ fti + SIZE[FTRecord] 
      ENDLOOP;
    WriteChar['\n]};

  PrintFile: PROC [fti: BcdDefs.FTIndex] = {
    OPEN SourceBcd.bcdBases.ftb[fti];
    Tab[2];
    SELECT fti FROM
      BcdDefs.FTNull => WriteString["(null)"L];
      BcdDefs.FTSelf => WriteString["(self)"L];
      ENDCASE => {
	WriteName[name];  PrintIndex[fti];
	WriteString[", version: "L];  PrintFileVersion[fti]}};

  WriteName: PROC [n: BcdDefs.NameRecord] = {
    ssd: String.SubStringDescriptor _ [
      base: @SourceBcd.bcdBases.ssb.string, 
      offset: n, 
      length: SourceBcd.bcdBases.ssb.size[n]];
    WriteSubString[@ssd]};


 -- ********************** Configuration Tree Printing **********************

  PrintConfigTree: PUBLIC PROC [root: SourceBcd.CTreeIndex] = {
    WriteString["\n\n--Configuration Tree--\n"L];    
    IF root = SourceBcd.nullCTreeIndex THEN WriteString[" <Empty>"L]
    ELSE {
      nBlanks: CARDINAL _ 1;
      
      WriteSubConfigTree: PROC [node: SourceBcd.CTreeIndex] RETURNS [BOOL_FALSE] = {
	index: SourceBcd.BcdTableLoc = node.Index;
	Tab[nBlanks];
	IF node.Kind = $instance THEN {WriteName[node.Name[$instance]]; WriteChar[':]};
	WriteName[node.Name[$prototype]];  PrintIndex[node];
	WriteChar[' ];
	IF ~node.SharedProtoName THEN WriteChar['~];
	WriteString["pNameTwice"L];
	WITH index SELECT FROM
	  module => WriteIndex[", module"L, mti];
	  config => WriteIndex[", config"L, cti];
	  ENDCASE;
	WriteIndex[", Link: i"L, node.Link[$instance]];
	WriteIndex[", p"L, node.Link[$prototype]];
	WriteIndex[", Prev: i"L, node.Prev[$instance]];
	WriteIndex[", p"L, node.Prev[$prototype]];
	nBlanks _ nBlanks+2;
	node.EnumerateSons[WriteSubConfigTree];
	nBlanks _ nBlanks-2};

      [] _ WriteSubConfigTree[root]; WriteChar['\n]};
    WriteChar['\n]};


 -- ******************** Processing Order Printing ********************

  PrintProcessingOrder: PUBLIC PROC [root: SourceBcd.CTreeIndex] =
    BEGIN
    WriteString["\n\n--Processing Order--\n"L];
    SourceBcd.EnumerateModulesInConfig[
      kind: prototype,
      configTreeNode: root,
      userProc: PrintOneModulesOrder];
    WriteChar['\n];
    END;

  PrintOneModulesOrder: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
    BEGIN
    printCount: CARDINAL _ 0;

    PrintOneCDNode: PROC [cdNode: Tree.Index] RETURNS [stop: BOOLEAN] =
      BEGIN  -- print one component description node to be processed for mti
      IF (printCount _ printCount+1) > 10 THEN 
        {WriteString["\n  "L];  printCount _ 1}
      ELSE WriteString[" "L];
      PrintIndex[cdNode];
      RETURN[FALSE];
      END;
  
    Tab[0];
    WriteName[SourceBcd.bcdBases.mtb[mti].name];  
    PrintIndex[mti];  WriteString[": "L];  
    ProcessingOrder.Enumerate[mti, PrintOneCDNode];
    RETURN[FALSE];
    END;

  END.