home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol019 / scan2ex.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  4.3 KB  |  172 lines
  1. PROGRAM Scan2Evaluation;
  2. (*
  3.  * PROGRAM TITLE:    Scan 2 Evaluation
  4.  * WRITTEN BY:        Raymond E. Penley
  5.  * DATE WRITTEN:    4 January 1980
  6.  *            11 June 1980 slightly modified for
  7.  *            Pascal/Z vers 3.0
  8.  *
  9.  * PURPOSE:
  10.  *    This is an evaluation of a File read routine I call:
  11.  *    "SCAN-2". SCAN-2 provides to the calling
  12.  *    program TWO characters;
  13.  *       A current character (currchar) and
  14.  *       a look-ahead char (nextchar).
  15.  *
  16.  *)
  17.  
  18. CONST
  19.   prompt = '?';
  20.   space = ' ';
  21.   fill = '    ';
  22.   DisplayLines = 12;
  23.   FID_LENGTH = 14;    {---Maximum length for a file name---}
  24.  
  25. TYPE
  26.   charname = (lletter, uletter, digit, blank, quote, atab,
  27.           EndOfLine, FileMark, otherchar );
  28.   charinfo = RECORD
  29.         name : charname;
  30.         valu : char
  31.          END;
  32.   STR0       = STRING 0;
  33.   STR255   = STRING 255;
  34.   STRING80 = STRING 80;
  35.   FID      = STRING FID_LENGTH; {---FILE IDENTIFIER TYPE---}
  36.  
  37. VAR
  38.   xeof,            (* EOF status AFTER a read *)
  39.   xeoln    : boolean;    (* EOLN status AFTER a read *)
  40.   count    : integer;    (* line counter *)
  41.   LooK,            (* Look-ahead character *)
  42.   Ch       : CHAR;    (* temp usage char *)
  43.   currchar,        (* Current operative character *)
  44.   nextchar : CharInfo;    (* Next character to be operated on *)
  45.   FileID   : FID;         (* File IDentifier *)
  46.   tab       : char;    (* ASCII tab character *)
  47.   ft       : Text;    (* File Control Block <FCB> *)
  48.  
  49.  
  50. FUNCTION LENGTH(X: STR255): INTEGER; EXTERNAL;
  51. PROCEDURE SETLENGTH(VAR X: STR0; Y: INTEGER); EXTERNAL;
  52.  
  53. PROCEDURE GETID( Message : STRING80; VAR ID: FID );
  54. CONST    SPACE = ' ';
  55. begin
  56.   SETLENGTH(ID,0);
  57.   writeln;
  58.   write(message);
  59.   READLN(ID);
  60.   WHILE LENGTH(ID)<FID_LENGTH DO APPEND(ID,SPACE);
  61. end;
  62.  
  63. PROCEDURE GetC(    VAR nextchar : charinfo;
  64.         VAR currchar : charinfo );
  65. (* revised 4 Jan 80, rep *)
  66. begin
  67. (*     Terminator status module
  68.     Stores terminator status "AFTER" a read.
  69.     NOTE this play on words - after one char is
  70.     also "PRIOR TO" the next character
  71.                             *)
  72.   xeoln := EOLN(ft);
  73.   xeof  := EOF(ft);
  74.     (* read byte module *)
  75.   If NOT xeof then
  76.     READ(ft, Look);
  77.     (* current operative character module *)
  78.   currchar := nextchar;
  79.     (* Look-ahead character name module *)
  80.   With NextChar do begin
  81.     IF xeof then
  82.       name := FileMark
  83.     Else If xeoln then
  84.        name := EndOfLine
  85.     Else If LooK IN ['a'..'z'] then (* lower case *)
  86.        name := lletter
  87.     Else If LooK IN ['A'..'Z'] then (* upper case *)
  88.        name := uletter
  89.     Else If LooK IN ['0'..'9'] then (* digit *)
  90.        name := digit
  91.     Else If LooK = '''' then
  92.        name := quote
  93.     Else If LooK = TAB then
  94.        name := atab
  95.     Else If LooK = space then
  96.        name := blank
  97.     Else name := otherchar;
  98.     (* store character value module *)
  99.     CASE name of
  100.     EndOfLine,
  101.     FileMark:    Valu := space;
  102.     Else:        Valu := LooK
  103.     end(* case name of *);
  104.     end(* look-ahead name module *)
  105. end(*---of GetC---*);
  106.  
  107. Procedure HEADER;
  108. begin
  109. writeln(' ':15,'STATUS      Cchar   Cchar',' ':11,'Nchar    Nchar');
  110. writeln('    LooK     EOLN  EOF     VAL    Name ',
  111.         ' ':11,' VAL     Name');
  112. end;
  113.  
  114. Procedure DISPLAY;
  115. begin
  116. {-----FIRST LINE---}
  117.   write(count:3, fill);
  118.   If ord(LooK)=26 then
  119.      write('^Z', ' ':5)
  120.   Else
  121.     write(LooK, ' ':6);
  122.   If xeoln then write('T') else write('F'); write('   ');
  123.   If Xeof then write('T') else write('F');
  124.   Writeln(' ':30, nextchar.valu, ' ':6, nextchar.name );
  125. {-----SECOND LINE-----}
  126.   Writeln(' ':26, currchar.valu, ' ':5 , currchar.name );
  127. end;
  128.  
  129. Procedure PAUSE;
  130. VAR
  131.   dummy : char;
  132. begin
  133.   write(prompt);readln(dummy);
  134. end;
  135.  
  136. Procedure Initialize;
  137. begin
  138.   TAB := chr(9);  (* ASCII Tab character *)
  139.     (*** INITIALIZE look-ahead char ***)
  140.   nextchar.name := blank;
  141.   nextchar.valu := space;
  142. end;
  143.  
  144. BEGIN(* SCAN-2 main *)
  145.   GETID('Enter File Name: ', FileID);
  146.   RESET(FileID, ft);
  147.   If EOF(ft) then
  148.     begin
  149.     writeln('File not found');
  150.     end
  151.   ELSE
  152.     begin
  153.       Initialize;
  154.       writeln;writeln;
  155.       GetC(nextchar, currchar);(* attempt to read *)
  156.       While (CurrChar.name<>filemark) do
  157.     begin(* processing char *)
  158.      count := 0;
  159.     Header;
  160.       REPEAT
  161.         count := count +1;
  162.         Display;
  163.         GetC(nextchar, currchar);
  164.       UNTIL (count=DisplayLines) or (CurrChar.name=filemark);
  165.     PAUSE;
  166.     writeln;
  167.     end(* of processing *);
  168.       writeln('Normal file termination');
  169.     end(* else *);
  170.     WRITELN('That''S all!');
  171. end(*---of SCAN-2 eval---*).
  172.