-- file Debug.mesa
-- last modified by Satterthwaite, March 23, 1983 10:11 am

DIRECTORY
  Alloc: TYPE USING [Base, Handle, Notifier, AddNotify, DropNotify, Top],
  BcdDefs: TYPE USING [Link, VersionStamp],
  CharIO: TYPE USING [CR, TAB, PutChar, PutDecimal, PutOctal, PutString],
  CompilerUtil: TYPE USING [
    AcquireStream, AcquireTable, ReleaseStream, ReleaseTable],
  DebugTable: TYPE USING [CSRptr],
  Literals: TYPE USING [Base, LitDescriptor, ltType],
  LiteralOps: TYPE USING [DescriptorValue, MasterString, StringValue],
  Strings: TYPE USING [String, SubString, SubStringDescriptor],
  Stream: TYPE USING [Handle],
  Symbols: TYPE USING [
    Base, BitAddress, CTXRecord, TransferMode, TypeClass,
    Name, SEIndex, ISEIndex, CSEIndex, CTXIndex, BTIndex,
    nullName, SENull, CTXNull, lG, lZ, RootBti, typeTYPE,
    seType, ctxType, mdType, bodyType],
  SymbolOps: TYPE USING [
    EnumerateBodies, FindExtension, NameForSe, NextSe,
    SubStringForName, TypeLink, XferMode],
  Tree: TYPE USING [Base, Index, Link, NodeName, Scan, NullIndex, treeType],
  TreeOps: TYPE USING [GetNode, ScanSons];

Debug: PROGRAM
    IMPORTS
      Alloc, CharIO, CompilerUtil, LiteralOps, SymbolOps, TreeOps
    EXPORTS CompilerUtil = {
  OPEN Symbols;

  tb: Tree.Base;
  seb: Symbols.Base;
  ctxb: Symbols.Base;
  mdb: Symbols.Base;
  bb: Symbols.Base;
  ltb: Literals.Base;

  definitionsOnly: BOOL;
  
  DebugNotify: Alloc.Notifier = {
    tb _ base[Tree.treeType];
    seb _ base[seType];  ctxb _ base[ctxType];  mdb _ base[mdType];
    bb _ base[bodyType];
    ltb _ base[Literals.ltType]};

  SubString: TYPE = Strings.SubString;

 -- basic io

  errorStream: Stream.Handle _ NIL;

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

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

  WriteDecimal: PROC [n: INTEGER] = {
    CharIO.PutDecimal[errorStream, n]};

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

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


  -- errorStream, csrP and desc.base are set by Enter

  csrP: DebugTable.CSRptr;
  desc: Strings.SubStringDescriptor;
  ss: SubString = @desc;

  LockStringTable: PROC = INLINE {
    csrP _ CompilerUtil.AcquireTable[debug];
    ss.base _ @csrP[csrP.stringOffset]};

  UnlockStringTable: PROC = INLINE {CompilerUtil.ReleaseTable[debug]; csrP _ NIL};

  Enter: PROC [table: Alloc.Handle] = {
    table.AddNotify[DebugNotify];
    errorStream _ CompilerUtil.AcquireStream[log];  LockStringTable[]};

  Exit: PROC [table: Alloc.Handle] = {
    UnlockStringTable[];  CompilerUtil.ReleaseStream[log]; errorStream _ NIL;
    table.DropNotify[DebugNotify]};

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


  -- tree printing

  PrintLiteral: PROC [t: Tree.Link.literal] = {
    WITH t.index SELECT FROM
      string => {
	s: Strings.String = LiteralOps.StringValue[sti];
	WriteChar['"];
	FOR i: CARDINAL IN [0..s.length) DO WriteChar[s[i]] ENDLOOP;
	WriteChar['"];
	IF sti # LiteralOps.MasterString[sti] THEN WriteChar['L]};
      word => {
	desc: Literals.LitDescriptor = LiteralOps.DescriptorValue[lti];
	v: WORD;
	IF desc.length # 1 THEN WriteChar['[];
	FOR i: CARDINAL IN [0 .. desc.length) DO
	  IF (v _ ltb[desc.offset][i]) < 1000 THEN WriteDecimal[v]
	  ELSE CharIO.PutOctal[errorStream, v];
	  IF i+1 # desc.length THEN WriteChar[',];
	  ENDLOOP;
	IF desc.length # 1 THEN WriteChar[']]};
      ENDCASE};

  WriteNodeName: PROC [n: Tree.NodeName] = {
    ss.offset _ csrP.NodePrintName[n].offset; ss.length _ csrP.NodePrintName[n].length;
    WriteSubString[ss]};

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

    Printer: Tree.Scan = {
      Indent[nBlanks];
      WITH s: t SELECT FROM
	hash => PrintName[s.index];
	symbol => {PrintSei[s.index]; WriteChar['[]; PrintIndex[s.index]; WriteChar[']]};
	literal => PrintLiteral[s];
	subtree => {
	  node: Tree.Index = s.index;
	  IF node = Tree.NullIndex THEN WriteString["<empty>"L]
	  ELSE {
	    OPEN tb[node];
	    WriteNodeName[name];
	    WriteChar['[];  PrintIndex[node];  WriteString["] "L];
	    IF info # 0 THEN {WriteString["  info="L]; PrintIndex[info]};
	    IF attr1 OR attr2 OR attr3 THEN {
	      IF info = 0 THEN WriteChar[' ];
	      WriteChar['(];
	      IF attr1 THEN WriteChar['1];
	      IF attr2 THEN WriteChar['2];
	      IF attr3 THEN WriteChar['3];
	      WriteChar[')]};
	    nBlanks _ nBlanks + 2;
	    IF name # thread THEN TreeOps.ScanSons[s, Printer]
	    ELSE {
	      WriteString[" link="L]; PrintIndex[TreeOps.GetNode[son[2]]];
	      Printer[son[1]]};
	    nBlanks _ nBlanks - 2}};
	ENDCASE};

    Printer[t]};


  PrintTree: PUBLIC PROC [table: Alloc.Handle, root: Tree.Link] = {
    Enter[table];
    PrintSubTree[root, 0];  NewLine[];  NewLine[];
    Exit[table]};

  PrintBodies: PUBLIC PROC [table: Alloc.Handle] = {
    Enter[table];
    [] _ SymbolOps.EnumerateBodies[RootBti, PrintBody];  NewLine[];
    Exit[table]};

  PrintBody: PROC [bti: BTIndex] RETURNS [BOOL] = {
    OPEN body: bb[bti];
    WriteString["Body: "L];
    WITH b: body SELECT FROM
      Callable => {
	PrintSei[b.id];
	IF b.inline THEN WriteString[" [inline]"L]
	ELSE {
	  WriteString[", ep: "L];  WriteDecimal[b.entryIndex];
	  WITH b SELECT FROM
	    Inner => {WriteString[", frame addr: "L]; WriteDecimal[frameOffset]};
	    ENDCASE};
	WriteString[", attrs: "L];
	WriteChar[IF ~b.noXfers THEN 'x ELSE '-];
	WriteChar[IF b.hints.safe THEN 's ELSE '-];
	WriteChar[IF b.hints.nameSafe THEN 'n ELSE '-];
	IF ~b.hints.noStrings THEN {Indent[2]; WriteString["string literals"L]}};
      ENDCASE => WriteString["(anon)"L];
    Indent[2];
    WriteString["context: "L];  PrintIndex[body.localCtx];
    WriteString[", level: "L];  WriteDecimal[body.level];
    WITH body.info SELECT FROM
      Internal => {
	WriteString[", frame size: "L];  WriteDecimal[frameSize];
	IF body.kind = Callable THEN PrintSubTree[[subtree[index: bodyTree]], 0]
	ELSE {WriteString[", tree root: "L]; PrintIndex[bodyTree]}};
      ENDCASE;
    NewLine[];  NewLine[];  RETURN [FALSE]};


  PrintSymbols: PUBLIC PROC [table: Alloc.Handle, definitions: BOOL] = {
    ctx: CTXIndex;
    limit: CTXIndex;
    Enter[table];
    definitionsOnly _ definitions;
    limit _ table.Top[Symbols.ctxType];
    ctx _ CTXIndex.FIRST + CTXRecord.nil.SIZE;
    UNTIL ctx = limit DO
      PrintContext[ctx];  NewLine[];  NewLine[];
      ctx _ ctx + (WITH ctxb[ctx] SELECT FROM
	included => CTXRecord.included.SIZE,
	imported => CTXRecord.imported.SIZE,
	ENDCASE => CTXRecord.simple.SIZE);
      ENDLOOP;
    NewLine[];
    Exit[table]};

  PrintContext: PROC [ctx: CTXIndex] = {
    sei, root: ISEIndex;
    WriteString["Context: "L];  PrintIndex[ctx];
    IF ctxb[ctx].level # lZ THEN {WriteString[", level: "L]; WriteDecimal[ctxb[ctx].level]};
    WITH c: ctxb[ctx] SELECT FROM
      included => {
	WriteString[", copied from: "L]; PrintName[mdb[c.module].moduleId];
	WriteString[" ["L]; PrintName[mdb[c.module].fileId];
	WriteString[", "L]; PrintVersion[mdb[c.module].stamp];
	WriteString["], context: "L];  PrintIndex[c.map]};
      imported => {
	WriteString[", imported from: "L]; PrintName[mdb[ctxb[c.includeLink].module].moduleId]};
      ENDCASE;
    root _ sei _ ctxb[ctx].seList;
    DO
      IF sei = SENull THEN EXIT;
      PrintSE[sei, 2];
      IF (sei _ SymbolOps.NextSe[sei]) = root THEN EXIT;
      ENDLOOP};


  PrintSE: PROC [sei: ISEIndex, nBlanks: CARDINAL] = {
    OPEN seb[sei];
    typeSei: SEIndex;
    Indent[nBlanks];
    PrintSei[sei];
    WriteString[" ["L];  PrintIndex[sei];  WriteChar[']];
    IF public THEN WriteString[" [public]"L];
    IF mark3 THEN {
      WriteString[", type = "L];
      IF idType = typeTYPE THEN {
	typeSei _ idInfo;
	WriteString["TYPE, equated to: "L];
	PrintType[typeSei];
	IF ctxb[idCtx].level = lZ AND SymbolOps.TypeLink[sei] # SENull THEN {
	  WriteString[", tag code: "L]; WriteDecimal[idValue]}}
	ELSE {
	  typeSei _ idType;  PrintType[typeSei];
	  SELECT TRUE FROM
	    constant => WriteString[" [const]"L];
	    immutable => WriteString[" [init only]"L];
	    ENDCASE;
	  IF ~mark4 THEN {WriteString[", # refs: "L]; WriteDecimal[idInfo]}
	  ELSE
	    SELECT TRUE FROM
	      constant =>
		IF ~ extended THEN {
		  WriteString[", value: "L];
		  SELECT SymbolOps.XferMode[typeSei] FROM
		    proc, program, signal, error => PrintLink[idValue];
		    ENDCASE =>
		      IF LOOPHOLE[idValue, CARDINAL] < 1000 THEN WriteDecimal[idValue]
		      ELSE CharIO.PutOctal[errorStream, idValue]};
	      (definitionsOnly AND ctxb[idCtx].level = lG) => {
		WriteString[", index: "L]; WriteDecimal[idValue]};
	      ENDCASE => {
		addr: BitAddress = idValue;
		WriteString[", address: "L];
		WriteDecimal[addr.wd];  WriteChar[' ];
		WriteChar['[];  WriteDecimal[addr.bd];
		WriteChar[':];  WriteDecimal[idInfo];  WriteChar[']];
		IF linkSpace THEN WriteChar['*]}};
	PrintTypeInfo[typeSei, nBlanks+2];
	IF extended THEN PrintSubTree[SymbolOps.FindExtension[sei].tree, nBlanks+4]}};


  PrintName: PROC [name: Name] = {
    desc: Strings.SubStringDescriptor;
    s: SubString = @desc;
    IF name = nullName THEN WriteString["(anon)"L]
    ELSE {SymbolOps.SubStringForName[s, name]; WriteSubString[s]}};

  PrintSei: PROC [sei: ISEIndex] = {PrintName[SymbolOps.NameForSe[sei]]};


  WriteTypeName: PROC [n: TypeClass] = {
    ss.offset _ csrP.TypePrintName[n].offset;  ss.length _ csrP.TypePrintName[n].length;
    WriteSubString[ss]};

  WriteModeName: PROC [n: TransferMode] = {
    ss.offset _ csrP.ModePrintName[n].offset;  ss.length _ csrP.ModePrintName[n].length;
    WriteSubString[ss]};

  PrintType: PROC [sei: SEIndex] = {
    tSei: SEIndex;
    IF sei = SENull THEN WriteChar['?]
    ELSE
      WITH t: seb[sei] SELECT FROM
	cons =>
	  WITH t SELECT FROM
	    transfer => WriteModeName[mode];
	    ENDCASE => WriteTypeName[t.typeTag];
	id =>
	  FOR tSei _ sei, SymbolOps.TypeLink[tSei] UNTIL tSei = SENull DO
	    WITH seb[tSei] SELECT FROM
	      id => {
		IF sei # tSei THEN WriteChar[' ];
		PrintSei[LOOPHOLE[tSei, ISEIndex]];
		IF ~mark3 OR ctxb[idCtx].level # lZ THEN EXIT};
	      ENDCASE;
	    ENDLOOP;
	ENDCASE;
    WriteString[" ["L];  PrintIndex[sei];  WriteChar[']]};

  PrintTypeInfo: PROC [sei: SEIndex, nBlanks: CARDINAL] = {
    IF sei # SENull THEN
      WITH s: seb[sei] SELECT FROM
	cons => {
	  Indent[nBlanks];
	  WriteChar['[];  PrintIndex[sei];  WriteString["] "L];
	  WITH s SELECT FROM
	    transfer => WriteModeName[mode];
	    ENDCASE => WriteTypeName[s.typeTag];
	  WITH t: s SELECT FROM
	    basic => NULL;
	    enumerated => {
	      IF t.machineDep THEN WriteString[" (md)"L]
	      ELSE IF t.unpainted THEN WriteString[" (~painted)"L];
	      WriteString[", value ctx: "L];  PrintIndex[t.valueCtx]};
	    record => {
	      IF t.machineDep THEN WriteString[" (md)"L];
	      IF t.monitored THEN WriteString[" (monitored)"L];
	      IF t.hints.variant THEN WriteString[" (variant)"L];
	      OutCtx[", field"L, t.fieldCtx];
	      WITH ctxb[t.fieldCtx] SELECT FROM
		included => IF ~complete THEN WriteString[" [partial]"L];
		imported => WriteString[" [partial]"L];
		ENDCASE;
	      WITH t SELECT FROM
		linked => {WriteString[", link: "L]; PrintType[linkType]};
		ENDCASE};
	    ref => {
	      SELECT TRUE FROM
		t.counted => WriteString[" (counted)"L];
		t.var => WriteString[" (var)"L];
		ENDCASE;
	      IF t.ordered THEN WriteString[" (ordered)"L];
	      IF t.basing THEN WriteString[" (base)"L];
	      WriteString[", to: "L]; PrintType[t.refType];
	      IF t.readOnly THEN WriteString[" (readonly)"L];
	      PrintTypeInfo[t.refType, nBlanks+2]};
	    array => {
	      IF t.packed THEN WriteString[" (packed)"L];
	      WriteString[", index type: "L]; PrintType[t.indexType];
	      WriteString[", component type: "L]; PrintType[t.componentType];
	      PrintTypeInfo[t.indexType, nBlanks+2];
	      PrintTypeInfo[t.componentType, nBlanks+2]};
	    arraydesc => {
	      WriteString[", described type: "L]; PrintType[t.describedType];
	      IF t.readOnly THEN WriteString[" (readonly)"L];
	      PrintTypeInfo[t.describedType, nBlanks+2]};
	    transfer => {
	      IF t.safe THEN WriteString[" (safe)"L];
	      OutArgType[", input"L, t.typeIn];
	      OutArgType[", output"L, t.typeOut]};
	    definition => {
	      WriteString[", ctx: "L];  PrintIndex[t.defCtx];
	      WriteString[", ngfi: "L];  WriteDecimal[t.nGfi]};
	    union => {
	      IF t.overlaid THEN WriteString[" (overlaid)"L];
	      IF t.controlled THEN {WriteString[", tag: "L]; PrintSei[t.tagSei]};
	      WriteString[", tag type: "L];
	      PrintType[seb[t.tagSei].idType];
	      WriteString[", case ctx: "L];  PrintIndex[t.caseCtx];
	      IF t.controlled THEN PrintSE[t.tagSei, nBlanks+2]};
	    sequence => {
	      IF t.packed THEN WriteString[" (packed)"L];
	      IF t.controlled THEN {WriteString[", tag: "L]; PrintSei[t.tagSei]}
	      ELSE {WriteString[", index type: "L];  PrintType[seb[t.tagSei].idType]};
	      WriteString[", component type: "L]; PrintType[t.componentType];
	      IF t.controlled THEN PrintSE[t.tagSei, nBlanks+2]
	      ELSE PrintTypeInfo[seb[t.tagSei].idType, nBlanks+2];
	      PrintTypeInfo[t.componentType, nBlanks+2]};
	    relative => {
	      WriteString[", base type: "L]; PrintType[t.baseType];
	      WriteString[", offset type: "L]; PrintType[t.offsetType];
	      PrintTypeInfo[t.baseType, nBlanks+2];
	      PrintTypeInfo[t.offsetType, nBlanks+2]};
	    opaque => {
	      WriteString[", id: "L]; PrintSei[t.id];
	      IF t.lengthKnown THEN {WriteString[", size: "L]; WriteDecimal[t.length]}};
	    zone => {
	      IF t.counted THEN WriteString[" (counted)"L];
	      IF t.mds THEN WriteString[" (mds)"L]};
	    subrange => {
	      WriteString[" of: "L];  PrintType[t.rangeType];
	      IF t.filled THEN {
		WriteString[" origin: "L];  WriteDecimal[t.origin];
		WriteString[", range: "L];  WriteDecimal[t.range]};
	      PrintTypeInfo[t.rangeType, nBlanks+2]};
	    long, real => {
	      WriteString[" of: "L];  PrintType[t.rangeType];
	      PrintTypeInfo[t.rangeType, nBlanks+2]};
	    ENDCASE};
	ENDCASE};

  OutCtx: PROC [message: STRING, ctx: CTXIndex] = {
    WriteString[message]; WriteString[" ctx: "L];
    IF ctx = CTXNull THEN WriteString["NIL"L] ELSE PrintIndex[ctx]};

  OutArgType: PROC [message: STRING, sei: CSEIndex] = {
    IF sei = SENull THEN {WriteString[message]; WriteString[": NIL"L]}
    ELSE
      WITH t: seb[sei] SELECT FROM
        record => OutCtx[message, t.fieldCtx];
	any => {WriteString[message]; WriteString[": ANY"L]};
	ENDCASE};

  PrintIndex: PROC [v: UNSPECIFIED] = LOOPHOLE[WriteDecimal];

  PrintLink: PROC [link: BcdDefs.Link] = {
    SELECT TRUE FROM
      link.proc => {
	WriteString["proc["L]; WriteDecimal[link.gfi]; WriteChar[',]; WriteDecimal[link.ep]};
      link.type => {WriteString["type["L]; PrintIndex[link.typeID]};
      ENDCASE => {
	WriteString["var["L]; WriteDecimal[link.gfi]; WriteChar[',]; WriteDecimal[link.var]};
    WriteChar[']]};

  PrintVersion: PROC [stamp: BcdDefs.VersionStamp] = {
    stampWords: CARDINAL = BcdDefs.VersionStamp.SIZE;
    str: PACKED ARRAY [0..4*stampWords) OF [0..16) = LOOPHOLE[stamp];
    digit: STRING = "0123456789abcdef"L;
    FOR i: NAT IN [0..4*stampWords) DO WriteChar[digit[str[i]]] ENDLOOP};

  }.