home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / PASCAL / STRINGS.LBR / TESTER.PZS / TESTER.PAS
Pascal/Delphi Source File  |  2000-06-30  |  4KB  |  135 lines
  1. PROGRAM tester(input, output);
  2. (* testing string package. *)
  3.  
  4. (*$i'strings.dec' (may need extra operations here on other systems) *)
  5.  
  6.   VAR
  7.     stest,
  8.     ssub        : string;
  9.     s           : ARRAY[1..4] OF string;
  10.     i, j, v     : integer;
  11.     ch          : char;
  12.  
  13. 01000000(*$i'strings.inc' line number control *)
  14.  
  15. 08015000  FUNCTION getreply : char; (* 1 char from console, and flush line *)
  16.  
  17.     BEGIN (* getreply *)
  18.     getreply := input^; readln;    (* coded for ISO std file system *)
  19.     END; (* getreply *)
  20.  
  21.   (* 1---------------1 *)
  22.  
  23. { PROCEDURE prompt; }
  24.   (* uncomment this for systems that do not buffer output, and     *)
  25.   (* that do not have the prompt procedure.  If the system buffers *)
  26.   (* output you must install code to force flushing the buffer to  *)
  27.   (* the console, without any final <cr> or <lf>.                  *)
  28.  
  29. {   BEGIN (* prompt *)  }
  30. {   END; (* prompt *)   }
  31.  
  32.   (* 1---------------1 *)
  33.  
  34.   PROCEDURE showstrings(max : integer);
  35.  
  36.     VAR
  37.       i    : integer;
  38.  
  39.     BEGIN (* showstrings *)
  40.     FOR i := 1 TO max DO BEGIN
  41.       write(i : 1, '(', length(s[i]) : 2, ') "');
  42.       writestring(output, s[i]);
  43.       writeln('"'); END;
  44.     END; (* showstrings *)
  45.  
  46.   (* 1---------------1 *)
  47.  
  48.   PROCEDURE showrelation(i, j : integer);
  49.  
  50.     BEGIN (* showrelation *)
  51.     write(i : 1);
  52.     IF s[i] > s[j] THEN write(' > ')
  53.     ELSE IF s[i] < s[j] THEN write(' < ')
  54.     ELSE IF s[i] = s[j] THEN write(' = ')
  55.     ELSE write(' BUG ');
  56.     writeln(j : 1);
  57.     END; (* showrelation *)
  58.  
  59.   (* 1---------------1 *)
  60.  
  61.   BEGIN (* test *)
  62.   REPEAT
  63.     (* Showing a method (non-standard) of initializing strings *)
  64.     (* Unfortunately this requires counting string characters  *)
  65.     (* and use of the s- option to enable the substring op.    *)
  66. (*$s-*)
  67.     s[4, 1 FOR 18] := 'Initialized string'; s[4, 19] := eos;
  68. (*$s+                  1234567890123456789  DON'T FORGET EOS *)
  69.  
  70.     FOR i := 1 TO 3 DO BEGIN
  71.       write('Enter string[', i:1, ']:'); prompt;
  72.       readlnstring(input, s[i]); END;
  73.     writeln; showstrings(4);
  74.  
  75.     writeln; writeln('Trailing blanks removed');
  76.     FOR i := 1 TO 3 DO stringdeblank(s[i]);
  77.     showstrings(3);
  78.  
  79.     writeln; writeln('In a field of 60 chars');
  80.     FOR i := 1 TO 3 DO BEGIN
  81.       write('"'); wrtfldstring(output, s[i], 60); writeln('"'); END;
  82.     write(' ');
  83.     FOR i := 1 TO 60 DO write(i MOD 10 : 1);
  84.     writeln;
  85.  
  86.     write('<ret> to continue'); prompt; readln;
  87.  
  88.     stringextend(s[1], ' ', false); stringextend(s[2], ' ', false);
  89.     concat(s[1], s[2], s[4]); concat(s[4], s[3], s[4]);
  90.     writeln; writeln('Single blanks at end, concatenated');
  91.     showstrings(4);
  92.  
  93.     writeln; writeln('Substring at 4 for 8 chars');
  94.     FOR i := 1 TO 3 DO BEGIN
  95.       substring(s[i], 4, 8, stest);
  96.       write(i : 1, '(', length(stest) : 2, ') "');
  97.       writestring(output, stest); writeln('"'); END;
  98.  
  99.     writeln; writeln('String relationships');
  100.     substring(s[1], 1, 8, s[4]);
  101.     FOR i := 1 TO 4 DO stringclean(s[i]); (* needed for relation *)
  102.     showstrings(4);
  103.     FOR i := 1 TO 3 DO
  104.       FOR j := succ(i) TO 4 DO showrelation(i, j);
  105.  
  106.     write('<ret> to continue'); prompt; readln;
  107.  
  108.     writeln; write('Enter string to search for ='); prompt;
  109.     readlnstring(input, ssub);
  110.     FOR i := 1 TO 3 DO BEGIN
  111.       j := stringfind(ssub, s[i], 1);
  112.       IF j > 0 THEN BEGIN
  113.         wrtfldstring(output, s[i], succ(length(s[i]))); writeln;
  114.         writeln(' ' : j, '^');
  115.         REPEAT
  116.           j := stringfind(ssub, s[i], succ(j));
  117.           IF j > 0 THEN writeln(' ' : j, '^');
  118.         UNTIL j = 0; END
  119.       ELSE writeln('Not found in string', i : 2); END;
  120.  
  121.     writeln; writeln('Upshifting strings');
  122.     FOR i := 1 TO 4 DO stringupshift(s[i]);
  123.     showstrings(4);
  124.  
  125.     writeln; writeln('Numeric values of strings');
  126.     FOR i := 1 TO 4 DO BEGIN
  127.       write(i : 1);
  128.       IF stoi(s[i], 1, v) = 0 THEN write(' has no value')
  129.       ELSE write(' = ', v : 1);
  130.       writeln; END;
  131.  
  132.     write('Again (y/n) ? '); prompt;
  133.   UNTIL NOT (getreply IN ['Y', 'y']);
  134.   END. (* test *)
  135. ɇ