home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SP12SRC.ZIP / SPELCHEK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-03-28  |  16.3 KB  |  495 lines
  1. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V+,X+}
  2. {$M 6144,0,655360}
  3. Program SpelChek;
  4. { SPELCHEK - A spelling checker.  Copyright (c) 1990,91 by Edwin T. Floyd. }
  5. Uses Dos, Crt, Dict;
  6.  
  7. Const
  8.   Alphabetic = ['a'..'z','A'..'Z']; { Alphabetic characters }
  9.   WordChar = Alphabetic+[''''];   { Default WordSet }
  10.   DefaultOutput = '';             { Default output filename (''=stdout) }
  11.   BufSize = 4096;                 { I/O buffer size }
  12.  
  13. Type
  14.   SetOfChar = Set Of Char;
  15.   FileEntryPtr = ^FileEntry;
  16.   FileEntry = Record
  17.   { Input file name list entry }
  18.     NextFile : FileEntryPtr;
  19.     FileName : PathStr;
  20.   End;
  21.  
  22. Const
  23.   FileList : FileEntryPtr = Nil;       { File name list head }
  24.   LastFile : FileEntryPtr = Nil;       { File name list tail }
  25.   WordCount : LongInt = 0;             { Total number of words examined }
  26.   BadWords : LongInt = 0;              { Total number of words not found }
  27.   ReturnCode : Word = 0;               { Return code for Halt }
  28.   WordSet : SetOfChar = WordChar;      { Words are made of these }
  29.   HighOrder : Boolean = False;         { If true, clear high-order bits }
  30.   FullMark : Boolean = False;          { If true, output full markup info }
  31.   UserDict : Boolean = False;          { If true, use a user dictionary }
  32.   SuppressOutput : Boolean = False;    { If true, do not write output file }
  33.   Aborted : Boolean = False;           { True if operator aborted }
  34.   OutName : PathStr = DefaultOutput;   { Output file name }
  35.   UserDictName : PathStr = '';         { User dictionary name }
  36.   DictPath : PathStr = '';             { Dictionary path }
  37.  
  38. Var
  39.   dab, dcd, deh, din, dor, dst, duz, user : Dictionary;
  40.   TextFile : File;                     { Input file }
  41.   OutFile : Text;                      { Output file }
  42.   TextBuf : Array[1..BufSize] Of Char; { I/O buffer for TextFile }
  43.  
  44. {$S+}
  45. Function ProcessParameter(s : String) : Boolean; Forward;
  46.  
  47. Function ParseParamString(s : String) : Boolean;
  48. { Extract parameters from a string and process them; return True if all OK. }
  49. Var
  50.   i, j : Word;
  51.   ParamsOk : Boolean;
  52. Begin
  53.   ParamsOk := True;
  54.   While (s <> '') And (s[Length(s)] = ' ') Do Dec(s[0]);
  55.   While s <> '' Do Begin
  56.     i := 1;
  57.     While (i <= Length(s)) And (s[i] = ' ') Do Inc(i);
  58.     j := Succ(i);
  59.     While (j <= Length(s)) And (s[j] <> ' ') Do Inc(j);
  60.     If Not ProcessParameter(Copy(s, i, j - i)) Then ParamsOk := False;
  61.     Delete(s, 1, Pred(j));
  62.   End;
  63.   ParseParamString := ParamsOk;
  64. End;
  65.  
  66. Function ProcessParameter(s : String) : Boolean;
  67. { Process command line parameter or file name; return True if OK. }
  68. Var
  69.   ThisFile : FileEntryPtr;
  70.   IncludeFile : Text;
  71.   ParamOk : Boolean;
  72.   i, j : Word;
  73.   IoRes : Integer;
  74.  
  75.   Procedure GetFiles(Var s : String);
  76.   Var
  77.     Path : PathStr;
  78.     Dir : DirStr;
  79.     Name : NameStr;
  80.     Ext : ExtStr;
  81.     Search : SearchRec;
  82.   Begin
  83.     Path := FExpand(s);
  84.     FSplit(Path, Dir, Name, Ext);
  85.     FindFirst(Path, Archive, Search);
  86.     If DosError <> 0 Then Begin
  87.       WriteLn('No files match ', s);
  88.       ParamOk := False;
  89.     End;
  90.     While DosError = 0 Do Begin
  91.       Path := Dir + Search.Name;
  92.       ThisFile := FileList;
  93.       While (ThisFile <> Nil) And (ThisFile^.FileName <> Path) Do
  94.         ThisFile := ThisFile^.NextFile;
  95.       If ThisFile = Nil Then Begin
  96.         New(ThisFile);
  97.         If ThisFile <> Nil Then Begin
  98.           With ThisFile^ Do Begin
  99.             NextFile := Nil;
  100.             FileName := Path;
  101.           End;
  102.           If LastFile = Nil Then FileList := ThisFile
  103.           Else LastFile^.NextFile := ThisFile;
  104.           LastFile := ThisFile;
  105.         End;
  106.       End Else WriteLn('Already in list: ', Path);
  107.       FindNext(Search);
  108.     End;
  109.   End;
  110.  
  111. Begin
  112.   ParamOk := True;
  113.   If (s[1] = '-') Or (s[1] = '/') Then Case UpCase(s[2]) Of
  114.     'H' : If s[3] = '-' Then HighOrder := False Else HighOrder := True;
  115.     'M' : If s[3] = '-' Then FullMark := False Else FullMark := True;
  116.     'O' : Begin { Output file }
  117.       Delete(s, 1, 2);
  118.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  119.       If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
  120.         SuppressOutput := True;
  121.         OutName := '-';
  122.       End Else Begin
  123.         SuppressOutput := False;
  124.         If s = '' Then OutName := s Else OutName := FExpand(s);
  125.       End;
  126.     End;
  127.     'P' : Begin { Dictionary path }
  128.       Delete(s, 1, 2);
  129.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  130.       If (s <> '') Then Begin
  131.         DictPath := FExpand(s);
  132.         If DictPath[Length(DictPath)] <> '\' Then DictPath := DictPath + '\';
  133.       End Else DictPath := s;
  134.     End;
  135.     'U' : Begin { User dictionary }
  136.       Delete(s, 1, 2);
  137.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  138.       If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
  139.         UserDict := False;
  140.         UserDictName := '';
  141.       End Else Begin
  142.         UserDict := True;
  143.         UserDictName := FExpand(s);
  144.       End;
  145.     End;
  146.     'W' : Begin { Word character set }
  147.       Delete(s, 1, 2);
  148.       Case s[1] Of
  149.         '+' : ;
  150.         '-' : WordSet := [];
  151.         Else Begin
  152.           WriteLn('WordSet (-W) option must be followed by + or -.');
  153.           ParamOk := False;
  154.         End;
  155.       End;
  156.       Delete(s, 1, 1);
  157.       For i := 1 To Length(s) Do
  158.         WordSet := WordSet + [s[i]];
  159.     End;
  160.     Else Begin
  161.       WriteLn('Unrecognized option: ', s);
  162.       ParamOk := False;
  163.     End;
  164.   End Else If s[1] = '@' Then Begin
  165.     Delete(s, 1, 1);
  166.     For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  167.     Assign(IncludeFile, s);
  168.     Reset(IncludeFile);
  169.     IoRes := IoResult;
  170.     If IoRes = 0 Then Begin
  171.       WriteLn('Processing include file ', s);
  172.       Repeat
  173.         ReadLn(IncludeFile, s);
  174.         IoRes := IoResult;
  175.         If IoRes = 0 Then If Not ParseParamString(s) Then ParamOk := False;
  176.       Until Eof(IncludeFile) Or (IoRes <> 0);
  177.       If IoRes <> 0 Then Begin
  178.         WriteLn('Error ', IoRes, ' reading include file');
  179.         ParamOk := False;
  180.       End;
  181.       Close(IncludeFile);
  182.       IoRes := IoResult;
  183.     End Else Begin
  184.       WriteLn('Error ', IoRes, ' opening include file ', s);
  185.       ParamOk := False;
  186.     End;
  187.   End Else GetFiles(s);
  188.   ProcessParameter := ParamOk;
  189. End;
  190.  
  191. Procedure ParseParams;
  192. { Interpret environment and command line parameters; display Help info. }
  193. Var
  194.   i, j : Word;
  195.   ParamsOk : Boolean;
  196.   Ch : Char;
  197.   s : String;
  198. Begin
  199.   WriteLn('SPELCHEK v1.2 - A spelling checker.  Copyright (c) 1990,91 by Edwin T. Floyd.');
  200.   ParamsOk := True;
  201.   If Not ParseParamString(GetEnv('SPELCHEK')) Then Begin
  202.     WriteLn('Error found in SET SPELCHEK=.. environment string');
  203.     ParamsOk := False;
  204.   End;
  205.   For i := 1 To ParamCount Do Begin
  206.     FillChar(s[1], 255, ' ');
  207.     s := ParamStr(i);
  208.     If Not ProcessParameter(s) Then ParamsOk := False;
  209.   End;
  210.   If Not ParamsOk Then Begin
  211.     WriteLn('At least one parameter was in error.  Run SPELCHEK with no parameters');
  212.     WriteLn('to see documentation.');
  213.     Halt(1);
  214.   End Else If FileList = Nil Then Begin
  215.     WriteLn;
  216.     WriteLn('  SPELCHEK filenames.. [-H] [-W[+/-]abc..] [@name] [-Oname] [-Ppath]' );
  217.     WriteLn('                       [-Uname]');
  218.     WriteLn;
  219.     WriteLn('All command line parameters are separated by spaces.  Input text filenames');
  220.     WriteLn('and options may be intermixed; options are distinguished by a leading hyphen:');
  221.     WriteLn;
  222.     WriteLn('  -H[-] Clear high-order bits on input file (i.e. WordStar, default off).');
  223.     WriteLn('  -M[-] Output markup information for MARKDOC program');
  224.     WriteLn('  -W-abc.. Replace the word character set with the indicated characters');
  225.     WriteLn('     (default is all alphabetic characters, upper and lower case, apostrophe).');
  226.     WriteLn('  -W+abc.. Add additional characters to the word character set.');
  227.     WriteLn('  -O[name] Name the output file (default is name omitted => stdout).');
  228.     WriteLn('  -O- Suppress output (counts are still displayed on screen).');
  229.     WriteLn('  -Ppath Drive and directory of dictionary files.');
  230.     WriteLn('  -Uname specifies a user dictionary.');
  231.     WriteLn;
  232.     WriteLn('The "@" prefixes the name of an ASCII include file which may contain');
  233.     WriteLn('filenames, options, and nested include files, in any order.');
  234.     Write('Press any key to continue...');
  235.     Ch := ReadKey;
  236.     Write(^M);
  237.     ClrEol;
  238.     WriteLn;
  239.     WriteLn('You may use the DOS "SET" command to specify default parameters.  Examples:');
  240.     WriteLn;
  241.     WriteLn('  SET SPELCHEK=-Ospell.out -W-ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  242.     WriteLn('  SET SPELCHEK=@defaults.spl -O -Pc:\spell');
  243.     WriteLn;
  244.     WriteLn('Command line parameters override "SET" parameters.  SPELCHEK examples:');
  245.     WriteLn;
  246.     WriteLn('  SPELCHEK document.txt -W+- -Obadwords.lst');
  247.     WriteLn('  SPELCHEK @filename.lst -Pc:\spell\dict -Obadwords.txt');
  248.     WriteLn('  SPELCHEK file1.txt -H+ -M+ -Umedterm.dct -O | MARKDOC');
  249.     WriteLn;
  250.     WriteLn('SPELCHEK was written by:');
  251.     WriteLn;
  252.     WriteLn('  Edwin T. Floyd         [76067,747]  (CompuServe)');
  253.     WriteLn('  #9 Adams Park Court    404/576-3305 (work)');
  254.     WriteLn('  Columbus, GA 31909     404/322-0076 (home)');
  255.     Halt(0);
  256.   End Else Begin
  257.     s := '';
  258.     If HighOrder Then ch := '+' Else ch := '-';
  259.     s := s + ' -H' + ch;
  260.     If FullMark Then ch := '+' Else ch := '-';
  261.     s := s + ' -M' + ch;
  262.     WriteLn('Options: ', s, ', -O', OutName);
  263.     If DictPath <> '' Then WriteLn('  -P', DictPath);
  264.     If UserDict Then WriteLn('  -U', UserDictName);
  265.     WriteLn('Press <Esc> to stop.');
  266.   End;
  267. End;
  268.  
  269. {$S-}
  270.  
  271. Function FileExists(FileName : PathStr) : Boolean;
  272. { Return TRUE if FileName can be opened ($F parameter should be off). }
  273. Var
  274.   f : File;
  275. Begin
  276.   Assign(f, FileName);
  277.   Reset(f);
  278.   If IoResult = 0 Then Begin
  279.     FileExists := True;
  280.     Close(f);
  281.   End Else FileExists := False;
  282. End;
  283.  
  284. Procedure LoadDict;
  285. { Load dictionaries }
  286. Var
  287.   d : DirStr;
  288.   n : NameStr;
  289.   e : ExtStr;
  290.   found : Boolean;
  291. Begin
  292.   If Not FileExists(DictPath+'AB.DCT') Then Begin
  293.     found := False;
  294.     If DictPath <> '' Then Begin
  295.       WriteLn('Dictionary not found in directory ', DictPath);
  296.       DictPath := '';
  297.       If FileExists('AB.DCT') Then found := True
  298.       Else WriteLn('Dictionary not found in current directory');
  299.     End;
  300.     If Not found Then Begin
  301.       FSplit(ParamStr(0), d, n, e);
  302.       If d[Length(d)] <> '\' Then d := d + '\';
  303.       DictPath := d;
  304.       If Not FileExists(DictPath+'AB.DCT') Then Begin
  305.         WriteLn('Dictionary not found in program directory');
  306.         WriteLn('Unable to locate master dictionary, terminating');
  307.         Halt(1);
  308.       End;
  309.     End;
  310.   End;
  311.   WriteLn('Loading dictionary');
  312.   dab.RestoreDictionary(DictPath+'AB.DCT');
  313.   dcd.RestoreDictionary(DictPath+'CD.DCT');
  314.   deh.RestoreDictionary(DictPath+'EH.DCT');
  315.   din.RestoreDictionary(DictPath+'IN.DCT');
  316.   dor.RestoreDictionary(DictPath+'OR.DCT');
  317.   dst.RestoreDictionary(DictPath+'ST.DCT');
  318.   duz.RestoreDictionary(DictPath+'UZ.DCT');
  319.   If UserDict Then Begin
  320.     If FileExists(UserDictName) Then Begin
  321.       WriteLn('Loading user dictionary');
  322.       user.RestoreDictionary(UserDictName)
  323.     End Else Begin
  324.       WriteLn('User dictionary not found: ', UserDictName);
  325.       WriteLn('Processing continued without user dictionary');
  326.     End;
  327.   End;
  328. End;
  329.  
  330. Function InDict(Var s : String) : Boolean;
  331. { Test for word in dictionary }
  332. Var
  333.   IsIn : Boolean;
  334. Begin
  335.   Case s[1] Of
  336.     'A'..'B' : IsIn := dab.StringInDictionary(s);
  337.     'C'..'D' : IsIn := dcd.StringInDictionary(s);
  338.     'E'..'H' : IsIn := deh.StringInDictionary(s);
  339.     'I'..'N' : IsIn := din.StringInDictionary(s);
  340.     'O'..'R' : IsIn := dor.StringInDictionary(s);
  341.     'S'..'T' : IsIn := dst.StringInDictionary(s);
  342.     'U'..'Z' : IsIn := duz.StringInDictionary(s);
  343.     Else IsIn := False;
  344.   End;
  345.   If UserDict And Not IsIn Then IsIn := user.StringInDictionary(s);
  346.   InDict := IsIn;
  347. End;
  348.  
  349. Function ParseInputBlock(Block : LongInt; Len : Word) : Word;
  350. { Check words from input block against dictionaries }
  351. Var
  352.   Words : Word;
  353.   s : String;
  354.   i, start : Word;
  355. Begin
  356.   i := 1;
  357.   Words := 0;
  358.   While i <= Len Do Begin
  359.     s := '';
  360.     While (i <= Len) And Not (TextBuf[i] In WordSet) Do Inc(i);
  361.     start := i;
  362.     If i <= Len Then Begin
  363.       Inc(Words);
  364.       While (i <= Len) And (Length(s) < 255)
  365.       And (TextBuf[i] In WordSet) Do Begin
  366.         Inc(s[0]);
  367.         s[Ord(s[0])] := UpCase(TextBuf[i]);
  368.         Inc(i);
  369.       End;
  370.       While (s <> '') And Not (s[1] In Alphabetic) Do Begin
  371.         Delete(s, 1, 1);
  372.         Inc(start);
  373.       End;
  374.       While (s <> '') And Not (s[Length(s)] In Alphabetic) Do
  375.         Dec(s[0]);
  376. (*
  377.       { Check for posessive and for some contractions }
  378.       If s = 'WON''T' Then s := ''
  379.       Else If Length(s) > 3 Then Begin
  380.         If Copy(s, Length(s)-1, 2) = '''S' Then
  381.           Delete(s, Length(s)-1, 2)
  382.         Else If Copy(s, Length(s)-1, 2) = '''M' Then
  383.           Delete(s, Length(s)-1, 2)
  384.         Else If Copy(s, Length(s)-2, 3) = 'N''T' Then
  385.           Delete(s, Length(s)-2, 3)
  386.         Else If Copy(s, Length(s)-2, 3) = '''LL' Then
  387.           Delete(s, Length(s)-2, 3)
  388.         Else If Copy(s, Length(s)-2, 3) = '''RE' Then
  389.           Delete(s, Length(s)-2, 3)
  390.         Else If Copy(s, Length(s)-2, 3) = '''VE' Then
  391.           Delete(s, Length(s)-2, 3);
  392.       End;
  393. *)
  394.       If (Length(s) > 1) And Not InDict(s) Then Begin
  395.         Inc(BadWords);
  396.         If Not SuppressOutput Then Begin
  397.           If FullMark Then Write(OutFile, Block + start, ' ');
  398.           WriteLn(OutFile, s);
  399.         End;
  400.       End;
  401.     End;
  402.   End;
  403.   ParseInputBlock := Words;
  404. End;
  405.  
  406. Procedure ProcessNextFile;
  407. { Open and process the next input file pointed to by FileList. }
  408. Var
  409.   ThisFile : FileEntryPtr;
  410.   FileWords, BlockOfs, OldBad : LongInt;
  411.   i, MaxLen, Len : Word;
  412.   FileResult : Integer;
  413. Begin
  414.   ThisFile := FileList;
  415.   With ThisFile^ Do Begin
  416.     Write(FileName, ': ');
  417.     Assign(TextFile, FileName);
  418.     Reset(TextFile, 1);
  419.     FileResult := IoResult;
  420.     If FileResult = 0 Then Begin
  421.       If FullMark And Not SuppressOutput Then
  422.         WriteLn(OutFile, '0 ', FileName);
  423.       Len := 0;
  424.       FileWords := 0;
  425.       OldBad := BadWords;
  426.       BlockOfs := 0;
  427.       Repeat
  428.         BlockRead(TextFile, TextBuf[Succ(Len)], BufSize-Len, i);
  429.         FileResult := IoResult;
  430.         If FileResult = 0 Then Begin
  431.           MaxLen := Len + i;
  432.           If HighOrder Then For i := Succ(Len) To MaxLen Do
  433.             TextBuf[i] := Chr(Ord(TextBuf[i]) And $7F);
  434.           Len := MaxLen;
  435.           If Not Eof(TextFile) Then Begin
  436.             While (Len > 0) And (TextBuf[Len] In WordSet) Do Dec(Len);
  437.             If (Len = 0) Then Len := MaxLen;
  438.           End;
  439.           FileWords := FileWords + ParseInputBlock(BlockOfs, Len);
  440.           BlockOfs := BlockOfs + Len;
  441.           MaxLen := MaxLen - Len;
  442.           If MaxLen > 0 Then
  443.             Move(TextBuf[Succ(Len)], TextBuf[1], MaxLen);
  444.           Len := MaxLen;
  445.           Write(^M, FileName, ': ', FileWords, ' words, ',
  446.             BadWords-OldBad, ' bad');
  447.           While KeyPressed Do If ReadKey = ^[ Then Aborted := True;
  448.         End;
  449.       Until Eof(TextFile) Or (FileResult <> 0) Or Aborted;
  450.       Close(TextFile);
  451.       WriteLn(^M, FileName, ': ', FileWords, ' words, ',
  452.         BadWords-OldBad, ' bad');
  453.       WordCount := WordCount + FileWords;
  454.     End Else WriteLn('Unable to open input file ', FileName);
  455.     If FileResult <> 0 Then Begin
  456.       WriteLn('Error ', FileResult);
  457.       Inc(ReturnCode);
  458.     End;
  459.     FileList := NextFile;
  460.   End;
  461.   Dispose(ThisFile);
  462. End;
  463.  
  464. {$F+}
  465. Function HandleHeapError(Size : Word) : Integer;
  466. Begin
  467.   If Size > 0 Then Begin
  468.     WriteLn('SPELCHEK ran out of memory.');
  469.     Halt(1);
  470.   End;
  471. End;
  472. {$F-}
  473.  
  474. Begin
  475.   HeapError := @HandleHeapError;
  476.   FileMode := $40;
  477.   ParseParams;
  478.   LoadDict;
  479.   If Not SuppressOutput Then Begin
  480.     Assign(OutFile, OutName);
  481.     Rewrite(OutFile);
  482.   End;
  483.   While (FileList <> Nil) And Not Aborted Do ProcessNextFile;
  484.   If Aborted Then Begin
  485.     WriteLn('File processing aborted by operator');
  486.     If Not SuppressOutput Then WriteLn(OutFile, '***ABORTED***');
  487.     Inc(ReturnCode);
  488.   End;
  489.   If Not SuppressOutput Then Close(OutFile);
  490.   WriteLn('Final Counts: ', WordCount, ' words examined, ',
  491.     BadWords, ' words not found in dictionary');
  492.   WriteLn('Done!');
  493.   Halt(ReturnCode);
  494. End.
  495.