Simtel MSDOS 1992 December/simtel1292_SIMTEL_1292_Walnut_Creek.iso/msdos/ddjmag/ddj8911.arc/HEJLSBER.LST

File List | 1989-10-04 | 12KB | 628 lines

_CONTAINER OBJECT TYPES IN TURBO PASCAL_
by Anders Hejlsberg

[LISTING ONE]

unit Contain;

{$S-}

interface

type

{ Base object type }

  Base = object
    destructor Done; virtual;
  end;

{ Abstract linked list node type }

  ListNodePtr = ^ListNode;
  ListNode = object(Base)
    Next: ListNodePtr;
    function Prev: ListNodePtr;
  end;

{ Linked list iteration procedure type }

  ListAction = procedure(N: ListNodePtr);

{ Linked list type }

  ListPtr = ^List;

  List = object(Base)
    Last: ListNodePtr;
    constructor Init;
    destructor Done; virtual;
    procedure Append(N: ListNodePtr);
    procedure Delete;
    function Empty: Boolean;
    procedure ForEach(Action: ListAction);
    function First: ListNodePtr;
    procedure Insert(N: ListNodePtr);
    function Next(N: ListNodePtr): ListNodePtr;
    function Prev(N: ListNodePtr): ListNodePtr;
    procedure Remove(N: ListNodePtr);
  end;

{ Abstract binary node type }

  TreeNodePtr = ^TreeNode;
  TreeNode = object(Base)
    Left, Right: TreeNodePtr;
  end;

{ Binary tree iteration procedure type }

  TreeAction = procedure(N: TreeNodePtr);

{ Binary tree node creation procedure type }

  TreeCreate = function(Key: Pointer): TreeNodePtr;

{ Binary tree type }

  TreePtr = ^Tree;
  Tree = object(Base)
    Root: TreeNodePtr;
    constructor Init;
    destructor Done; virtual;
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    procedure Delete;
    function Empty: Boolean;
    function Find(Key: Pointer): TreeNodePtr;
    procedure ForEach(Action: TreeAction);
    function GetKey(N: TreeNodePtr): Pointer; virtual;
    procedure Insert(N: TreeNodePtr);
    function Search(Key: Pointer; Create: TreeCreate):
TreeNodePtr;
  end;

implementation

{ Base methods }

destructor Base.Done;
begin
end;

{ ListNode methods }

function ListNode.Prev: ListNodePtr;
var
  P: ListNodePtr;
begin
  P :=  Self;
  while P^.Next <>  Self do P := P^.Next;

  Prev := P;
end;

{ List methods }

{$F+}

procedure DelListNode(N: ListNodePtr);
begin
  Dispose(N, Done);
end;

{$F-}

constructor List.Init;
begin
  Last := nil;
end;

destructor List.Done;
begin

  Delete;
end;

procedure List.Append(N: ListNodePtr);
begin
  Insert(N);
  Last := N;
end;

procedure List.Delete;
begin
  ForEach(DelListNode);
  Last := nil;
end;

function List.Empty: Boolean;
begin
  Empty := Last = nil;
end;

procedure List.ForEach(Action: ListAction);

var
  P, Q: ListNodePtr;
begin
  P := First;
  while P <> nil do
  begin
    Q := P;
    P := Next(P);
    Action(Q);
  end;
end;

function List.First: ListNodePtr;
begin
  if Last = nil then First := nil else First := Last^.Next;
end;

procedure List.Insert(N: ListNodePtr);
begin
  if Last = nil then Last := N else N^.Next := Last^.Next;
  Last^.Next := N;

end;

function List.Next(N: ListNodePtr): ListNodePtr;
begin
  if N = Last then Next := nil else Next := N^.Next;
end;

function List.Prev(N: ListNodePtr): ListNodePtr;
begin
  if N = First then Prev := nil else Prev := N^.Prev;
end;

procedure List.Remove(N: ListNodePtr);
var
  P: ListNodePtr;
begin
  if Last <> nil then
  begin
    P := Last;
    while (P^.Next <> N) and (P^.Next <> Last) do P := P^.Next;
    if P^.Next = N then

    begin
      P^.Next := N^.Next;
      if Last = N then if P = N then Last := nil else Last := P;
    end;
  end;
end;

{ Tree methods }

var
  NewTreeNode: TreeNodePtr;

{$F+}

function GetTreeNode(Key: Pointer): TreeNodePtr;
begin
  GetTreeNode := NewTreeNode;
end;

procedure DelTreeNode(N: TreeNodePtr);
begin

  Dispose(N, Done);
end;

{$F-}

constructor Tree.Init;
begin
  Root := nil;
end;

destructor Tree.Done;
begin
  Delete;
end;

function Tree.Compare(Key1, Key2: Pointer): Integer;
begin
  Compare := 0;
end;

procedure Tree.Delete;

begin
  ForEach(DelTreeNode);
  Root := nil;
end;

function Tree.Empty: Boolean;
begin
  Empty := Root = nil;
end;

function Tree.Find(Key: Pointer): TreeNodePtr;
begin
  NewTreeNode := nil;
  Find := Search(Key, GetTreeNode);
end;

procedure Tree.ForEach(Action: TreeAction);

  procedure Traverse(P: TreeNodePtr);
  var
    R: TreeNodePtr;

  begin
    if P <> nil then
    begin
      R := P^.Right;
      Traverse(P^.Left);
      Action(P);
      Traverse(R);
    end;
  end;

begin
  Traverse(Root);
end;

function Tree.GetKey(N: TreeNodePtr): Pointer;
begin
  GetKey := N;
end;

procedure Tree.Insert(N: TreeNodePtr);
begin

  NewTreeNode := N;
  N := Search(GetKey(N), GetTreeNode);
end;

function Tree.Search(Key: Pointer; Create: TreeCreate):
TreeNodePtr;

  procedure Traverse(var P: TreeNodePtr);
  var
    C: Integer;
  begin
    if P = nil then
    begin
      P := Create(Key);
      P^.Left := nil;
      P^.Right := nil;
      Search := P;
    end else
    begin
      C := Compare(Key, GetKey(P));
      if C < 0 then Traverse(P^.Left) else
        if C > 0 then Traverse(P^.Right) else

          Search := P;
    end;
  end;

begin
  Traverse(Root);
end;

end.


[LISTING TWO]

program CrossRef;

{$S-}
{$M 8192,8192,655360}

uses Contain;


const

  MaxIdentLen = 20;      { Maximum identifier length }
  LineNoWidth = 6;       { Width of line numbers in listing }
  RefPerLine  = 8;       { Line numbers per line in
cross-reference }
  IOBufSize   = 4096;    { Input/Output buffer size }

  FormFeed  = #12;
  EndOfLine = #13;
  EndOfFile = #26;

type

{ Input/Output buffer }

  IOBuffer = array[1..IOBufSize] of Char;

{ Identifier string }

  IdentPtr = ^Ident;
  Ident = string[MaxIdentLen];

{ Line reference object }

  LineRefPtr = ^LineRef;
  LineRef = object(ListNode)
    LineNo: Integer;
    constructor Init(Line: Integer);
  end;

{ Identifier reference object }

  IdentRefPtr = ^IdentRef;
  IdentRef = object(TreeNode)
    Lines: List;
    Name: IdentPtr;
    constructor Init(S: Ident);
    destructor Done; virtual;
  end;

{ Identifier tree }

  IdentTreePtr = ^IdentTree;
  IdentTree = object(Tree)
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    function GetKey(N: TreeNodePtr): Pointer; virtual;
  end;

const

{ Turbo Pascal reserved words }

  KeyWordCount = 52;
  KeyWord: array[1..KeyWordCount] of string[15] = (
    'ABSOLUTE', 'AND', 'ARRAY', 'BEGIN', 'CASE', 'CONST',
    'CONSTRUCTOR', 'DESTRUCTOR', 'DIV', 'DO', 'DOWNTO', 'ELSE',
    'END', 'EXTERNAL', 'FILE', 'FOR', 'FORWARD', 'FUNCTION',
    'GOTO', 'IF', 'IMPLEMENTATION', 'IN', 'INLINE', 'INTERFACE',
    'INTERRUPT', 'LABEL', 'MOD', 'NIL', 'NOT', 'OBJECT', 'OF',
    'OR', 'PACKED', 'PROCEDURE', 'PROGRAM', 'RECORD', 'REPEAT',
    'SET', 'SHL', 'SHR', 'STRING', 'THEN', 'TO', 'TYPE', 'UNIT',
    'UNTIL', 'USES', 'VAR', 'VIRTUAL', 'WHILE', 'WITH', 'XOR');


var

  Idents: IdentTree;         { Tree of IdentRef objects }
  LineCount: Integer;        { Current line number }
  RefCount: Integer;         { Counter used by PrintLine }
  InputBuffer: IOBuffer;     { Standard input buffer }
  OutputBuffer: IOBuffer;    { Standard output buffer }

{ LineRef constructor }

constructor LineRef.Init(Line: Integer);
begin
  LineNo := Line;
end;

{ IdentRef constructor }

constructor IdentRef.Init(S: Ident);
begin
  Lines.Init;
  GetMem(Name, Length(S) + 1);

  Name^ := S;
end;

{ IdentRef destructor }

destructor IdentRef.Done;
begin
  FreeMem(Name, Length(Name^) + 1);
  Lines.Done;
end;

{ Compare keys of two IdentRef objects in an IdentTree }

function IdentTree.Compare(Key1, Key2: Pointer): Integer;
begin
  if IdentPtr(Key1)^ < IdentPtr(Key2)^ then Compare := -1 else
  if IdentPtr(Key1)^ > IdentPtr(Key2)^ then Compare := 1 else
  Compare := 0;
end;

{ Return the key of an IdentRef object in an IdentTree }

function IdentTree.GetKey(N: TreeNodePtr): Pointer;
begin
  GetKey := IdentRefPtr(N)^.Name;
end;

{ Insert keywords in identifier tree }

procedure InsertKeyWord(L, R: Integer);
var
  I: Integer;
begin
  I := (L + R) div 2;
  Idents.Insert(New(IdentRefPtr, Init(KeyWord[I])));
  if L < I then InsertKeyWord(L, I - 1);
  if I < R then InsertKeyWord(I + 1, R);
end;

{$F+}

{ Create and return a new IdentRef object }

function NewIdent(Key: Pointer): TreeNodePtr;
var
  P: IdentRefPtr;
begin
  New(P, Init(IdentPtr(Key)^));
  P^.Lines.Append(New(LineRefPtr, Init(LineCount)));
  NewIdent := P;
end;

{$F-}

{ Process input file and print listing }

procedure ProcessFile;
var
  Ch: Char;

{ Get next character from input file }

procedure GetChar;

begin
  if Eof then Ch := EndOfFile else
  begin
    if Ch = EndOfLine then
    begin
      Inc(LineCount);
      Write(LineCount: LineNoWidth, ': ');
    end;
    if not Eoln then
    begin
      Read(Ch);
      Write(Ch);
      if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);
    end else
    begin
      ReadLn;
      WriteLn;
      Ch := EndOfLine;
    end;
  end;
end;

{ Get next token from input file }

procedure GetToken;

{ Get identifier from input file and enter into tree }

procedure GetIdent;
var
  Name: Ident;
  P: LineRefPtr;
begin
  Name := '';
  repeat
    if Length(Name) < MaxIdentLen then
    begin
      Inc(Name[0]);
      Name[Length(Name)] := Ch;
    end;
    GetChar;
  until ((Ch < '0') or (Ch > '9')) and

    ((Ch < 'A') or (Ch > 'Z')) and (Ch <> '_');
  with IdentRefPtr(Idents.Search( Name, NewIdent))^ do
    if not Lines.Empty then
      if LineRefPtr(Lines.Last)^.LineNo <> LineCount then
        Lines.Append(New(LineRefPtr, Init(LineCount)));
end;

begin { GetToken }
  case Ch of
    'A'..'Z', '_':
      GetIdent;
    '''':
      repeat
        repeat
          GetChar;
        until (Ch = '''') or (Ch = EndOfFile);
        GetChar;
      until (Ch <> '''');
    '$':
      repeat
        GetChar;

      until ((Ch < '0') or (Ch > '9')) and
            ((Ch < 'A') or (Ch > 'F'));
    '{':
      begin
        repeat
          GetChar;
        until (Ch = '}') or (Ch = EndOfFile);
        GetChar;
      end;
    '(':
      begin
        GetChar;
        if Ch = '*' then
        begin
          GetChar;
          repeat
            while (Ch <> '*') and (Ch <> EndOfFile) do GetChar;
            GetChar;
          until (Ch = ')') or (Ch = EndOfFile);
          GetChar;
        end;

      end;
  else
    GetChar;
  end;
end;

begin { ProcessFile }
  Ch := EndOfLine;
  GetChar;
  while (Ch <> EndOfFile) do GetToken;
  Write(FormFeed, EndOfLine);
end;

{$F+}

{ Print a LineRef object }

procedure PrintLine(N: ListNodePtr);
begin
  if RefCount = RefPerLine then
  begin

    WriteLn;
    Write(' ': MaxIdentLen + 1);
    RefCount := 0;
  end;
  Inc(RefCount);
  Write(LineRefPtr(N)^.LineNo: LineNoWidth);
end;

{ Print an IdentRef object }

procedure PrintRef(N: TreeNodePtr);
begin
  with IdentRefPtr(N)^ do if not Lines.Empty then
  begin
    Write(Name^, ' ': MaxIdentLen + 1 - Length(Name^));
    RefCount := 0;
    Lines.ForEach(PrintLine);
    WriteLn;
  end;
end;


{$F-}

{ Print identifier tree }

procedure PrintIdents;
begin
  Idents.ForEach(PrintRef);
  Write(FormFeed, EndOfLine);
end;

begin { CrossRef }
  Idents.Init;
  LineCount := 0;
  if Pos('.', ParamStr(1)) = 0 then
    Assign(Input, ParamStr(1) + '.PAS')
  else
    Assign(Input, ParamStr(1));
  Reset(Input);
  SetTextBuf(Input, InputBuffer);
  SetTextBuf(Output, OutputBuffer);
  InsertKeyWord(1, KeyWordCount);
  ProcessFile;
  PrintIdents;
  Idents.Done;
end.