_ALGORITHM ALLEY_
by Tom Swan


Listing One

(* ----------------------------------------------------------- *(
** search.pas -- Search engine for IDENT program               **
** Trie search algorithm                                       **
** Copyright (c) 1994 by Tom Swan. All rights reserved.        **
)* ----------------------------------------------------------- *)

unit Search;
INTERFACE
uses Common;

{ Return true if Ident is a Turbo Pascal reserved word }
function IsReserved(Ident: IdentStr): Boolean;
IMPLEMENTATION
type
  ResWord = String[14];
  PResWordRec = ^ResWordRec;
  ResWordRec = record
    Word: ResWord;      { Reserved word string }
    Next: PResWordRec;  { List link field }
  end;
var
  Index: array['a' .. 'z'] of PResWordRec;
{ Add word W to list at P }
procedure AddList(var P: PResWordRec; var W: ResWord);
begin
  if (P <> nil) then
    AddList(P^.Next, W)
  else begin
    P := new(PResWordRec);
    if (P = nil) then
    begin
      Writeln('Out of memory');
      Halt;
    end;
    P^.Word := W;
    P^.Next := nil
  end
end;
{ Add word W to global Index }
procedure AddWord(W: ResWord);
begin
  if Length(W) = 0 then exit;
  AddList(Index[W[1]], W)
end;
{ Initialize search engine variables }
procedure Initialize;
var
  C: Char;  { Index[] array index }
begin
  for C := 'a' to 'z' do
    Index[C] := nil;
  AddWord('and');
  AddWord('array');
  AddWord('asm');
  AddWord('begin');
  AddWord('case');
  AddWord('const');
  AddWord('constructor');
  AddWord('destructor');
  AddWord('div');
  AddWord('do');
  AddWord('downto');
  AddWord('else');
  AddWord('end');
  AddWord('export');
  AddWord('exports');
  AddWord('far');
  AddWord('file');
  AddWord('for');
  AddWord('function');
  AddWord('goto');
  AddWord('if');
  AddWord('implementation');
  AddWord('in');
  AddWord('inherited');
  AddWord('inline');
  AddWord('interface');
  AddWord('label');
  AddWord('library');
  AddWord('mod');
  AddWord('near');
  AddWord('nil');
  AddWord('not');
  AddWord('object');
  AddWord('of');
  AddWord('or');
  AddWord('packed');
  AddWord('private');
  AddWord('procedure');
  AddWord('program');
  AddWord('public');
  AddWord('record');
  AddWord('repeat');
  AddWord('set');
  AddWord('shl');
  AddWord('shr');
  AddWord('string');
  AddWord('then');
  AddWord('to');
  AddWord('type');
  AddWord('unit');
  AddWord('until');
  AddWord('uses');
  AddWord('var');
  AddWord('virtual');
  AddWord('while');
  AddWord('with');
  AddWord('xor');
end;
{ Trie search algorithm }
function IsReserved(Ident: IdentStr): Boolean;
var
  P: PResWordRec;
begin
  IsReserved := false;
  if Length(Ident) = 0 then exit;
  DownCase(Ident);
  P := Index[Ident[1]];
  while(P <> nil) do
  begin
    if P^.Word = Ident then
    begin
      IsReserved := true;
      exit
    end;
    P := P^.Next
  end
end;
begin
  Initialize;
end.



Listing Two

(* ----------------------------------------------------------- *(
** common.pas -- Various constants, types, and subroutines     **
** Copyright (c) 1994 by Tom Swan. All rights reserved.        **
)* ----------------------------------------------------------- *)
unit Common;
INTERFACE
const
  identStrLen = 64;
  digitSet = ['0' .. '9'];
  upperSet = ['A' .. 'Z'];
  lowerSet = ['a' .. 'z'];
  alphaSet = upperSet + lowerSet;
  identSet = alphaSet + digitSet + ['_'];
type
  IdentStr = String[identStrLen];
{ Return lowercase equivalent of Ch }
function DnCase(Ch: Char): Char;
{ Convert all letters in identifier to lowercase }
procedure DownCase(var Ident: IdentStr);
IMPLEMENTATION
{ Return lowercase equivalent of Ch }
function DnCase(Ch: Char): Char;
begin
  if Ch in upperSet
    then Ch := Chr(Ord(Ch) + 32);
  DnCase := Ch
end;
{ Convert all letters in identifier to lowercase }
procedure DownCase(var Ident: IdentStr);
var
  I: Integer;
begin
  if Length(Ident) > 0 then
    for I := 1 to Length(Ident) do
      Ident[I] := DnCase(Ident[I])
end;
begin
end.


Listing Three

(* ------------------------------------------------------------*(
** ident.pas -- Convert key word identifiers in .PAS files.    **
** Converts key words in Pascal listings to lowercase, and     **
** marks them for bold facing. Words are marked using the      **
** symbols <* and *>. For example, <*begin*> is interpreted as **
** a bold faced "begin" key word. A word-processor macro could **
** search for all <* and *> symbols in the resulting file and  **
** replace these with bold face on and off commands.           **
** Copyright (c) 1994 by Tom Swan. All rights reserved.        **
)* ------------------------------------------------------------*)

{$X+}  { Enable "extended" syntax }
program Ident;
uses Dos, Common, Search;
const
  bakExt  = '.BAK';   { Backup file extension }
  tempExt = '.$$$';   { Temporary file extension }
type
  PString = ^String;
  PListRec = ^TListRec;
  TListRec = record
    Path: PString;
    Next: PListRec
  end;
  TState = (
    Reading, Chkcomment, Comment1, Comment2, Stopcomment,
    Stringing, Converting
  );
var
  FileSpec: ComStr;         { Files entered on command line }
  Root: PListRec;           { File name list root pointer }
  DelimitWords: Boolean;    { True to add <* and *> to reserved words }
  CapIdentifiers: Boolean;  { True to capitalize non-keywords }
{ Return copy of a string }
function NewStr(S: String): PString;
var
  P: PString;
begin
  GetMem(P, Length(S) + 1);
  if (P <> nil) then
    PString(P)^ := S;
  NewStr := P
end;
{ Return true if InF is successfully converted to OutF }
function ConvertIdents(var InF, OutF: Text): Boolean;
var
  Ch, PushedCh: Char;
  State: TState;
  Identifier : IdentStr;
  function GetCh(var C: Char): Char;
  begin
    if PushedCh <> #0 then
    begin
      C := PushedCh;
      PushedCh := #0
    end else
      Read(InF, C);
    if (C = #13) or (C = #10) then
    begin
      if (C = #13) then
        Writeln(OutF);  { Start new line }
      C := #0           { Ignore new line characters }
    end;
    GetCh := C
  end;
  procedure UngetCh(Ch: Char);
  begin
    PushedCh := Ch
  end;
  procedure PutCh(Ch: Char);
  begin
    if Ch <> #0 then
      Write(OutF, Ch)
  end;
begin
  PushedCh := #0;     { No pushed character }
  State := Reading;
  while not eof(InF) do
  begin
    GetCh(Ch);
    case State of
      Reading:
      begin
        case Ch of
          '('  : State := Chkcomment;
          '{'  : State := Comment1;
          '''' : State := Stringing;
        end;
        if Ch in alphaSet then
        begin
          UngetCh(Ch);
          State := Converting
        end else
          PutCh(Ch)
      end;
      Chkcomment:
        if Ch = '*' then
        begin
          PutCh(Ch);
          State := Comment2
        end else begin
          UngetCh(Ch);
          State := Reading
        end;
      Comment1:
      begin
        PutCh(Ch);
        if Ch = '}' then
          State := Reading
      end;
      Comment2:
      begin
        PutCh(Ch);
        if Ch = '*' then
          State := Stopcomment
      end;
      Stopcomment:
      begin
        PutCh(Ch);
        if Ch = ')' then
          State := Reading
        else
          State := Comment2;
      end;
      Stringing:
      begin
        PutCh(Ch);
        if Ch = '''' then
          State := Reading;
      end;
      Converting:
      begin
        Identifier := '';
        while Ch in identSet do
        begin
          Identifier := Identifier + Ch;
          Read(InF, Ch)  { Note: Don't call GetCh here! }
        end;
        if IsReserved(Identifier) then
        begin
          DownCase(Identifier);
          if DelimitWords then
            Identifier := '<*' + Identifier + '*>'
        end else
        if CapIdentifiers and (Length(Identifier) > 0) then
          Identifier[1] := UpCase(Identifier[1]);
        Write(OutF, Identifier);
        UngetCh(Ch);
        State := Reading
      end
    end
  end;
  if PushedCh <> #0 then  { Write possible pushed last char that }
    PutCh(Ch);            {  sets eof() to true. }
  ConvertIdents := true
end;
{ Convert one file specified in Path string }
procedure ConvertOneFile(Path: PathStr);
var
  Result: Integer;
  BakF, InF, OutF: Text;
  TempName, BakName: PathStr;
  Name: NameStr;
  Dir: DirStr;
  Ext: ExtStr;
begin
  Write(Path);
  Assign(InF, Path);
  {$i-} Reset(InF); {$i+}
  if IoResult <> 0 then
    Writeln(' **Error opening file')
  else begin
    FSplit(Path, Dir, Name, Ext);
    TempName := Dir + Name + tempExt;
    BakName := Dir + Name + bakExt;
    Assign(OutF, TempName);
    {$i-} Rewrite(OutF); {$i+}
    if IoResult <> 0 then
      Writeln(' **Error creating output file')
    else begin
      if ConvertIdents(InF, OutF) then
      begin
        Close(InF);
        Close(OutF);
        Assign(BakF, BakName);
        {$i-}
        Erase(BakF);
        Result := IoResult;      { Throw out IoResult }
        Rename(InF, BakName);
        Rename(OutF, Path);
        {$i+}
        if IoResult <> 0 then
          Writeln(' **Error renaming files')
        else
          Writeln(' done')
      end else
        Writeln(' **Error processing files')
    end
  end
end;
{ Convert files on global list at Root pointer }
procedure ConvertFiles(List: PListRec);
begin
  if List = nil then
    Writeln('No files specified')
  else
    while List <> nil do
    begin
      ConvertOneFile(List^.Path^);
      List := List^.Next
    end
end;

{ Add file path to list }
procedure ListFile(var List: PListRec; Path: PathStr);
var
  P: PListRec;
begin
  New(P);
  P^.Next := List;
  P^.Path := NewStr(Path);
  if P^.Path = nil then
    Dispose(P)
  else
    List := P
end;
{ Create list of file names from FileSpec string }
procedure ListFiles(var List: PListRec);
var
  Sr: SearchRec;        { Directory search record }
  L: Integer;           { Length of Dir string }
  OldDir: DirStr;       { Old directory upon entry to procedure }
  Path: PathStr;        { Expanded file specification with path info }
  Dir: DirStr;          { Directory component of Path }
  Name: NameStr;        { File name component of Path }
  Ext: ExtStr;          { File extension component of Path }
begin
  GetDir(0, OldDir);             { Save current path }
  Path := FExpand(FileSpec);     { Add path info to file spec }
  FSplit(Path, Dir, Name, Ext);  { Separate Path components }
  L := Length(Dir);              { Prepare to change directories }
  if L > 0 then
  begin
    if (Dir[L] = '\') and (L > 1) and (Dir[L - 1] <> ':') then
      Delete(Dir, L, 1); { Ensure that ChDir will work }
    ChDir(Dir)           { Change to location of file(s) }
  end;
  FindFirst(Path, 0, Sr);        { Start file name search }
  while DosError = 0 do          { Continue while files found }
  begin
    Path := FExpand(Sr.Name);    { Expand to full path name }
    ListFile(List, Path);        { Add path to list }
    FindNext(Sr)                 { Search for the next file }
  end;
  ChDir(OldDir)
end;
{ Display instructions }
procedure Instruct;
begin
  Writeln('Use -b option to surround reserved words with');
  Writeln('<* and *> for bold-facing in a word processor.');
  Writeln('Use -c option to capitalize non-keyword identifers.');
  Writeln;
  Writeln('WARNING: After conversion with -b, the listing will');
  Writeln('not compile. Use -b ONLY on a copy of original files.');
  Writeln;
  Writeln('ex. IDENT single.pas');
  Writeln('    IDENT -b one.pas two.pas');
  Writeln('    IDENT wild??.pas -b *.pas')
end;
{ Main program initializations }
procedure Initialize;
begin
  Writeln;
  Writeln('IDENT -- (C) 1994 by Tom Swan');
  Writeln('Converts Pascal reserved words to lowercase.');
  Writeln;
  Root := nil;              { File name list is empty }
  DelimitWords := false;    { Normally do not add <* and *> to words }
  CapIdentifiers := false   { Normally do not capitalize other idents }
end;
{ Main program block }
var
  I: Integer;
begin
  Initialize;
  if ParamCount = 0 then
    Instruct
  else for I := 1 to ParamCount do
  begin
    FileSpec := ParamStr(I);
    if (FileSpec = '-b') or (FileSpec = '-B') then
      DelimitWords := true
    else if (FileSpec = '-c') or (FileSpec = '-C') then
      CapIdentifiers := true
    else begin
      ListFiles(Root);
      ConvertFiles(Root)
    end
  end
end.



Listing Four

Sub MAIN
StartOfDocument
EditFind .Find = "<*", .WholeWord = 0, .MatchCase = 0, .Direction = 1, \
.Format = 0
While EditFindFound()
 EditClear
 EditFind .Find = "*>", .WholeWord = 0, .MatchCase = 0, .Direction = 1, \
.Format = 0
 If Not EditFindFound() Then
  Stop
 End If
 EditClear
 WordLeft 1, 1
 Bold 1
 EditFind .Find = "<*", .WholeWord = 0, .MatchCase = 0, .Direction = 1, \
.Format = 0
Wend
End Sub


Example 1: 

            input
              Arg: String;
            var
              P: Pointer;
            begin
              P <- Index[Arg[1]];
              while(P <> nil) do
              begin
                if P^.Word = Arg then
                  return True;
                P <- P^.Next;
              end;
              return False;
            end;