-- ListPub.mesa; modified by Sweet, August 28, 1980  9:50 AM

DIRECTORY
  AltoDefs USING [PageNumber, BytesPerPage],
  AltoFileDefs USING [FP],
  CommanderDefs USING [AddCommand, CommandBlockHandle],
  DirectoryDefs USING [DirectoryLookup],
  DisplayDefs USING [DisplayOn, DisplayOff],
  GPsortDefs USING [PutProcType, GetProcType, LT, EQ, GT, Sort],
  InlineDefs USING [BITXOR],
  IODefs USING [CR, WriteString],
  ListerDefs USING [
    IncorrectVersion, Load, MultipleModules, NoCode, NoFGT, NoSymbols, PrintSei,
    SetRoutineSymbols],
  OutputDefs USING [
    outStream, CloseOutput, OpenOutput, PutChar, PutCR, PutDecimal, PutNumber,
    PutOctal, PutString],
  SegmentDefs USING [
    DeleteFileSegment, DestroyFile, FileNameError, FileSegmentHandle, LockFile,
    UnlockFile, Read, SwapError],
  StreamDefs USING [
    CreateByteStream, DiskHandle, NormalizeIndex, GetIndex, GrIndex,
    NewByteStream, StreamIndex],
  String USING [
    AppendChar, AppendString, AppendSubString, SubStringDescriptor,
    WordsForString],
  SymbolTable USING [Acquire, Release, Base, SetCacheSize, TableForSegment],
  Symbols USING [
    BodyRecord, BTIndex, codeANY, SERecord, codeCHAR, codeINT, CTXIndex, HTNull,
    ISEIndex, ISENull, lZ, RecordSEIndex, RecordSENull, SEIndex, SENull,
    TransferMode, typeTYPE, CSEIndex],
  Table USING [Base, Limit];

ListPub: PROGRAM
  IMPORTS
    CommanderDefs, DirectoryDefs, DisplayDefs, GPsortDefs, InlineDefs, IODefs,
    ListerDefs, OutputDefs, SegmentDefs, StreamDefs, String, SymbolTable
  EXPORTS ListerDefs =
  BEGIN OPEN Symbols;
  
  ProcType: TYPE = PROCEDURE [root: STRING];
  
  cz: CHARACTER = 32C;
  FileTooBig: SIGNAL = CODE;
  largestItem: CARDINAL;
  lastItem: StreamDefs.StreamIndex;
  moduleList: STRING _ [40];
  inSh, outSh, sortSh: StreamDefs.DiskHandle;
  symbols: SymbolTable.Base;
  
  Cap: PROCEDURE [ch: CHARACTER] RETURNS [cap: CHARACTER] =
    BEGIN RETURN[IF ch IN ['a..'z] THEN ch - ('a - 'A) ELSE ch] END;
    
  CompareStrings: PROCEDURE [p1, p2: POINTER] RETURNS [INTEGER] =
    BEGIN OPEN GPsortDefs;
    s1: STRING _ p1;
    s2: STRING _ p2;
    idx: CARDINAL;
    c1, c2: CHARACTER;
    FOR idx IN [0..MIN[s1.length, s2.length]) DO
      c1 _ Cap[s1[idx]];
      c2 _ Cap[s2[idx]];
      SELECT c1 FROM < c2 => RETURN[LT]; > c2 => RETURN[GT]; ENDCASE;
      ENDLOOP;
    SELECT s1.length FROM
      < s2.length => RETURN[LT];
      = s2.length => RETURN[EQ];
      ENDCASE => RETURN[GT];
    END;
    
  GetItem: GPsortDefs.GetProcType =
    BEGIN
    char: CHARACTER _ 0C;
    s: STRING _ p;
    s^ _ [length: 0, maxlength: largestItem - 2, text:];
    UNTIL sortSh.endof[sortSh] DO
      char _ sortSh.get[sortSh];
      IF char = IODefs.CR THEN EXIT ELSE String.AppendChar[s, char];
      REPEAT FINISHED => RETURN[0];
      ENDLOOP;
    RETURN[String.WordsForString[s.length]]
    END;
    
  PutItem: GPsortDefs.PutProcType =
    BEGIN OPEN StreamDefs, OutputDefs;
    maxSi: StreamIndex _ NormalizeIndex[[0, 50000]];
    trailer: STRING = "l3398d2998\b"L;
    namelength: CARDINAL _ 0;
    itemString: STRING _ p;
    PutString[itemString];
    PutChar[cz];
    PutString[trailer];
    UNTIL itemString[namelength] = ': DO
      namelength _ namelength + 1;
      IF namelength > itemString.length THEN ERROR;
      ENDLOOP;
    PutDecimal[namelength];
    PutChar['B];
    PutCR[];
    IF GrIndex[GetIndex[outSh], maxSi] THEN SIGNAL FileTooBig;
    END;
    
  doPriv, xferOnly: BOOLEAN;
  
  PrintSymbols: PROCEDURE =
    BEGIN OPEN symbols, String;
    modname: STRING _ [50]; -- :SP[name]SP
    ss: SubStringDescriptor;
    mySei, sei: ISEIndex;
    thisItem: StreamDefs.StreamIndex;
    AppendString[modname, ": ["L]; -- set up modname
    FOR sei _ FirstCtxSe[stHandle.directoryCtx], NextSe[sei] UNTIL sei = ISENull
      DO mySei _ sei; ENDLOOP;
    SubStringForHash[@ss, seb[mySei].hash];
    AppendSubString[modname, @ss];
    AppendString[modname, "] "L];
    AppendSubString[moduleList, @ss];
    BlinkCursor[];
    AppendChar[moduleList, ' ];
    FOR sei _ FirstCtxSe[stHandle.outerCtx], NextSe[sei] UNTIL sei = ISENull DO
      IF (doPriv OR seb[sei].public) AND ( ~xferOnly OR XferMode[seb[sei].idType]
	# none) THEN
	BEGIN
	defaultPublic _ TRUE;
	PrintSym[sei, modname];
	OutputDefs.PutCR[];
	thisItem _ StreamDefs.GetIndex[outSh];
	largestItem _ MAX[largestItem, SiSub[thisItem, lastItem]];
	lastItem _ thisItem;
	END;
      ENDLOOP;
    END;
    
  SiSub: PROCEDURE [si1, si2: StreamDefs.StreamIndex] RETURNS [CARDINAL] =
    BEGIN OPEN AltoDefs;
    pages: PageNumber _ si1.page - si2.page;
    bytes: CARDINAL _ si1.byte - si2.byte;
    RETURN[pages*BytesPerPage + bytes]
    END;
    
  defaultPublic: BOOLEAN;
  
  PrintSym: PROCEDURE [sei: ISEIndex, colonstring: STRING] =
    BEGIN OPEN symbols;
    savePublic: BOOLEAN _ defaultPublic;
    typeSei: SEIndex;
    IF seb[sei].hash # HTNull THEN
      BEGIN ListerDefs.PrintSei[sei]; OutputDefs.PutString[colonstring]; END;
    IF seb[sei].public # defaultPublic THEN
      BEGIN
      defaultPublic _ seb[sei].public;
      OutputDefs.PutString[IF defaultPublic THEN "PUBLIC "L ELSE "PRIVATE "L];
      END;
    IF seb[sei].idType = typeTYPE THEN
      BEGIN
      typeSei _ seb[sei].idInfo;
      OutputDefs.PutString["TYPE = "L];
      [] _ PrintType[typeSei, NoSub];
      END
    ELSE
      BEGIN
      vf: ValFormat;
      typeSei _ seb[sei].idType;
      vf _ PrintType[typeSei, NoSub];
      IF seb[sei].constant AND vf.tag # none THEN
	BEGIN
	OutputDefs.PutString[" = "L];
	PrintTypedVal[seb[sei].idValue, vf];
	END;
      END;
    defaultPublic _ savePublic;
    END;
    
  PrintTypedVal: PROCEDURE [val: UNSPECIFIED, vf: ValFormat] =
    BEGIN OPEN OutputDefs;
    WITH vf SELECT FROM
      num => PrintValue[val];
      char => BEGIN PutNumber[val, [8, FALSE, TRUE, 0]]; PutChar['C] END;
      enum => PutEnum[val, esei];
      ENDCASE;
    END;
    
  PrintFieldCtx: PROCEDURE [ctx: CTXIndex] =
    BEGIN OPEN symbols, OutputDefs;
    isei: ISEIndex _ FirstCtxSe[ctx];
    first: BOOLEAN _ TRUE;
    IF isei # ISENull AND seb[isei].idCtx # ctx THEN isei _ NextSe[isei];
    IF isei = ISENull THEN BEGIN PutString["NULL"L]; RETURN END;
    PutChar['[];
    FOR isei _ isei, NextSe[isei] UNTIL isei = ISENull DO
      IF first THEN first _ FALSE ELSE PutString[", "L];
      PrintSym[isei, ": "L];
      ENDLOOP;
    PutChar[']];
    END;
    
  PrintValue: PROCEDURE [value: UNSPECIFIED] =
    BEGIN
    IF LOOPHOLE[value, CARDINAL] < 1000 THEN OutputDefs.PutDecimal[value]
    ELSE OutputDefs.PutOctal[value];
    END;
    
  NoSub: PROCEDURE [vf: ValFormat] = BEGIN RETURN END;
    
  arraySub: BOOLEAN _ FALSE;
  
  EnumeratedSEIndex: TYPE = Table.Base RELATIVE POINTER [0..Table.Limit) TO
    enumerated cons
  SERecord;
  ValFormat: TYPE = RECORD [
    SELECT tag: * FROM
    none => NULL,
      num => NULL,
      char => NULL,
      enum => [esei: EnumeratedSEIndex],
      ENDCASE];
  
  PutEnum: PROCEDURE [val: UNSPECIFIED, esei: EnumeratedSEIndex] =
    BEGIN OPEN Symbols, OutputDefs, symbols;
    sei: ISEIndex;
    FOR sei _ FirstCtxSe[seb[esei].valueCtx], NextSe[sei] WHILE sei # ISENull DO
      IF seb[sei].idValue = val THEN BEGIN ListerDefs.PrintSei[sei]; RETURN; END;
      ENDLOOP;
    PutString["LOOPHOLE ["L];
    PrintValue[val];
    PutChar[']];
    END;
    
  PrintType: PROCEDURE [tsei: SEIndex, dosub: PROCEDURE [vf: ValFormat]]
    RETURNS [vf: ValFormat] =
    BEGIN OPEN Symbols, OutputDefs, ListerDefs, symbols;
    vf _ [none[]];
    WITH t: seb[tsei] SELECT FROM
      id =>
	BEGIN OPEN Symbols;
	printBase: BOOLEAN _ TRUE;
	ifInteger: BOOLEAN _ FALSE;
	bsei: SEIndex _ tsei;
	csei: CSEIndex;
	DO
	  csei _ UnderType[bsei];
	  WITH seb[csei] SELECT FROM
	    basic =>
	      BEGIN
	      SELECT code FROM
		codeINT => BEGIN printBase _ ifInteger; vf _ [num[]] END;
		codeCHAR => vf _ [char[]];
		ENDCASE;
	      EXIT;
	      END;
	    subrange => BEGIN bsei _ rangeType; ifInteger _ TRUE END;
	    enumerated =>
	      BEGIN printBase _ TRUE; vf _ [enum[LOOPHOLE[csei]]]; EXIT END;
	    ENDCASE => EXIT;
	  ENDLOOP;
	IF printBase OR dosub = NoSub THEN
	  BEGIN
	  PrintSei[LOOPHOLE[tsei]];
	  UNTIL (tsei _ TypeLink[tsei]) = SENull DO
	    WITH seb[tsei] SELECT FROM
	      id => BEGIN PutChar[' ]; PrintSei[LOOPHOLE[tsei]] END;
	      ENDCASE;
	    ENDLOOP;
	  END;
	dosub[vf];
	END;
      cons =>
	WITH t SELECT FROM
	  --basic =>  won't see one, see the id first.
	  
	  enumerated =>
	    BEGIN
	    isei: ISEIndex;
	    first: BOOLEAN _ TRUE;
	    PutChar['{];
	    FOR isei _ FirstCtxSe[valueCtx], NextSe[isei] UNTIL isei = ISENull DO
	      IF first THEN first _ FALSE ELSE PutString[", "L];
	      PrintSei[isei];
	      ENDLOOP;
	    PutChar['}];
	    END;
	  record =>
	    BEGIN
	    IF ctxb[fieldCtx].level # lZ THEN
	      BEGIN
	      fctx: CTXIndex = fieldCtx;
	      bti: BTIndex _ FIRST[BTIndex];
	      btlimit: BTIndex = bti + stHandle.bodyBlock.size;
	      PutString["FRAME ["];
	      UNTIL bti = btlimit DO
		WITH entry: bb[bti] SELECT FROM
		  Callable =>
		    BEGIN
		    IF entry.localCtx = fctx THEN
		      BEGIN PrintSei[entry.id]; PutChar[']]; EXIT END;
		    bti _
		      bti +
			(WITH entry SELECT FROM
			   Inner => SIZE[Inner Callable BodyRecord],
			   ENDCASE => SIZE[Outer Callable BodyRecord]);
		    END;
		  ENDCASE => bti _ bti + SIZE[Other BodyRecord];
		ENDLOOP;
	      END
	    ELSE
	      BEGIN
	      IF monitored THEN PutString["MONITORED "L];
	      IF machineDep THEN PutString["MACHINE DEPENDENT "L];
	      PutString["RECORD"L];
	      PrintFieldCtx[fieldCtx];
	      END;
	    END;
	  ref =>
	    BEGIN
	    IF readOnly THEN PutString["READ ONLY "L];
	    IF ordered THEN PutString["ORDERED "L];
	    IF basing THEN PutString["BASE "L];
	    PutString["POINTER"L];
	    IF dosub # NoSub THEN BEGIN PutChar[' ]; dosub[[num[]]]; END;
	    WITH seb[UnderType[refType]] SELECT FROM
	      basic => IF code = Symbols.codeANY THEN GO TO noprint;
	      ENDCASE;
	    PutString[" TO "L];
	    [] _ PrintType[refType, NoSub];
	    EXITS noprint => NULL;
	    END;
	  array =>
	    BEGIN
	    IF packed THEN PutString["PACKED "L];
	    PutString["ARRAY "L];
	    arraySub _ TRUE;
	    [] _ PrintType[indexType, NoSub];
	    arraySub _ FALSE;
	    PutString[" OF "L];
	    [] _ PrintType[componentType, NoSub];
	    END;
	  arraydesc =>
	    BEGIN
	    PutString["DESCRIPTOR FOR "L];
	    [] _ PrintType[describedType, NoSub];
	    END;
	  transfer =>
	    BEGIN
	    PutModeName[mode];
	    IF inRecord # RecordSENull THEN
	      BEGIN PutChar[' ]; PrintFieldCtx[seb[inRecord].fieldCtx]; END;
	    IF outRecord # RecordSENull THEN
	      BEGIN
	      PutString[" RETURNS "L];
	      PrintFieldCtx[seb[outRecord].fieldCtx];
	      END;
	    END;
	  union =>
	    BEGIN
	    tagType: SEIndex;
	    PutString["SELECT "L];
	    IF ~controlled THEN
	      IF overlaid THEN PutString["OVERLAID "L]
	      ELSE PutString["COMPUTED "L]
	    ELSE BEGIN PrintSei[tagSei]; PutString[": "L] END;
	    tagType _ seb[tagSei].idType;
	    IF seb[tagSei].public # defaultPublic THEN
	      OutputDefs.PutString[
		IF defaultPublic THEN "PRIVATE "L ELSE "PUBLIC "L];
	    WITH seb[tagType] SELECT FROM
	      id => [] _ PrintType[tagType, NoSub];
	      cons => PutChar['*];
	      ENDCASE;
	    PutString[" FROM "L];
	    BEGIN
	    isei: ISEIndex;
	    first: BOOLEAN _ TRUE;
	    varRec: RecordSEIndex;
	    FOR isei _ FirstCtxSe[caseCtx], NextSe[isei] UNTIL isei = ISENull DO
	      IF first THEN first _ FALSE ELSE PutString[", "L];
	      PrintSei[isei];
	      PutString[" => "L];
	      varRec _ seb[isei].idInfo;
	      PrintFieldCtx[seb[varRec].fieldCtx];
	      ENDLOOP;
	    PutString[" ENDCASE"L];
	    END;
	    END;
	  relative =>
	    BEGIN
	    IF baseType # SENull THEN [] _ PrintType[baseType, NoSub];
	    PutString["RELATIVE "L];
	    [] _ PrintType[offsetType, dosub];
	    END;
	  subrange =>
	    BEGIN
	    org: INTEGER _ origin;
	    size: CARDINAL _ range;
	    
	    doit: PROCEDURE [pvf: ValFormat] =
	      BEGIN
	      PutChar['[];
	      PrintTypedVal[org, pvf];
	      PutString[".."L];
	      IF arraySub AND size = 177777B THEN
		BEGIN PrintTypedVal[org, pvf]; PutChar[')] END
	      ELSE BEGIN PrintTypedVal[org + size, pvf]; PutChar[']] END;
	      END;
	      
	    vf _ PrintType[rangeType, doit];
	    END;
	  long =>
	    BEGIN PutString["LONG "L]; [] _ PrintType[rangeType, NoSub]; END;
	  real => PutString["REAL"L];
	  ENDCASE => PutString["Send message to SDSUPPORT"L];
      ENDCASE;
    END;
    
  PutModeName: PROCEDURE [n: TransferMode] =
    BEGIN
    ModePrintName: ARRAY TransferMode OF STRING =
      ["PROCEDURE"L, "PORT"L, "SIGNAL"L, "ERROR"L, "PROCESS"L, "PROGRAM"L,
	"NONE"L];
    OutputDefs.PutString[ModePrintName[n]]
    END;
    
  DoSymbols: PROCEDURE [bcdFile: STRING] =
    BEGIN OPEN ListerDefs;
    defs: BOOLEAN _ FALSE;
    cseg, sseg: SegmentDefs.FileSegmentHandle;
    BEGIN
    [code: cseg, symbols: sseg] _ Load[
      bcdFile ! NoFGT => RESUME ; NoCode => RESUME ; -- language feature
       NoSymbols, IncorrectVersion, MultipleModules => GOTO badformat;
      SegmentDefs.FileNameError => GOTO badname];
    IF cseg # NIL THEN SegmentDefs.DeleteFileSegment[cseg];
    DisplayDefs.DisplayOff[black];
    symbols _ SymbolTable.Acquire[SymbolTable.TableForSegment[sseg]];
    SetRoutineSymbols[symbols];
    PrintSymbols[];
    SymbolTable.Release[symbols];
    SymbolTable.SetCacheSize[0];
    SegmentDefs.DeleteFileSegment[sseg ! SegmentDefs.SwapError => CONTINUE];
    EXITS
      badformat =>
	BEGIN OPEN IODefs;
	DisplayDefs.DisplayOn[];
	WriteString[bcdFile];
	WriteString[" Has A Bad Format!"L];
	END;
      badname =>
	BEGIN OPEN IODefs;
	DisplayDefs.DisplayOn[];
	WriteString[bcdFile];
	WriteString[" Not Found!"L];
	END;
    END;
    END;
    
   -- Of DoSymbols
  
  
  AppendBcd: PROCEDURE [s: STRING] =
    BEGIN
    i: CARDINAL;
    FOR i IN [0..s.length) DO
      IF s[i] = '. THEN BEGIN s.length _ i; EXIT END ENDLOOP;
    String.AppendString[s, ".bcd"L];
    END;
    
  globalRoot: STRING;
  
  DoIt: PROCEDURE [root: STRING, myDoPriv, myXferOnly: BOOLEAN] =
    BEGIN OPEN SegmentDefs, OutputDefs;
    list: BOOLEAN;
    bcdFile: STRING _ [40];
    sortFile: STRING _ "2.xref";
    fp: AltoFileDefs.FP;
    globalRoot _ root;
    doPriv _ myDoPriv;
    xferOnly _ myXferOnly;
    String.AppendString[bcdFile, root];
    AppendBcd[bcdFile];
    list _ NOT DirectoryDefs.DirectoryLookup[@fp, bcdFile, FALSE];
    largestItem _ 0;
    lastItem _ [0, 0];
    OutputDefs.OpenOutput[root, ".scratch$"L];
    outSh _ LOOPHOLE[outStream];
    IF list THEN
      BEGIN OPEN StreamDefs;
      inSh _ NewByteStream[root, Read ! FileNameError => GOTO badname];
      GPsortDefs.Sort[GetName, PutName, CompareStrings, 22, 22, 140];
      PutChar[cz];
      PutChar['j];
      PutCR[]; -- trailer for module list
      inSh.destroy[inSh];
      EXITS badname => BEGIN IODefs.WriteString["File Not Found!"L]; RETURN END;
      END
    ELSE
      BEGIN
      DoSymbols[bcdFile];
      ChangeOutput[];
      PutString[moduleList];
      moduleList.length _ 0;
      PutChar[cz];
      PutChar['c];
      PutCR[]; -- trailer for heading
      
      END;
    PutChar[cz];
    PutCR[]; -- skip a line
    largestItem _ largestItem + 20; -- a little slop
    BlinkCursor[];
    GPsortDefs.Sort[
      GetItem, PutItem, CompareStrings, 100, largestItem/2, 15 !
      FileTooBig =>
	BEGIN
	CloseOutput[];
	OpenOutput[root, sortFile];
	outSh _ LOOPHOLE[outStream];
	sortFile[0] _ sortFile[0] + 1;
	RESUME
	END];
    DisplayDefs.DisplayOn[];
    sortSh.destroy[sortSh];
    UnlockFile[sortSh.file];
    DestroyFile[sortSh.file];
    CloseOutput[];
    END;
    
  BlinkCursor: PROCEDURE =
    BEGIN
    map: POINTER TO WORD = LOOPHOLE[431B];
    i: CARDINAL;
    FOR i IN [0..16) DO
      (map + i)^ _ InlineDefs.BITXOR[(map + i)^, 177777B]; ENDLOOP;
    FOR i IN [0..1000) DO NULL ENDLOOP; -- wait a little while
    FOR i IN [0..16) DO
      (map + i)^ _ InlineDefs.BITXOR[(map + i)^, 177777B]; ENDLOOP;
    END;
    
  ChangeOutput: PROCEDURE =
    BEGIN OPEN SegmentDefs, OutputDefs;
    LockFile[outSh.file];
    CloseOutput[];
    sortSh _ StreamDefs.CreateByteStream[outSh.file, Read];
    OpenOutput[globalRoot, ".xref"L];
    outSh _ LOOPHOLE[outStream];
    PutString["PUBLIC SYMBOLS FOR "L];
    END;
    
  GetName: GPsortDefs.GetProcType =
    BEGIN OPEN String;
    char: CHARACTER _ 0C;
    file: STRING _ [40];
    s: STRING _ p;
    s^ _ [length: 0, maxlength: 40, text:];
    UNTIL inSh.endof[inSh] DO
      char _ inSh.get[inSh];
      SELECT char FROM
	'-, '., '$ => AppendChar[file, char];
	IN ['0..'9] => AppendChar[file, char];
	IN ['A..'Z] => AppendChar[file, char];
	IN ['a..'z] => AppendChar[file, char];
	ENDCASE => IF file.length # 0 THEN EXIT;
      REPEAT
	FINISHED =>
	  BEGIN OPEN OutputDefs;
	  ChangeOutput[];
	  PutChar[cz];
	  PutChar['c];
	  PutCR[]; -- trailer for heading
	  RETURN[0];
	  END;
      ENDLOOP;
    AppendBcd[file];
    DoSymbols[file];
    AppendString[s, moduleList];
    moduleList.length _ 0;
    RETURN[WordsForString[s.length]]
    END;
    
  PutName: GPsortDefs.PutProcType =
    BEGIN s: STRING _ LOOPHOLE[p]; OutputDefs.PutString[s]; END;
    
  -- mainline
  
  command: CommanderDefs.CommandBlockHandle;
  
  command _ CommanderDefs.AddCommand["Xref", LOOPHOLE[DoIt], 3];
  command.params[0] _ [type: string, prompt: "Filename"];
  command.params[1] _ [type: boolean, prompt: "Include Private Symbols?"];
  command.params[2] _ [type: boolean, prompt: "Procedures Only?"];
  
  END...