home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol022 / gen5.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  4.6 KB  |  191 lines
  1. PROGRAM GENERATE;
  2. (*
  3.  ********************************************************
  4.  *    An attempt to access files under PASCAL/Z.    *
  5.  *    This program will Generate a File of data,    *
  6.  *    read the data back and display the data.    *
  7.  *                            *
  8.  *     1.0  30 NOV 79, REP                *
  9.  *     1.1   3 DEC 79, REP                *
  10.  *     1.2   4 DEC 79, REP                *
  11.  *         Cleaned up some logic concerning Eof()    *
  12.  *                            *
  13.  *  REP (Ray Penley) wrote this back in version 2.O    *
  14.  *  days but I upgraded it to version 3.O. Its still    *
  15.  *  interesting to those of us who need all the in-    *
  16.  *  structional help we can get.(I only modified it     *
  17.  *  enough to get it running, so it possibly has some   *
  18.  *  outdated syntax.)                    *
  19.  *                            *
  20.  *  Donated to Pascal/Z users group, Aug 1980        *
  21.  ********************************************************
  22.  *)
  23. CONST
  24.   MaxLength = 80;
  25.   EOS = '|';    (* End of String marker *)
  26.  
  27. TYPE
  28.   FILETYPE    = TEXT;
  29.   CPMFILENAME    = PACKED ARRAY[1..14] of CHAR;
  30.   ErrorSym    = (NULL, ERR0, ERR1, ERR2, ERR3);
  31.   MININTEGER    = -240..240;
  32.   strg = record
  33.         length  : INTEGER;
  34.          image  : PACKED ARRAY[1..MaxLength] of CHAR;
  35.        end;
  36. VAR
  37.   F1NAME,            (* File name - File A *)
  38.   F2NAME    : CPMFILENAME;    (* File name - File B *)
  39.   TextFile    : FILETYPE;
  40.   INBUFF     : STRG;
  41.   CH         : CHAR;
  42.   ErrorCodes     : SET of ErrorSym;
  43.   error         : ErrorSym;
  44.   EndofFile,        (* End of File flag *)
  45.   EndofText,        (* End of Text flag *)
  46.   complete : BOOLEAN;    (* Action flag *)
  47.  
  48. (**********************************)
  49.  
  50. FUNCTION G( II : INTEGER  ): CHAR;
  51. (* Function to perform some action upon the CHAR *)
  52. begin
  53.   G := CHR(II +32)
  54. end;
  55.  
  56. Procedure PRINT( VAR X : STRG );
  57. (*    Print the string X until End of String        *)
  58. VAR
  59.   CH : CHAR;
  60.   pos : MININTEGER;
  61. begin
  62.   pos := 0;
  63.   REPEAT
  64.     pos := pos +1;
  65.     CH := X.image[ pos ];
  66.     If CH <> EOS then WRITE(CH)
  67.   UNTIL (CH = EOS) OR (pos = MaxLength);
  68.   If (pos=MaxLength) then error := ERR3;
  69.   Writeln
  70. end;
  71.  
  72. Procedure PUTDATA;
  73. VAR 
  74.   I, J : MININTEGER;
  75. begin
  76.   (***    CREATE FILE    ***)
  77.   REWRITE( F1NAME, TextFile );
  78.   EndofFile := Eof(TextFile);(*** SET Eof FLAG ***)
  79.   J := 0;
  80.   complete := FALSE;
  81.   Writeln('Now writing data to File ', F1NAME);
  82.   REPEAT
  83.     J := J +1;
  84.     WRITE( J:4 );
  85.     FOR I := 1 TO 58 DO
  86.       begin
  87.       CH := G( I );    (*** PROCESS CHAR  ***)
  88.       WRITE( TextFile, CH )
  89.       end;
  90.     WRITE( TextFile, EOS ) (* NOW WRITE OUR End of String *)
  91.   UNTIL (J = 25);
  92.   Writeln;
  93.   complete := TRUE
  94. (***   CLOSE FILE   ***)
  95. end(* PUTDATA *);
  96.  
  97. Procedure GetLine( VAR INBUFF : STRG );
  98. (* GLOBAL
  99.     INBUFF,    EndofFile, MaxLength     *)
  100. VAR
  101.  CH   : CHAR;
  102.  I    : MININTEGER;
  103. begin
  104.   WITH INBUFF DO
  105.     begin
  106.       FOR I:=1 TO MaxLength DO (* Initialize INbuffer *)
  107.      image[ I ]:= EOS;
  108.       length := 0;
  109.       EndofText := FALSE;
  110.     WHILE NOT Eof(TextFile) AND (CH <> EOS) DO
  111.       begin
  112.       If length < MaxLength then
  113.         begin
  114.           READ(TextFile, CH );
  115.           length := length +1;
  116.           image [length] := CH
  117.         end(* If *)
  118.       ELSE    (***   error   ***)
  119.         begin
  120.           error := ERR2;
  121.           EndofText := TRUE
  122.         end(* else *)
  123.       end(* WHILE *);
  124.       EndofFile := Eof(TextFile) (*** !!! SET FLAG !!! ***)
  125.     end(* with *)
  126. end(* GetLine *);
  127.  
  128. Procedure GetData;
  129. VAR
  130.   I : MININTEGER;
  131. begin
  132.   (***   Open File   ***)
  133.   RESET( F1NAME, TextFile );
  134.   I := 0;
  135.   complete := TRUE;
  136.   EndofFile := Eof(TextFile);(*** GET Eof FLAG ***)
  137.   If EndofFile then
  138.     begin
  139.     error := ERR1;(* FILE NOT FOUND *)
  140.     complete := FALSE
  141.     end
  142.   ELSE
  143.     begin   Writeln('Now Reading Data from ', F1NAME );
  144.  
  145.       GetLine(INBUFF); (* Attempt to Read a Line *)
  146.       WHILE NOT EndofFile DO
  147.     begin
  148.     I := I +1;
  149.     WRITE( I:2, ' ');
  150.     PRINT(INBUFF);     (*** PROCESS THE CHAR ***)
  151.     GetLine(INBUFF); (* Attempt to Read a Line *)
  152.     end(* While *)
  153.  
  154.     end(* else *)
  155. (***   Close File   ***)
  156. end(* GET DATA *);
  157.  
  158. Procedure ShowError;
  159. begin
  160.   CASE error of
  161.     ERR0:    Writeln;
  162.     ERR1:    Writeln('FILE NOT FOUND');
  163.     ERR2:    Writeln('Exceeded buffer limits on read');
  164.     ERR3:    Writeln('Exceeded write buffer limits')
  165.     end(* CASE *)
  166. end;
  167.  
  168. Procedure INITIALIZE;
  169. begin
  170.   F1NAME := 'TEST.DAT      ';
  171.   F2NAME := 'TEST.DAT      ';
  172.   ErrorCodes := [ERR0..ERR3];    (* INITIALIZE ERROR CODES *)
  173.   error  := NULL;
  174.   EndofText := FALSE
  175. end;
  176.  
  177. begin(*** GENERATE ***)
  178.   INITIALIZE;
  179.   PUTDATA;
  180.   If NOT(error IN ErrorCodes) then
  181.     begin
  182.       If complete then Writeln(CHR(7), ' ':12, 'Good Write!');
  183.       GetData
  184.     end(* If *);
  185.   Writeln;
  186.   If error IN ErrorCodes then ShowError;
  187.   If complete then Writeln(CHR(7), ' ':12, 'Excellent Read Back!');
  188.   Writeln;Writeln;
  189.   Writeln('That''s All!')
  190. end.
  191.