-- ListImpl.Mesa  
--   Edited by Sweet on  3-Sep-80 12:36:48

DIRECTORY
  AltoDefs: FROM "altodefs",
  BcdDefs,
  BcdOps USING [NameString],
  CommanderDefs USING [AddCommand, CommandBlockHandle],
  GPsortDefs USING [CompareProcType, GetProcType, PutProcType, Sort],
  IODefs,
  ListerDefs,
  OutputDefs,
  SegmentDefs,
  StreamDefs,
  String,
  Symbols,
  SymbolTable USING [Acquire, Base, Release, TableForSegment];

ListImpl: PROGRAM
  IMPORTS
    CommanderDefs, GPsortDefs, IODefs, ListerDefs, OutputDefs, SegmentDefs, 
    StreamDefs, String, SymbolTable =
  BEGIN OPEN OutputDefs, BcdDefs;
  
  bcd: POINTER TO BCD;
  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: SegmentDefs.FileSegmentHandle] =
    BEGIN OPEN SegmentDefs;
    size: CARDINAL;
    SwapIn[seg];
    bcd _ FileSegmentAddress[seg];
    IF (size _ bcd.nPages) # seg.pages THEN
      BEGIN
      Unlock[seg];
      MoveFileSegment[seg, seg.base, size];
      SwapIn[seg];
      bcd _ FileSegmentAddress[seg];
      END;
    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 [seg: SegmentDefs.FileSegmentHandle] =
    BEGIN OPEN SegmentDefs;
    IF seg.swappedin THEN Unlock[seg];
    SwapOut[seg];
    RETURN
    END;
    
  ScanExports: PROCEDURE [action: PROC[EXPIndex]] =
    BEGIN
    eti: EXPIndex _ FIRST[EXPIndex];
    UNTIL eti = bcd.expLimit DO
      action[eti !
	SegmentDefs.FileNameError =>
	  BEGIN OPEN IODefs, etb[eti];
	  WriteString["Can't find "L];
	  WriteName[ftb[file].name];
	  WriteChar[CR];
	  CONTINUE
	  END;
	ListerDefs.MultipleModules =>
	  BEGIN OPEN IODefs, etb[eti];
	  WriteString["Bad format for "L];
	  WriteName[ftb[file].name];
	  WriteChar[CR];
	  CONTINUE
	  END;
	ListerDefs.NoSymbols =>
	  BEGIN OPEN IODefs, etb[eti];
	  WriteString["No symbols for "L];
	  WriteName[ftb[file].name];
	  WriteChar[CR];
	  CONTINUE
	  END;
	ListerDefs.IncorrectVersion =>
	  BEGIN OPEN IODefs, etb[eti];
	  WriteString["Wrong version: "L];
	  WriteName[ftb[file].name];
	  WriteChar[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;
    String.AppendString[interfaceName, moduleName];
    LoadSymbolsName[moduleName !
      SegmentDefs.FileNameError =>
	BEGIN OPEN IODefs;
	WriteString["Can't find "L];
	WriteString[moduleName];
	WriteChar[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: SegmentDefs.FileSegmentHandle _ NIL;
  
  loaded: BOOLEAN _ FALSE;
  
  LoadSymbols: PROCEDURE [file: FTIndex] =
    BEGIN OPEN ListerDefs;
    s: STRING _ [60];
    IF file = FTNull OR file = FTSelf OR symbols # NIL OR sseg # NIL 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: SegmentDefs.FileSegmentHandle;
    bs: STRING _ [50];
    String.AppendString[bs, s];
    FOR i: CARDINAL IN [0..bs.length) DO
      IF bs[i] = '. THEN EXIT;
      REPEAT
        FINISHED => String.AppendString[bs, ".bcd"L];
      ENDLOOP;
    [code: cseg, symbols: sseg] _ Load[bs ! NoCode, NoFGT => RESUME ];
    IF cseg # NIL THEN SegmentDefs.DeleteFileSegment[cseg];
    symbols _ SymbolTable.Acquire[SymbolTable.TableForSegment[sseg]];
    SetRoutineSymbols[symbols];
    loaded _ TRUE;
    END;
    
  UnloadSymbols: PROCEDURE =
    BEGIN OPEN SegmentDefs;
    IF symbols # NIL THEN SymbolTable.Release[symbols];
    IF sseg # NIL THEN DeleteFileSegment[sseg ! SwapError => CONTINUE];
    symbols _ NIL;
    sseg _ NIL;
    loaded _ FALSE;
    END;
    
  -- Utility Prints
  
  
  PrintGarbage: PROCEDURE =
    BEGIN
    PutString["? looks like garbage to me ..."];
    PutCR[];
    RETURN
    END;
    
  GetBcdName: PUBLIC PROCEDURE [s: STRING, n: NameRecord] =
    BEGIN
    i: CARDINAL;
    ssd: String.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    s.length _ 0;
    String.AppendSubString[s, @ssd];
    FOR i IN [0..s.length) DO IF s[i] = '. THEN RETURN ENDLOOP;
    String.AppendString[s, ".bcd"L];
    RETURN
    END;
    
  -- Utility Puts
  
  
  PutName: PUBLIC PROCEDURE [n: NameRecord] =
    BEGIN
    ssd: String.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    PutSubString[@ssd];
    RETURN
    END;
    
  AppendName: PUBLIC PROCEDURE [s: STRING, n: NameRecord] =
    BEGIN
    ssd: String.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    String.AppendSubString[s, @ssd];
    RETURN
    END;
    
  WriteName: PUBLIC PROCEDURE [n: NameRecord] =
    BEGIN
    ssd: String.SubStringDescriptor _
      [base: @ssb.string, offset: n, length: MIN[ssb.size[n], 100]];
    IODefs.WriteSubString[@ssd];
    RETURN
    END;
    
  RecordExport: PROC [item: Symbols.ISEIndex, present: BOOLEAN] =
    BEGIN OPEN String;
    desc: String.SubStringDescriptor;
    sortLength: CARDINAL;
    buffer^ _ [
      interface: NULL, 
      module: NULL, 
      item: [length: 0, maxlength: 100, text:]];
    symbols.SubStringForHash[@desc, symbols.HashForSe[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: POINTER] RETURNS [i: INTEGER] =
    BEGIN
    k1:KeyBase = p1;
    k2: KeyBase = p2;
    i _ String.CompareStrings[@k1[k1.interface], @k2[k2.interface]];
    IF i = 0 THEN i _ String.CompareStrings[@k1.item, @k2.item];
    IF i = 0 THEN i _ String.CompareStrings[@k1[k1.module], @k2[k2.module]];
    END;
    
  lastInterface: STRING _ [60];
  lastItem: STRING _ [60];
  first: BOOLEAN _ TRUE;

  Put: PROC [p: 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: STRING] =
    BEGIN OPEN OutputDefs;
    IF ~String.EqualString[interface, lastInterface] THEN
      BEGIN
      IF ~first THEN PutChar[')];
      first _ TRUE;
      PutCR[];
      PutCR[];
      PutString[interface];
      lastInterface.length _ 0;
      String.AppendString[lastInterface, interface];
      lastItem.length _ 0;
      END;
    IF ~String.EqualString[item, lastItem] THEN
      {IF ~first THEN PutChar[')];
      PutCR[]; PutString["    "L]; PutString[item]; 
      lastItem.length _ 0; String.AppendString[lastItem, item];
      first _ TRUE};
    IF module # NIL THEN
      BEGIN
      IF first THEN {PutString["  ("L]; first _ FALSE}
      ELSE PutString[", "L];
      PutString[module];
      END;
    END;
    
  KeyBase: TYPE = 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];
  
  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];
    onLine: CARDINAL;
    firstFile: BOOLEAN _ TRUE;
  
  Implementors: PROCEDURE [fileList: STRING] =
    BEGIN OPEN String, StreamDefs, OutputDefs;
    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];
    OutputDefs.OpenOutput[fileList, ".iml"];
    PutString["Interface items implemented by:"];
    PutCR[]; onLine _ 0;
    -- 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;
	WriteChar[CR];
	WriteString["    "L];
	WriteString[s];
	ProcessFile[s];
	END;
      ENDLOOP;
    IODefs.WriteChar[IODefs.CR];
    cs.destroy[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, SortStopper][];
    IF ~first THEN PutChar[')];
    OutputDefs.PutCR[];
    OutputDefs.CloseOutput[];
    EXITS notFound => IODefs.WriteLine["  Command file not found"L];
    END;

  ProcessFile: PROCEDURE [root: STRING] =
    BEGIN
    i: CARDINAL;
    bcdfile: STRING _ [40];
    file: STRING _ [40];
    seg: SegmentDefs.FileSegmentHandle;
    BEGIN OPEN String;
    FOR i IN [0..root.length) DO
      IF root[i] = '. THEN EXIT;
      AppendChar[bcdfile, root[i]];
      ENDLOOP;
    AppendString[file, bcdfile];
    AppendString[bcdfile, ".bcd"];
    END;
    BEGIN OPEN SegmentDefs;
    seg _ NewFileSegment[
      NewFile[bcdfile, Read, DefaultVersion ! FileNameError => GO TO NoFile], 1,
      1, Read];
    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[seg];
    EXITS NoFile => IODefs.WriteString[" File not found"];
    END;
    RETURN
    END;
    
  Init: PROCEDURE =
    BEGIN
    command: CommanderDefs.CommandBlockHandle;
    command _ CommanderDefs.AddCommand[
      "Implementors", LOOPHOLE[Implementors], 1];
    command.params[0] _ [type: string, prompt: "fileList"];
    END;
    
  Init[];
  
  END....