-- ListXref.mesa
-- last edited by Sweet; 20-Mar-81 11:56:48
-- last edited by Satterthwaite; May 10, 1983 1:00 pm

DIRECTORY
  Ascii USING [CR],
  BcdDefs,
  BcdOps,
  CommanderOps USING [AddCommand, CommandBlockHandle],
  FileSegment: TYPE USING [Pages],
  FileStream: TYPE USING [Create, EndOf],
  Format,
  GSort USING [CompareProcType, Port, PutProcType, Sort, SortItemPort, SortStarter, SortStopper],
  Heap: TYPE USING [systemZone],
  ListerDefs USING [
    IncorrectVersion, Load, MapPages, MultipleModules, NoCode, NoFGT, NoFile,
    NoSymbols, SetRoutineSymbols, WriteChar, WriteLine, WriteString],
  LongString USING [
    AppendChar, AppendString, AppendSubString, CompareStrings, EquivalentString,
    SubString, SubStringDescriptor, WordsForString],
  Mopcodes USING [
    zEFC0, zEFC15, zEFCB, zJ2, zJIW, zLADRB, zLFC1, zLFC16, zLFCB, zLLB, zNOOP, zSFC],
  OpTableDefs USING [InstAligned, InstLength],
  OSMiscOps: TYPE USING [FileError, FindFile],
  OutputDefs USING [CloseOutput, OpenOutput, PutCR, PutLongString, PutString],
  PrincOps USING [CSegPrefix, FrameHandle],
  Space: TYPE USING [Handle, Delete, LongPointer],
  Stream: TYPE USING [Delete, GetChar, Handle],
  Symbols USING [
    BitAddress, BTIndex, BTNull, CTXIndex, HTIndex, ISEIndex, ISENull, SENull],
  SymbolTable USING [Acquire, Base, Release];

ListXref: PROGRAM
  IMPORTS
    CommanderOps, FileStream, GSort, Heap, ListerDefs, Strings: LongString,
    OpTableDefs, OSMiscOps, OutputDefs, Space, Stream, SymbolTable =
  BEGIN OPEN ListerDefs, OutputDefs;
  
  FrameHandle: TYPE = PrincOps.FrameHandle;
  NumberFormat: TYPE = Format.NumberFormat;
  BYTE: TYPE = [0..256);
  opcode: TYPE = BYTE;
  
  JumpOp: TYPE = [Mopcodes.zJ2..Mopcodes.zJIW];
  InstWord: TYPE = MACHINE DEPENDENT RECORD [
    SELECT COMPUTED BOOLEAN FROM
    FALSE => [oddbyte, evenbyte: BYTE],
      TRUE => [evenbyte, oddbyte: BYTE],
      ENDCASE];
  
  offset: CARDINAL;
  codebase: LONG POINTER;
  codepages: CARDINAL;
  symbols: SymbolTable.Base;
  Tinst, Tbytes, Pinst, Pbytes: CARDINAL _ 0;
  dStar: BOOLEAN _ FALSE;
  
  KeyBase: TYPE = LONG BASE POINTER TO SortKey;
  SortKey: TYPE = RECORD [
    callee: KeyBase RELATIVE POINTER TO StringBody, caller: StringBody];
  buffer: KeyBase;
  callerName: STRING _ [80];
  moduleName: STRING _ [40];
  
  RecordLocal: PROCEDURE [ep: CARDINAL] =
    BEGIN OPEN Strings;
    desc: SubStringDescriptor;
    buffer^ _ [callee: NULL, caller: [length: 0, maxlength: 100, text:]];
    AppendString[@buffer.caller, callerName];
    buffer.callee _ LOOPHOLE[WordsForString[buffer.caller.length] + 1];
    buffer[buffer.callee] _ [length: 0, maxlength: 100, text:];
    IF epMap = NIL THEN ERROR;
    symbols.SubStringForName[@desc, epMap[ep]];
    AppendSubString[@buffer[buffer.callee], @desc];
    AppendString[@buffer[buffer.callee], moduleName];
    buffer _ OutToSort[
      WordsForString[buffer.caller.length] + WordsForString[
	buffer[buffer.callee].length] + 1];
    END;
    
  RecordExternal: PROCEDURE [link: CARDINAL] =
    BEGIN OPEN Strings;
    desc: SubStringDescriptor;
    offset: CARDINAL;
    buffer^ _ [callee: NULL, caller: [length: 0, maxlength: 100, text:]];
    AppendString[@buffer.caller, callerName];
    buffer.callee _ LOOPHOLE[WordsForString[buffer.caller.length] + 1];
    buffer[buffer.callee] _ [length: 0, maxlength: 100, text:];
    IF linkMap = NIL THEN ERROR;
    symbols.SubStringForName[@desc, linkMap[link].hti];
    AppendSubString[@buffer[buffer.callee], @desc];
    AppendChar[@buffer[buffer.callee], '[];
    offset _ linkMap[link].ssd.offset;
    FOR i: CARDINAL IN [0 .. linkMap[link].ssd.length) DO
      AppendChar[@buffer[buffer.callee], linkMap[link].ssd.base[offset+i]]
      ENDLOOP;
    AppendChar[@buffer[buffer.callee], ']];
    buffer _ OutToSort[
      WordsForString[buffer.caller.length] + WordsForString[
	buffer[buffer.callee].length] + 1];
    END;
    
   RecordUnknown: PROCEDURE =
    BEGIN OPEN Strings;
    buffer^ _ [callee: NULL, caller: [length: 0, maxlength: 100, text:]];
    AppendString[@buffer.caller, callerName];
    buffer.callee _ LOOPHOLE[WordsForString[buffer.caller.length] + 1];
    buffer[buffer.callee] _ [length: 1, maxlength: 100, text:];
    buffer[buffer.callee].text[0] _ '*;
    buffer _ OutToSort[WordsForString[buffer.caller.length] + 3 + 1];
    END;
    
  CompareCallers: PROCEDURE [p1, p2: LONG POINTER] RETURNS [i: INTEGER] =
    BEGIN
    k1: KeyBase = p1;
    k2: KeyBase = p2;
    i _ Strings.CompareStrings[@k1.caller, @k2.caller];
    IF i = 0 THEN i _ Strings.CompareStrings[@k1[k1.callee], @k2[k2.callee]];
    END;
    
  CompareCallees: PROCEDURE [p1, p2: LONG POINTER] RETURNS [i: INTEGER] =
    BEGIN
    k1: KeyBase = p1;
    k2: KeyBase = p2;
    i _ Strings.CompareStrings[@k1[k1.callee], @k2[k2.callee]];
    IF i = 0 THEN i _ Strings.CompareStrings[@k1.caller, @k2.caller];
    END;
    
  lastMajor: STRING _ [80];
  lastMinor: STRING _ [80];
  onThisLine: CARDINAL _ 0;
  MaxOnLine: CARDINAL _ 80;
  first: BOOLEAN _ TRUE;
  
  NextItem: PROCEDURE [major, minor: LONG STRING] =
    BEGIN OPEN OutputDefs;
    IF ~Strings.EquivalentString[major, lastMajor] THEN
      BEGIN
      PutCR[];
      PutCR[];
      PutLongString[major];
      PutCR[];
      PutString["    "L];
      onThisLine _ 4;
      first _ TRUE;
      lastMajor.length _ 0;
      Strings.AppendString[lastMajor, major];
      END;
    IF ~first THEN
      BEGIN
      IF Strings.EquivalentString[minor, lastMinor] THEN RETURN;
      PutString[", "L];
      onThisLine _ onThisLine + 2;
      IF onThisLine + minor.length > MaxOnLine THEN
	{PutCR[]; PutString["    "L]; onThisLine _ 4};
      END;
    PutLongString[minor];
    onThisLine _ onThisLine + minor.length;
    lastMinor.length _ 0;
    Strings.AppendString[lastMinor, minor];
    first _ FALSE;
    END;
    
  PutByCaller: PROCEDURE [p: LONG POINTER, len: CARDINAL] =
    BEGIN
    key: KeyBase = p;
    NextItem[major: @key.caller, minor: @key[key.callee]];
    END;
    
  PutByCallee: PROCEDURE [p: LONG POINTER, len: CARDINAL] =
    BEGIN
    key: KeyBase = p;
    NextItem[major: @key[key.callee], minor: @key.caller];
    END;
    
  EPList: TYPE = RECORD [SEQUENCE length: NAT OF Symbols.HTIndex];
  epMap: LONG POINTER TO EPList _ NIL;
  
  CreateEpMap: PROCEDURE =
    BEGIN
    n: CARDINAL _ 0;
    
    Count: PROCEDURE [bti: Symbols.BTIndex] RETURNS [stop: BOOLEAN] =
      BEGIN
      stop _ FALSE;
      WITH b: symbols.bb[bti] SELECT FROM
	Callable => IF ~b.inline THEN n _ MAX[b.entryIndex, n];
	ENDCASE;
      END;
      
    Enter: PROCEDURE [bti: Symbols.BTIndex] RETURNS [stop: BOOLEAN] =
      BEGIN
      stop _ FALSE;
      WITH b: symbols.bb[bti] SELECT FROM
	Callable =>
	  IF ~b.inline THEN epMap[b.entryIndex] _ symbols.NameForSe[b.id];
	ENDCASE;
      END;
      
    [] _ symbols.EnumerateBodies[FIRST[Symbols.BTIndex], Count];
    epMap _ (Heap.systemZone).NEW[EPList[n+1]];
    [] _ symbols.EnumerateBodies[FIRST[Symbols.BTIndex], Enter];
    END;
    
  LinkMapItem: TYPE = RECORD [
    hti: Symbols.HTIndex,
    ssd: Strings.SubStringDescriptor];
  LinkList: TYPE = RECORD [SEQUENCE length: NAT OF LinkMapItem];
  linkMap: LONG POINTER TO LinkList _ NIL;
  
  CreateLinkMap: PROCEDURE =
    BEGIN
    m: CARDINAL _ 0;
    
    FindMax: PROCEDURE [sei: Symbols.ISEIndex, mname: Strings.SubString] =
      BEGIN OPEN symbols;
      IF seb[sei].linkSpace AND ~seb[sei].constant AND ~seb[sei].extended THEN
	BEGIN a: Symbols.BitAddress = seb[sei].idValue; m _ MAX[m, a.wd]; END;
      END;
      
    Insert: PROCEDURE [sei: Symbols.ISEIndex, mname: Strings.SubString] =
      BEGIN OPEN symbols;
      IF seb[sei].linkSpace AND ~seb[sei].constant AND ~seb[sei].extended THEN
	BEGIN
	a: Symbols.BitAddress = seb[sei].idValue;
	linkMap[a.wd] _ [symbols.NameForSe[sei], mname^];
	END;
      END;
      
    GenImports[FindMax];
    linkMap _ (Heap.systemZone).NEW[LinkList[m + 1]];
    GenImports[Insert];
    END;
    
  GenCtx: PROCEDURE [ctx: Symbols.CTXIndex, p: PROCEDURE [Symbols.ISEIndex]] =
    BEGIN OPEN Symbols, symbols;
    sei: ISEIndex;
    FOR sei _ FirstCtxSe[ctx], NextSe[sei] UNTIL sei = SENull DO p[sei]; ENDLOOP;
    END;
    
  GenImports: PROCEDURE [
    action: PROC [sei: Symbols.ISEIndex, mname: Strings.SubString]] =
    BEGIN OPEN Symbols, symbols;
    sei: ISEIndex;
    ctx: CTXIndex;
    modnameSS: Strings.SubStringDescriptor;
    
    DoAction: PROCEDURE [sei: ISEIndex] = BEGIN action[sei, @modnameSS]; END;
      
    FOR sei _ FirstCtxSe[stHandle.importCtx], NextSe[sei] UNTIL sei = ISENull
      DO
      SubStringForName[@modnameSS, seb[sei].hash];
      WITH seb[UnderType[seb[sei].idType]] SELECT FROM
	definition =>
	  BEGIN
	  isei: ISEIndex;
	  ctx _ defCtx;
	  FOR isei _ FirstCtxSe[stHandle.importCtx], NextSe[isei] UNTIL isei =
	    ISENull DO
	    WITH seb[UnderType[seb[isei].idType]] SELECT FROM
	      definition =>
		WITH ctxb[defCtx] SELECT FROM
		  imported =>
		    IF includeLink = ctx THEN BEGIN ctx _ defCtx; EXIT END;
		  ENDCASE;
	      ENDCASE;
	    ENDLOOP;
	  END;
	ENDCASE;
      GenCtx[ctx, DoAction];
      WITH ctxb[ctx] SELECT FROM
	included => NULL;
	imported => GenCtx[includeLink, DoAction];
	ENDCASE => LOOP; -- main body
      
      ENDLOOP;
    END;
    
  EvenUp: PROCEDURE [n: CARDINAL] RETURNS [CARDINAL] = 
    -- Round up to an even number
    BEGIN RETURN[n + n MOD 2]; END;
    
  getbyte: PROCEDURE [pc: CARDINAL] RETURNS [b: BYTE] = 
    -- pc is a byte address
    BEGIN
    w: LONG POINTER TO InstWord;
    w _ codebase + pc/2;
    b _
      IF pc MOD 2 = 0 THEN
      (WITH w^ SELECT dStar FROM
	 FALSE => evenbyte,
	 TRUE => evenbyte,
	 ENDCASE => 0)
      ELSE
	(WITH w^ SELECT dStar FROM
	   FALSE => oddbyte,
	   TRUE => oddbyte,
	   ENDCASE => 0);
    END;
    
  getword: PROCEDURE [pc: CARDINAL] RETURNS [WORD] = 
    -- pc is a word address
    BEGIN RETURN[(codebase + pc)^]; END;
    
  ExamineCode: PROCEDURE [startcode, endcode: CARDINAL] =
    BEGIN -- list opcodes for indicated segment of code
    OPEN Mopcodes;
    inst, byte, lastInst: BYTE;
    il: [0..3];
    lastInst _ zNOOP;
    FOR offset IN [startcode..endcode) DO
      lastInst _ inst;
      inst _ getbyte[offset];
      il _ OpTableDefs.InstLength[inst];
      IF ~dStar AND OpTableDefs.InstAligned[inst] AND (offset + il) MOD 2 # 0 THEN
	[] _ getbyte[offset _ offset + 1];
      SELECT il FROM
	0, 1 =>
	  SELECT inst FROM
	    IN [zLFC1..zLFC16] => RecordLocal[inst - zLFC1 + 1];
	    IN [zEFC0..zEFC15] => RecordExternal[inst - zEFC0];
	    zSFC => IF ~(lastInst = zLADRB OR (lastInst = zLLB AND byte = 2)) THEN RecordUnknown[];
	    ENDCASE;
	2 =>
	  BEGIN
	  byte _ getbyte[(offset _ offset + 1)];
	  SELECT inst FROM
	    zLFCB => RecordLocal[byte];
	    zEFCB => RecordExternal[byte];
	    ENDCASE;
	  END;
	3 =>
	  BEGIN
	  [] _ getbyte[(offset _ offset + 1)];
	  [] _ getbyte[(offset _ offset + 1)];
	  END;
	ENDCASE;
      ENDLOOP;
    END;
    
  ProcessFile: PROCEDURE [root: STRING] =
    BEGIN OPEN Strings, symbols, Symbols;
    i: CARDINAL;
    cseg, sseg, bcdseg: FileSegment.Pages;
    codeSpace, bcdSpace: Space.Handle;
    bcd: BcdOps.BcdBase;
    mth: BcdOps.MTHandle;
    bcdFile: STRING _ [40];
    cspp: LONG POINTER TO PrincOps.CSegPrefix;
    prevBti: BTIndex _ BTNull;
    desc: SubStringDescriptor;
    
    SearchBody: PROCEDURE [bti: BTIndex] RETURNS [stop: BOOLEAN] =
      BEGIN
      ipc: CARDINAL;
      WITH b: symbols.bb[bti] SELECT FROM
	Callable =>
	  IF ~b.inline THEN
	    BEGIN
	    desc: SubStringDescriptor;
	    hti: HTIndex = symbols.NameForSe[b.id];
	    symbols.SubStringForName[@desc, hti];
	    callerName.length _ 0;
	    AppendSubString[callerName, @desc];
	    AppendString[callerName, moduleName];
	    ipc _ cspp.entry[b.entryIndex].initialpc*2;
	    WITH bi: b.info SELECT FROM
	      External => IF bi.bytes # 0 THEN ExamineCode[ipc, ipc + bi.bytes];
	      ENDCASE => ERROR;
	    END;
	ENDCASE;
      RETURN[FALSE]
      END;
      
    AppendString[bcdFile, root];
    FOR i IN [0..root.length) DO
      IF root[i] = '. THEN {bcdFile.length _ i; EXIT}; ENDLOOP;
    AppendString[bcdFile, ".bcd"L];
    BEGIN OPEN ListerDefs;
    [cseg, sseg, bcdseg] _ Load[bcdFile !
      NoFGT => RESUME ; NoCode => GO TO badformat;
      NoSymbols, IncorrectVersion, MultipleModules => GOTO badformat;
      NoFile => GOTO badname];
    bcdSpace _ MapPages[bcdseg];
    bcd _ bcdSpace.LongPointer;
    mth _ @LOOPHOLE[bcd + bcd.mtOffset, BcdDefs.Base][FIRST[BcdDefs.MTIndex]];
    codeSpace _ MapPages[cseg];
    codebase _ codeSpace.LongPointer + mth.code.offset;
    codepages _ cseg.span.pages;
    cspp _ codebase;
    dStar _ ~cspp.header.info.altoCode;
    symbols _ SymbolTable.Acquire[sseg];
    Space.Delete[bcdSpace];
    ListerDefs.SetRoutineSymbols[symbols];
    BEGIN OPEN s: symbols;
    main: BTIndex = FIRST[BTIndex];
    hti: HTIndex;
    CreateEpMap[];
    CreateLinkMap[];
    WITH b: s.bb[main] SELECT FROM
      Callable => hti _ s.NameForSe[b.id];
      ENDCASE => ERROR;
    moduleName.length _ 0;
    AppendChar[moduleName, '[];
    s.SubStringForName[@desc, hti];
    AppendSubString[moduleName, @desc];
    AppendChar[moduleName, ']];
    [] _ s.EnumerateBodies[FIRST[BTIndex], SearchBody];
    END;
    SymbolTable.Release[symbols];
    Space.Delete[codeSpace];
    IF epMap # NIL THEN (Heap.systemZone).FREE[@epMap];
    IF linkMap # NIL THEN (Heap.systemZone).FREE[@linkMap];
    EXITS
      badformat => WriteString["--ignored (defs or config?)"L];
      badname => WriteString["--not found"L];
    END;
    END;
    
  OutToSort: GSort.SortItemPort;
  
  DoXref: PROCEDURE [
    fileList: STRING, Compare: GSort.CompareProcType,
    Put: GSort.PutProcType, ext: STRING] =
    BEGIN OPEN Strings;
    s: STRING _ [50];
    ch: CHARACTER;
    -- open list of names
    cs: Stream.Handle _ FileStream.Create[
      OSMiscOps.FindFile[fileList, ! OSMiscOps.FileError => GO TO notFound]];
    -- crank up the sort package
    LOOPHOLE[OutToSort, GSort.Port].out _ GSort.Sort;
    buffer _ LOOPHOLE[OutToSort, GSort.SortStarter][
      nextItem: @OutToSort, put: Put,
      compare: Compare, expectedItemSize: 40, maxItemSize: 70, pagesInHeap: 90];
    -- go through list of names, calling OutToSort
    UNTIL FileStream.EndOf[cs] DO
      s.length _ 0;
      WHILE ~FileStream.EndOf[cs] AND (ch _ cs.GetChar[]) # '  DO
	AppendChar[s, ch]; ENDLOOP;
      IF s.length > 0 THEN
	BEGIN
	WriteString["    "L];
	WriteString[s];
	ProcessFile[s];
	WriteChar[Ascii.CR];
	END;
      ENDLOOP;
    Stream.Delete[cs];
    -- get ready to write output
    OutputDefs.OpenOutput[fileList, ext];
    lastMajor.length _ 0;
    lastMinor.length _ 0;
    -- shut down the sort package (and call Put many times)
    LOOPHOLE[OutToSort, GSort.SortStopper][];
    OutputDefs.PutCR[];
    OutputDefs.CloseOutput[];
    EXITS notFound => WriteLine["  Command file not found"L];
    END;
    
  XrefByCaller: PROCEDURE [fileList: STRING] =
    BEGIN DoXref[fileList, CompareCallers, PutByCaller, ".xlr"L]; END;
    
  XrefByCallee: PROCEDURE [fileList: STRING] =
    BEGIN DoXref[fileList, CompareCallees, PutByCallee, ".xle"L]; END;
    
  Init: PROCEDURE =
    BEGIN
    command: CommanderOps.CommandBlockHandle;
    command _ CommanderOps.AddCommand["XrefByCaller", LOOPHOLE[XrefByCaller], 1];
    command.params[0] _ [type: string, prompt: "Filename"];
    command _ CommanderOps.AddCommand["XrefByCallee", LOOPHOLE[XrefByCallee], 1];
    command.params[0] _ [type: string, prompt: "Filename"];
    END;
    
  Init[];
  END.