home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 13
/
mediashare_13.zip
/
mediashare_13
/
ZIPPED
/
PROGRAM
/
APR94_1.ZIP
/
ALLEY.ASC
next >
Wrap
Text File
|
1994-02-27
|
14KB
|
532 lines
_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;