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[];
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....