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 / STRINGS.IZC / STRINGS.INC
Text File  |  2000-06-30  |  9KB  |  288 lines
  1. (* As long as an efficient method of determining string length *)
  2. (* is available (supplied by the PASCALP scanfor intrinsic),   *)
  3. (* strings delimited by an end marker, as here, appear to be   *)
  4. (* more efficient, and more easily manipulated, than strings   *)
  5. (* defined as a record with a length field.  by C.B. Falconer  *)
  6.  
  7. (* Added stoi/itos 85/11/18.  Added stringfill 85/11/25.       *)
  8. (* Renamed stringfill to fillstring (name conflict) 87/02/12   *)
  9.  
  10.   (* 1---------------1 *)
  11.  
  12.   PROCEDURE readstring(VAR f : text; VAR s : string)
  13.   (* At exit, eoln(f) is true, and no readln(f) has been called *);
  14.   (* The input string is terminated by eoln (usually cr).       *)
  15.  
  16.     VAR
  17.       i     : xxstrindex;
  18.  
  19.     BEGIN (* readstring *)
  20.     i := 1;
  21.     WHILE NOT eoln(f) DO
  22.       IF i < xmaxstring THEN BEGIN
  23.         read(f, s[i]); i := succ(i); END
  24.       ELSE get(f);
  25.     s[i] := eos;
  26.     END; (* readstring *)
  27.  
  28.   (* 1---------------1 *)
  29.  
  30.   PROCEDURE readlnstring(VAR f : text; VAR s : string)
  31.   (* differs from readstring in that at exit readln has been called *);
  32.  
  33.     BEGIN (* readlnstring *)
  34.     readstring(f, s); readln(f);
  35.     END; (* readlnstring *)
  36.  
  37.   (* 1---------------1 *)
  38.  
  39.   FUNCTION length(VAR s : string) : xstrindex;
  40.   (* better implemented as a macro. *)
  41.  
  42.     BEGIN (* length *)
  43.     length := pred(scanfor(eos, s, xmaxstring));
  44.     (* rangerror for invalid string, with no eos mark *)
  45.     END; (* length *)
  46.  
  47.   (* 1---------------1 *)
  48.  
  49.   PROCEDURE writestring(VAR f : text; VAR s : string);
  50.   (* better implemented as a macro. Uses the (nonstandard) *)
  51.   (* fact that write(f, s : 0) is a null op in PascalP.    *)
  52.   (* On other systems guard with "IF s > 0 THEN ..."       *)
  53.  
  54.     BEGIN (* writestring *)
  55.     write(f, s : length(s));
  56.     END; (* writestring *)
  57.  
  58.   (* 1---------------1 *)
  59.  
  60.   PROCEDURE wrtfldstring(VAR f : text; VAR s : string; field : integer)
  61.   (* Analog to the normal Pascal write(f, x : field). Rt. justifies *);
  62.  
  63.     VAR
  64.       l       : integer;
  65.  
  66.     BEGIN (* wrtfldstring *)
  67.     l := field - length(s);
  68.     IF l > 0 THEN BEGIN
  69.       write(f, ' ' : l); writestring(f, s); END
  70.     ELSE IF l < 0 THEN write(f, s : field)
  71.     ELSE writestring(f, s);
  72.     END; (* wrtfldstring *)
  73.  
  74.   (* 1---------------1 *)
  75.  
  76.   PROCEDURE concat(s1, s2 : string; VAR sdest : string)
  77.   (* Arguments may be the same string, correctly handled *);
  78.  
  79.     VAR
  80.       i, j, k     : integer;
  81.  
  82.     BEGIN (* concat *)
  83.     sdest := s1; k := 1; i := length(s1); j := i + length(s2);
  84.     IF j > maxstring THEN j := maxstring;
  85.     FOR i := succ(i) TO j DO BEGIN
  86.       sdest[i] := s2[k]; k := succ(k); END;
  87.     sdest[succ(j)] := eos;
  88.     END; (* concat *)
  89.  
  90.   (* 1---------------1 *)
  91.  
  92.   PROCEDURE stringdeblank(VAR s : string)
  93.   (* remove trailing blanks, if any *);
  94.  
  95.     VAR
  96.       i    : integer;
  97.  
  98.     BEGIN (* stringdeblank *)
  99.     i := length(s);
  100.     WHILE i > 0 DO
  101.       IF s[i] <> ' ' THEN i := 0 (* force exit *)
  102.       ELSE BEGIN
  103.         s[i] := eos; i := pred(i); END;
  104.     END; (* stringdeblank *)
  105.  
  106.   (* 1---------------1 *)
  107.  
  108.   PROCEDURE stringextend(VAR s : string; ch : char; always : boolean)
  109.   (* always false prevents extension if the terminal *)
  110.   (* char is ch, or if the string is null (length=0) *);
  111.  
  112.     VAR
  113.       l    : integer;
  114.  
  115.     BEGIN (* stringextend *)
  116.     l := length(s);
  117.     IF l = 0 THEN BEGIN
  118.       IF always THEN BEGIN
  119.         s[1] := ch; s[2] := eos; END;
  120.       END
  121.     ELSE IF l < maxstring THEN
  122.       IF (s[l] <> ch) OR always THEN BEGIN
  123.         s[succ(l)] := ch; s[l + 2] := eos; END;
  124.     END; (* stringextend *)
  125.  
  126.   (* 1---------------1 *)
  127.  
  128.   PROCEDURE substring(si : string; index : strindex; len : integer;
  129.                       VAR sdest : string)
  130.   (* if index outside of si, then return the null string *)
  131.   (* if index + len > length of si, then truncate len    *);
  132.  
  133.     VAR
  134.       i, j  : integer;
  135.  
  136.     BEGIN (* substring *)
  137.     IF (index > length(si)) OR           (* check anomalies *)
  138.        (len <= 0) OR (index <= 0) THEN sdest[1] := eos
  139.     ELSE BEGIN
  140.       j := index; i := 0;
  141.       REPEAT
  142.         i := succ(i); sdest[i] := si[j]; j := succ(j);
  143.       UNTIL (sdest[i] = eos) OR (i >= len) OR (j > maxstring);
  144.       IF i <= maxstring THEN sdest[succ(i)] := eos; END;
  145.     END; (* substring *)
  146.  
  147.   (* 1---------------1 *)
  148.  
  149.   PROCEDURE stringclean(VAR s : string)
  150.   (* This standardizes the portion beyond the eos marker. *);
  151.   (* Thus straight lexical comparisons can be made.       *)
  152.   (* Because strings are meaningless beyond their length, *)
  153.   (* this does not affect any other string operations.    *)
  154.   (* Comparisons depend on the fact that eos is zero, so  *)
  155.   (* that a string vs string+suffix compares correctly.   *)
  156.   (* This should be called after any string has been mod- *)
  157.   (* ified, and before any comparison is made.  It need   *)
  158.   (* not be called again unless the string is modified.   *)
  159.  
  160.     VAR
  161.       i    : xxstrindex;
  162.  
  163.     BEGIN (* stringclean *)
  164.     FOR i := succ(length(s)) TO xmaxstring DO s[i] := eos;
  165.     END; (* stringclean *)
  166.  
  167.   (* 1---------------1 *)
  168.  
  169.   PROCEDURE fillstring(VAR s : string; fillchar : char)
  170.   (* This fills the string out to maximum string length with  *)
  171.   (* "fillchar".  Can be used to create fixed rcd. lgh files. *);
  172.  
  173.     VAR
  174.       i    : xxstrindex;
  175.  
  176.     BEGIN (* fillstring *)
  177.     FOR i := succ(length(s)) TO maxstring DO s[i] := fillchar;
  178.     s[xmaxstring] := eos;
  179.     END; (* fillstring *)
  180.  
  181.   (* 1---------------1 *)
  182.  
  183.   FUNCTION stringfind(VAR s, searchee : string; start : strindex)
  184.                        : xstrindex
  185.   (* returns the index in searchee (from start up) where    *)
  186.   (* the substring s may be found.  Returns 0 if not found. *);
  187.  
  188.     LABEL 10;
  189.  
  190.     CONST
  191.       debug      = false;
  192.  
  193.     VAR
  194.       i, j, k    : integer;
  195.  
  196.     BEGIN (* stringfind *)
  197.     stringfind := 0;                            (* default not found *)
  198.     IF (length(searchee) >= start) THEN
  199.       IF length(s) = 0 THEN stringfind := start (* null string found *)
  200.       ELSE BEGIN                            (* both strings non-null *)
  201.         j := start;
  202. 10:     i := scanfor(s[1], searchee[j], succ(length(searchee)) - j)
  203.              + pred(j);            (* returns index from start point *)
  204.         IF debug THEN writeln('i=', i : 1, ', j=', j : 1);
  205.         IF i >= j THEN BEGIN           (* found 1st char, check rest *)
  206.           IF (pred(i) + length(s)) <= length(searchee) THEN BEGIN
  207.                                  (* room for the substring, continue *)
  208.             FOR k := 2 TO length(s) DO        (* 1st already matched *)
  209.               IF s[k] <> searchee[i + pred(k)] THEN BEGIN
  210.                 j := succ(i); GOTO 10; END;   (* no match, try again *)
  211.             stringfind := i; END;                     (* matched all *)
  212.           END;
  213.         END
  214.  (* ELSE searching a null string, return 0 *);
  215.     END; (* stringfind *)
  216.  
  217.   (* 1---------------1 *)
  218.  
  219.   PROCEDURE stringupshift(VAR s : string);
  220.  
  221.     CONST
  222.       upconvert = 32;  (* ord('a') - ord('A') *)
  223.  
  224.     VAR
  225.       i         : xstrindex;
  226.  
  227.     BEGIN (* stringupshift *)
  228.     FOR i := 1 TO length(s) DO
  229.       IF s[i] IN ['a'..'z'] THEN
  230.         s[i] := chr(ord(s[i]) - upconvert);
  231.     END; (* stringupshift *)
  232.  
  233.   (* 1---------------1 *)
  234.  
  235.   FUNCTION stoi(VAR s : string; start : strindex;
  236.                 VAR value : integer) : xstrindex
  237.   (* returns 0 for no valid number, else index past number *);
  238.   (* cannot handle -maxint - 1. Allows "--123" = 123, etc. *)
  239.  
  240.     VAR
  241.       i   : integer;
  242.  
  243.     BEGIN (* stoi *)
  244.     value := 0; i := start;
  245.     WHILE s[i] = ' ' DO i := succ(i);
  246.     IF s[i] = '-' THEN BEGIN
  247.       stoi := stoi(s, succ(i), value); value := - value; END
  248.     ELSE IF s[i] IN ['0'..'9'] THEN BEGIN
  249.       REPEAT                (* may cause integer overflow *)
  250.         value := 10*value + ord(s[i]) - ord('0'); i := succ(i);
  251.       UNTIL NOT (s[i] IN ['0'..'9']);
  252.       stoi := i; END
  253.     ELSE stoi := 0;    (* failure *)
  254.     END; (* stoi *)
  255.  
  256.   (* 1---------------1 *)
  257.  
  258.   PROCEDURE itos(i : integer; VAR s : string)
  259.   (* Creates a string with the left justified representation of i *);
  260.   (* fails for -maxint -1 *)
  261.  
  262.     VAR
  263.       x     : xstrindex;
  264.  
  265.     (* 2---------------2 *)
  266.  
  267.     PROCEDURE convert(i : integer); (* and reverse digits *)
  268.  
  269.       VAR
  270.         ch   : char;
  271.  
  272.       BEGIN (* convert *)
  273.       ch := chr(i MOD 10 + ord('0'));
  274.       IF i > 9 THEN convert(i DIV 10);
  275.       s[x] := ch; x := succ(x);
  276.       END; (* convert *)
  277.  
  278.     (* 2---------------2 *)
  279.  
  280.     BEGIN (* itos *)
  281.     IF i < 0 THEN BEGIN
  282.       s[1] := '-'; x := 2; i := abs(i); END
  283.     ELSE x := 1;
  284.     convert(i); s[x] := eos;
  285.     END; (* itos *)
  286.  
  287.   (* 1---------------1 *)
  288. gⁿ