-- ListXref.mesa; edited by Sweet; September 9, 1980  2:21 PM

DIRECTORY
  AltoDefs USING [BYTE, PageCount],
  CommanderDefs USING [AddCommand, CommandBlockHandle],
  ControlDefs USING [CSegPrefix, FrameHandle],
  GPsortDefs USING [CompareProcType, GetProcType, PutProcType, Sort],
  InlineDefs USING [BITAND],
  IODefs USING [CR, NumberFormat, WriteChar, WriteString, WriteLine],
  ListerDefs USING [
    FileSegmentHandle, IncorrectVersion, Load, MultipleModules, NoCode, NoFGT,
    NoSymbols, SetRoutineSymbols],
  Mopcodes USING [
    zEFC0, zEFC15, zEFCB, zJ2, zJIW, zLADRB, zLFC1, zLFC16, zLFCB, zNOOP, zSFC],
  OpTableDefs USING [instaligned, instlength],
  OutputDefs USING [CloseOutput, OpenOutput, PutCR, PutString],
  SegmentDefs USING [
    DeleteFileSegment, FileNameError, FileSegmentAddress, FileSegmentHandle,
    SwapError, SwapIn, SwapOut, Unlock],
  StreamDefs USING [NewByteStream, Read, StreamHandle],
  String USING [
    AppendChar, AppendString, AppendSubString, CompareStrings, EquivalentString,
    SubString, SubStringDescriptor, WordsForString],
  Symbols USING [
    BitAddress, BTIndex, BTNull, CTXIndex, HTIndex, ISEIndex, ISENull, SENull],
  SymbolTable USING [Acquire, Base, Release, TableForSegment],
  Storage USING [Node, Free];

ListXref: PROGRAM
  IMPORTS
    CommanderDefs, GPsortDefs, InlineDefs, IODefs, ListerDefs, OpTableDefs,
    OutputDefs, SegmentDefs, StreamDefs, Storage, String, SymbolTable
  EXPORTS ListerDefs
  SHARES SymbolTable =
  BEGIN OPEN AltoDefs, OutputDefs;
  
  FileSegmentHandle: TYPE = ListerDefs.FileSegmentHandle;
  FrameHandle: TYPE = ControlDefs.FrameHandle;
  NumberFormat: TYPE = IODefs.NumberFormat;
  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: POINTER;
  codepages: PageCount;
  symbols: SymbolTable.Base;
  Tinst, Tbytes, Pinst, Pbytes: CARDINAL _ 0;
  dStar: BOOLEAN _ FALSE;
  
  KeyBase: TYPE = 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 String;
    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.SubStringForHash[@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 String;
    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 linkMap = NIL THEN ERROR;
    symbols.SubStringForHash[@desc, linkMap[link].hti];
    AppendSubString[@buffer[buffer.callee], @desc];
    AppendChar[@buffer[buffer.callee], '[];
    AppendSubString[@buffer[buffer.callee], @linkMap[link].ssd];
    AppendChar[@buffer[buffer.callee], ']];
    buffer _ OutToSort[
      WordsForString[buffer.caller.length] + WordsForString[
	buffer[buffer.callee].length] + 1];
    END;
    
  RecordUnknown: PROCEDURE =
    BEGIN OPEN String;
    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: POINTER] RETURNS [i: INTEGER] =
    BEGIN
    k1: KeyBase = p1;
    k2: KeyBase = p2;
    i _ String.CompareStrings[@k1.caller, @k2.caller];
    IF i = 0 THEN i _ String.CompareStrings[@k1[k1.callee], @k2[k2.callee]];
    END;
    
  CompareCallees: PROCEDURE [p1, p2: POINTER] RETURNS [i: INTEGER] =
    BEGIN
    k1: KeyBase = p1;
    k2: KeyBase = p2;
    i _ String.CompareStrings[@k1[k1.callee], @k2[k2.callee]];
    IF i = 0 THEN i _ String.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: STRING] =
    BEGIN OPEN OutputDefs;
    IF ~String.EquivalentString[major, lastMajor] THEN
      BEGIN
      PutCR[];
      PutCR[];
      PutString[major];
      PutCR[];
      PutString["    "L];
      onThisLine _ 4;
      first _ TRUE;
      lastMajor.length _ 0;
      String.AppendString[lastMajor, major];
      END;
    IF ~first THEN
      BEGIN
      IF String.EquivalentString[minor, lastMinor] THEN RETURN;
      PutString[", "L];
      onThisLine _ onThisLine + 2;
      IF onThisLine + minor.length > MaxOnLine THEN
	{PutCR[]; PutString["    "L]; onThisLine _ 4};
      END;
    PutString[minor];
    onThisLine _ onThisLine + minor.length;
    lastMinor.length _ 0;
    String.AppendString[lastMinor, minor];
    first _ FALSE;
    END;
    
  PutByCaller: PROCEDURE [p: POINTER, len: CARDINAL] =
    BEGIN
    key: KeyBase = p;
    NextItem[major: @key.caller, minor: @key[key.callee]];
    END;
    
  PutByCallee: PROCEDURE [p: POINTER, len: CARDINAL] =
    BEGIN
    key: KeyBase = p;
    NextItem[major: @key[key.callee], minor: @key.caller];
    END;
    
  epMap: POINTER TO ARRAY [0..0) OF Symbols.HTIndex _ 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.HashForSe[b.id];
	ENDCASE;
      END;
      
    [] _ symbols.EnumerateBodies[FIRST[Symbols.BTIndex], Count];
    epMap _ Storage.Node[n + 1];
    [] _ symbols.EnumerateBodies[FIRST[Symbols.BTIndex], Enter];
    END;
    
  LinkMapItem: TYPE = RECORD [
    hti: Symbols.HTIndex, ssd: String.SubStringDescriptor];
  linkMap: POINTER TO ARRAY [0..0) OF LinkMapItem _ NIL;
  
  CreateLinkMap: PROCEDURE =
    BEGIN
    m: CARDINAL _ 0;
    
    FindMax: PROCEDURE [sei: Symbols.ISEIndex, mname: String.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: String.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.HashForSe[sei], mname^];
	END;
      END;
      
    GenImports[FindMax];
    linkMap _ Storage.Node[(m + 1)*SIZE[LinkMapItem]];
    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: String.SubString]] =
    BEGIN OPEN Symbols, symbols;
    sei: ISEIndex;
    ctx: CTXIndex;
    bti: BTIndex;
    modnameSS: String.SubStringDescriptor;
    
    DoAction: PROCEDURE [sei: ISEIndex] = BEGIN action[sei, @modnameSS]; END;
      
    FOR sei _ FirstCtxSe[stHandle.directoryCtx], NextSe[sei] UNTIL sei = ISENull
      DO
      SubStringForHash[@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;
	transfer => BEGIN bti _ seb[sei].idInfo; ctx _ bb[bti].localCtx; END;
	ENDCASE => ERROR;
      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 OPEN InlineDefs;
    w: POINTER TO InstWord;
    w _ codebase + pc/2;
    b _
      IF BITAND[pc, 1] = 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 InlineDefs, 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
	byte _ 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 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 String, SegmentDefs, symbols, Symbols;
    i: CARDINAL;
    cseg, sseg: FileSegmentHandle;
    bcdFile: STRING _ [40];
    cspp: POINTER TO ControlDefs.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.HashForSe[b.id];
	    symbols.SubStringForHash[@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] _ Load[
      bcdFile, FALSE ! NoFGT => RESUME ; NoCode => GO TO badformat;
      NoSymbols, IncorrectVersion, MultipleModules => GOTO badformat;
      SegmentDefs.FileNameError => GOTO badname];
    SwapIn[cseg];
    codebase _ FileSegmentAddress[cseg];
    codepages _ cseg.pages;
    cspp _ codebase;
    dStar _ ~cspp.header.info.altoCode;
    symbols _ SymbolTable.Acquire[SymbolTable.TableForSegment[sseg]];
    SetRoutineSymbols[symbols];
    BEGIN OPEN s: symbols;
    main: BTIndex = FIRST[BTIndex];
    hti: HTIndex;
    CreateEpMap[];
    CreateLinkMap[];
    WITH b: s.bb[main] SELECT FROM
      Callable => hti _ s.HashForSe[b.id];
      ENDCASE => ERROR;
    moduleName.length _ 0;
    AppendChar[moduleName, '[];
    s.SubStringForHash[@desc, hti];
    AppendSubString[moduleName, @desc];
    AppendChar[moduleName, ']];
    [] _ s.EnumerateBodies[FIRST[BTIndex], SearchBody];
    END;
    SymbolTable.Release[symbols];
    DeleteFileSegment[sseg ! SwapError => CONTINUE];
    Unlock[cseg];
    SwapOut[cseg];
    DeleteFileSegment[cseg ! SwapError => CONTINUE];
    IF epMap # NIL THEN {Storage.Free[epMap]; epMap _ NIL};
    IF linkMap # NIL THEN {Storage.Free[linkMap]; linkMap _ NIL};
    EXITS
      badformat => IODefs.WriteString["--ignored (defs?)"L];
      badname => IODefs.WriteString["--not found"L];
    END;
    END;
    
  port: TYPE = MACHINE DEPENDENT RECORD [in, out: UNSPECIFIED];
  
  OutToSort: PORT [len: CARDINAL] RETURNS [POINTER];
  SortStarter: TYPE = PORT [
    get: GPsortDefs.GetProcType, put: GPsortDefs.PutProcType,
    compare: GPsortDefs.CompareProcType, expectedItemSize: CARDINAL,
    maxItemSize: CARDINAL, reservedPages: CARDINAL] RETURNS [POINTER];
  SortStopper: TYPE = PORT [len: CARDINAL _ 0];
  
  DoXref: PROCEDURE [
    fileList: STRING, Compare: GPsortDefs.CompareProcType,
    Put: GPsortDefs.PutProcType, ext: STRING] =
    BEGIN OPEN String, StreamDefs;
    s: STRING _ [50];
    ch: CHARACTER;
    -- open list of names
    cs: StreamHandle _ NewByteStream[
      fileList, Read ! SegmentDefs.FileNameError => GO TO notFound];
    -- crank up the sort package
    LOOPHOLE[OutToSort, port].out _ GPsortDefs.Sort;
    buffer _ LOOPHOLE[OutToSort, SortStarter][
      get: LOOPHOLE[@OutToSort, GPsortDefs.GetProcType], put: Put,
      compare: Compare, expectedItemSize: 40, maxItemSize: 70, reservedPages: 90];
    -- go through list of names, calling OutToSort
    UNTIL cs.endof[cs] DO
      s.length _ 0;
      WHILE ~cs.endof[cs] AND (ch _ cs.get[cs]) # '  DO
	AppendChar[s, ch]; ENDLOOP;
      IF s.length > 0 THEN
	BEGIN OPEN IODefs;
	WriteString["    "L];
	WriteString[s];
	ProcessFile[s];
	WriteChar[CR];
	END;
      ENDLOOP;
    cs.destroy[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, SortStopper][];
    OutputDefs.PutCR[];
    OutputDefs.CloseOutput[];
    EXITS notFound => IODefs.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: CommanderDefs.CommandBlockHandle;
    command _ CommanderDefs.AddCommand["XrefByCaller", LOOPHOLE[XrefByCaller], 1];
    command.params[0] _ [type: string, prompt: "Filename"];
    command _ CommanderDefs.AddCommand["XrefByCallee", LOOPHOLE[XrefByCallee], 1];
    command.params[0] _ [type: string, prompt: "Filename"];
    END;
    
  Init[];
  END.