-- ListImpl.Mesa  
--   Edited by Bruce on  13-Jan-81 11:01:26
--   Edited by Sweet on  20-Mar-81 14:10:24
--   Edited by Lewis on  14-Jan-81 15:59:40
--   Edited by Satterthwaite on May 10, 1983 12:56 pm

DIRECTORY
  Ascii: TYPE USING [CR],
  BcdDefs: TYPE,
  BcdOps: TYPE USING [BcdBase, NameString],
  CommanderOps: TYPE USING [AddCommand, CommandBlockHandle],
  FileStream: TYPE USING [Create, EndOf],
  FileSegment: TYPE USING [Pages, nullPages],
  GSort: TYPE USING [
    CompareProcType, Port, PutProcType, SortItemPort, SortStarter, SortStopper, Sort],
  ListerDefs: TYPE,
  LongString: TYPE,
  OSMiscOps: TYPE USING [FileError, FindFile],
  OutputDefs: TYPE,
  Space: TYPE USING [Handle, Delete, LongPointer],
  Stream: TYPE USING [Delete, GetChar, Handle],
  Symbols: TYPE,
  SymbolTable: TYPE USING [Acquire, Base, Release];

ListImpl: PROGRAM
  IMPORTS
    CommanderOps, FileStream, GSort, ListerDefs, LongString, OSMiscOps,
    OutputDefs, Space, Stream, SymbolTable =
  BEGIN OPEN OutputDefs, BcdDefs;
  
  bcd: BcdOps.BcdBase;

  tb: Base;
  ssb: BcdOps.NameString;
  evb: Base;
  spb: Base;
  ctb: Base;
  mtb: Base;
  itb: Base;
  etb: Base;
  sgb: Base;
  ftb: Base;
  ntb: Base;
  typb: Base;
  
  InstallBcd: PROCEDURE [seg: FileSegment.Pages] RETURNS [space: Space.Handle] =
    BEGIN
    DO
      size: CARDINAL;
      space _ ListerDefs.MapPages[seg];
      bcd _ space.LongPointer;
      IF (size _ bcd.nPages) = seg.span.pages THEN EXIT;
      seg.span.pages _ size;
      Space.Delete[space];
      ENDLOOP;
    tb _ LOOPHOLE[bcd];
    ssb _ LOOPHOLE[bcd + bcd.ssOffset];
    ctb _ tb + bcd.ctOffset;
    mtb _ tb + bcd.mtOffset;
    itb _ tb + bcd.impOffset;
    etb _ tb + bcd.expOffset;
    sgb _ tb + bcd.sgOffset;
    ftb _ tb + bcd.ftOffset;
    ntb _ tb + bcd.ntOffset;
    evb _ tb + bcd.evOffset;
    spb _ tb + bcd.spOffset;
    typb _ tb + bcd.typOffset;
    RETURN
    END;
    
  UnstallBcd: PROCEDURE [space: Space.Handle] =
    BEGIN
    Space.Delete[space];
    RETURN
    END;
    
  ScanExports: PROCEDURE [action: PROC[EXPIndex]] =
    BEGIN
    eti: EXPIndex _ FIRST[EXPIndex];
    UNTIL eti = bcd.expLimit DO
      action[eti !
	ListerDefs.NoFile =>
	  BEGIN OPEN etb[eti];
	  ListerDefs.WriteString["Can't find "L];
	  WriteName[ftb[file].name];
	  ListerDefs.WriteChar[Ascii.CR];
	  CONTINUE
	  END;
	ListerDefs.MultipleModules =>
	  BEGIN OPEN etb[eti];
	  ListerDefs.WriteString["Bad format for "L];
	  WriteName[ftb[file].name];
	  ListerDefs.WriteChar[Ascii.CR];
	  CONTINUE
	  END;
	ListerDefs.NoSymbols =>
	  BEGIN OPEN etb[eti];
	  ListerDefs.WriteString["No symbols for "L];
	  WriteName[ftb[file].name];
	  ListerDefs.WriteChar[Ascii.CR];
	  CONTINUE
	  END;
	ListerDefs.IncorrectVersion =>
	  BEGIN OPEN etb[eti];
	  ListerDefs.WriteString["Wrong version: "L];
	  WriteName[ftb[file].name];
	  ListerDefs.WriteChar[Ascii.CR];
	  CONTINUE
	  END];
      UnloadSymbols[];
      eti _ eti + etb[eti].size + SIZE[EXPRecord];
      IF LOOPHOLE[eti, CARDINAL] > LOOPHOLE[bcd.expLimit, CARDINAL] THEN
	GO TO Bogus;
      REPEAT Bogus => PrintGarbage[];
      ENDLOOP;
    RETURN
    END;
    
  ExportsToSort: PROC [eti: EXPIndex] =
    BEGIN OPEN etb[eti];
    i: CARDINAL;
    n: CARDINAL _ 0;
    link: BcdDefs.Link;
    sei: Symbols.ISEIndex;
    interfaceName.length _ 0;
    AppendName[interfaceName, name];
    FOR i IN [0..size) DO
      link _ links[i];
      IF link # BcdDefs.NullLink THEN
	BEGIN
	IF ~loaded THEN LoadSymbols[file];
	sei _ SeiForItem[i];
	IF sei = Symbols.ISENull THEN LOOP;
	RecordExport[sei, TRUE];
	END;
      ENDLOOP;
    RETURN
    END;
    
  SeiForItem: PROCEDURE [item: CARDINAL] RETURNS [sei: Symbols.ISEIndex] =
    BEGIN OPEN symbols;
    FOR sei _ FirstCtxSe[stHandle.outerCtx], NextSe[sei] UNTIL sei =
      Symbols.ISENull DO
      IF seb[sei].idValue = item THEN
	SELECT LinkMode[
	  sei] FROM
	  val => IF seb[sei].extended THEN RETURN[Symbols.ISENull] ELSE RETURN;
	  ref => RETURN[sei];
	  manifest => LOOP; -- constant
	  
	  ENDCASE => RETURN[Symbols.ISENull];
      ENDLOOP;
    ERROR;
    END;

  AddInterface: PROC =
    BEGIN OPEN Symbols, symbols;
    interfaceName.length _ 0;
    LongString.AppendString[interfaceName, moduleName];
    LoadSymbolsName[moduleName !
      ListerDefs.NoFile =>
	BEGIN
	ListerDefs.WriteString["Can't find "L];
	ListerDefs.WriteString[moduleName];
	ListerDefs.WriteChar[Ascii.CR];
        GO TO cant;
	END];
    FOR sei: ISEIndex _ FirstCtxSe[stHandle.outerCtx],
	NextSe[sei] UNTIL sei = ISENull DO
      SELECT LinkMode[sei] FROM
	val, ref => RecordExport[sei, FALSE];
	ENDCASE;
      ENDLOOP;
    UnloadSymbols[];
    EXITS
      cant => NULL;
    END;
    
    
  symbols: SymbolTable.Base _ NIL;
  sseg: FileSegment.Pages _ FileSegment.nullPages;
  
  loaded: BOOLEAN _ FALSE;
  
  LoadSymbols: PROCEDURE [file: FTIndex] =
    BEGIN OPEN ListerDefs;
    s: STRING _ [60];
    IF file = FTNull OR file = FTSelf
     OR symbols # NIL OR sseg # FileSegment.nullPages THEN ERROR;
    GetBcdName[s, ftb[file].name];
    LoadSymbolsName[s];
    IF ftb[file].version # symbols.stHandle.version THEN
      SIGNAL ListerDefs.IncorrectVersion;
    END;
    
  LoadSymbolsName: PROCEDURE [s: STRING] =
    BEGIN OPEN ListerDefs;
    cseg: FileSegment.Pages;
    bs: STRING _ [50];
    LongString.AppendString[bs, s];
    FOR i: CARDINAL IN [0..bs.length) DO
      IF bs[i] = '. THEN EXIT;
      REPEAT
        FINISHED => LongString.AppendString[bs, ".bcd"L];
      ENDLOOP;
    [code: cseg, symbols: sseg] _ Load[bs ! NoCode, NoFGT => RESUME ];
    symbols _ SymbolTable.Acquire[sseg];
    SetRoutineSymbols[symbols];
    loaded _ TRUE;
    END;
    
  UnloadSymbols: PROCEDURE =
    BEGIN
    IF symbols # NIL THEN SymbolTable.Release[symbols];
    symbols _ NIL;
    sseg _ FileSegment.nullPages;
    loaded _ FALSE;
    END;
    
  -- Utility Prints
  
  
  PrintGarbage: PROCEDURE =
    BEGIN
    PutString["? looks like garbage to me ..."L];
    PutCR[];
    RETURN
    END;
    
  GetBcdName: PUBLIC PROCEDURE [s: STRING, n: NameRecord] =
    BEGIN
    i: CARDINAL;
    ssd: LongString.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    s.length _ 0;
    LongString.AppendSubString[s, @ssd];
    FOR i IN [0..s.length) DO IF s[i] = '. THEN RETURN ENDLOOP;
    LongString.AppendString[s, ".bcd"L];
    RETURN
    END;
    
  -- Utility Puts
  
  
  PutName: PUBLIC PROCEDURE [n: NameRecord] =
    BEGIN
    ssd: LongString.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    PutLongSubString[@ssd];
    RETURN
    END;
    
  AppendName: PUBLIC PROCEDURE [s: STRING, n: NameRecord] =
    BEGIN
    ssd: LongString.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    LongString.AppendSubString[s, @ssd];
    RETURN
    END;
    
  WriteName: PUBLIC PROCEDURE [n: NameRecord] =
    BEGIN
    s: LONG STRING = @ssb.string;
    last: CARDINAL = MIN[ssb.size[n], 100];
    FOR i: CARDINAL _ n, i + 1 UNTIL i >= n + last DO
      ListerDefs.WriteChar[s[i]];
      ENDLOOP;
    RETURN
    END;
    
  RecordExport: PROC [item: Symbols.ISEIndex, present: BOOLEAN] =
    BEGIN OPEN LongString;
    desc: SubStringDescriptor;
    sortLength: CARDINAL;
    buffer^ _ [
      interface: NULL, 
      module: NULL, 
      item: [length: 0, maxlength: 100, text:]];
    symbols.SubStringForName[LOOPHOLE[@desc], symbols.NameForSe[item]];
    AppendSubString[@buffer.item, @desc];
    buffer.interface _  
	LOOPHOLE[sortLength _ WordsForString[buffer.item.length] + 2];
    buffer[buffer.interface] _ [length: 0, maxlength: 100, text:];
    AppendString[@buffer[buffer.interface], interfaceName];
    sortLength _ sortLength + WordsForString[interfaceName.length];
    IF ~present THEN buffer.module _ NullString
    ELSE
      BEGIN
      buffer.module _ LOOPHOLE[sortLength];
      buffer[buffer.module] _ [length: 0, maxlength: 100, text:];
      AppendString[@buffer[buffer.module], moduleName];
      sortLength _ sortLength + WordsForString[moduleName.length];
      END;
    buffer _ OutToSort[sortLength];
    END;

  Compare: PROCEDURE [p1, p2: LONG POINTER] RETURNS [i: INTEGER] =
    BEGIN OPEN LongString;
    k1: KeyBase = p1;
    k2: KeyBase = p2;
    i _ CompareStrings[@k1[k1.interface], @k2[k2.interface]];
    IF i = 0 THEN i _ CompareStrings[@k1.item, @k2.item];
    IF i = 0 THEN i _ CompareStrings[@k1[k1.module], @k2[k2.module]];
    END;
    
  lastInterface: STRING _ [60];
  lastItem: STRING _ [60];
  first: BOOLEAN _ TRUE;

  Put: PROC [p: LONG POINTER, len: CARDINAL] =
    BEGIN
    key: KeyBase = p;
    NextItem[
      interface: @key[key.interface],
      item: @key.item,
      module: IF key.module = NullString THEN NIL ELSE @key[key.module]];
    END;
  
  NextItem: PROCEDURE [interface, item, module: LONG STRING] =
    BEGIN OPEN OutputDefs;
    IF ~LongString.EqualString[interface, lastInterface] THEN
      BEGIN
      IF ~first THEN PutChar[')];
      first _ TRUE;
      PutCR[];
      PutCR[];
      PutLongString[interface];
      lastInterface.length _ 0;
      LongString.AppendString[lastInterface, interface];
      lastItem.length _ 0;
      END;
    IF ~LongString.EqualString[item, lastItem] THEN
      {IF ~first THEN PutChar[')];
      PutCR[]; PutString["    "L]; PutLongString[item]; 
      lastItem.length _ 0; LongString.AppendString[lastItem, item];
      first _ TRUE};
    IF module # NIL THEN
      BEGIN
      IF first THEN {PutString["  ("L]; first _ FALSE}
      ELSE PutString[", "L];
      PutLongString[module];
      END;
    END;
    
  KeyBase: TYPE = LONG BASE POINTER TO SortKey;
  SortKey: TYPE = RECORD [
    interface, module: KeyBase RELATIVE POINTER TO StringBody,
    item: StringBody];
  NullString: KeyBase RELATIVE POINTER TO StringBody = LOOPHOLE[0];
  buffer: KeyBase;
  interfaceName: STRING _ [60];
  moduleName: STRING _ [40];
  
  
  OutToSort: GSort.SortItemPort;
    onLine: CARDINAL;
    firstFile: BOOLEAN _ TRUE;
  
  Implementors: PROCEDURE [fileList: STRING] =
    BEGIN OPEN OutputDefs;
    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];
    OutputDefs.OpenOutput[fileList, ".iml"L];
    PutString["Interface items implemented by:"L];
    PutCR[]; onLine _ 0;
    -- go through list of names, calling OutToSort
    UNTIL FileStream.EndOf[cs] DO
      s.length _ 0;
      WHILE ~FileStream.EndOf[cs] AND (ch _ cs.GetChar[]) # '  DO
	LongString.AppendChar[s, ch] ENDLOOP;
      IF s.length > 0 THEN
	BEGIN OPEN ListerDefs;
	WriteChar[Ascii.CR];
	WriteString["    "L];
	WriteString[s];
	ProcessFile[s];
	END;
      ENDLOOP;
    ListerDefs.WriteChar[Ascii.CR];
    Stream.Delete[cs];
    PutCR[];
    -- get ready to write output
    lastInterface.length _ 0;
    lastItem.length _ 0;
    -- shut down the sort package (and call Put many times)
    LOOPHOLE[OutToSort, GSort.SortStopper][];
    IF ~first THEN PutChar[')];
    OutputDefs.PutCR[];
    OutputDefs.CloseOutput[];
    EXITS notFound => ListerDefs.WriteLine["  Command file not found"L];
    END;

  ProcessFile: PROCEDURE [root: STRING] =
    BEGIN
    i: CARDINAL;
    bcdfile: STRING _ [40];
    file: STRING _ [40];
    seg: FileSegment.Pages;
    BEGIN
    FOR i IN [0..root.length) DO
      IF root[i] = '. THEN EXIT;
      LongString.AppendChar[bcdfile, root[i]];
      ENDLOOP;
    LongString.AppendString[file, bcdfile];
    LongString.AppendString[bcdfile, ".bcd"];
    END;
    BEGIN
    bcdSpace: Space.Handle;
    seg _ [
      file: OSMiscOps.FindFile[bcdfile, ! OSMiscOps.FileError => GO TO NoFile],
      span: [1, 1]];
    bcdSpace _ InstallBcd[seg];
    BEGIN
      name: BcdDefs.NameRecord = mtb[FIRST[BcdDefs.MTIndex]].name;
      moduleName.length _ 0; AppendName[moduleName, name];
      IF firstFile THEN firstFile _ FALSE ELSE PutChar[',];
      IF onLine + file.length > 70 THEN {PutCR[]; onLine _ 0}
	ELSE {PutChar[' ]; onLine _ onLine + 2}; -- 1 for the comma
	PutString[file]; onLine _ onLine + file.length;
      IF bcd.definitions THEN AddInterface[]
      ELSE ScanExports[ExportsToSort];
      END;
    UnstallBcd[bcdSpace];
    EXITS NoFile => ListerDefs.WriteString[" File not found"L];
    END;
    RETURN
    END;
    
  Init: PROCEDURE =
    BEGIN
    command: CommanderOps.CommandBlockHandle;
    command _ CommanderOps.AddCommand[
      "Implementors", LOOPHOLE[Implementors], 1];
    command.params[0] _ [type: string, prompt: "fileList"];
    END;
    
  Init[];
  
  END....