(* As long as an efficient method of determining string length *)
(* is available (supplied by the PASCALP scanfor intrinsic),   *)
(* strings delimited by an end marker, as here, appear to be   *)
(* more efficient, and more easily manipulated, than strings   *)
(* defined as a record with a length field.  by C.B. Falconer  *)

(* Added stoi/itos 85/11/18.  Added stringfill 85/11/25.       *)
(* Renamed stringfill to fillstring (name conflict) 87/02/12   *)

  (* 1---------------1 *)

  PROCEDURE readstring(VAR f : text; VAR s : string)
  (* At exit, eoln(f) is true, and no readln(f) has been called *);
  (* The input string is terminated by eoln (usually cr).       *)

    VAR
      i     : xxstrindex;

    BEGIN (* readstring *)
    i := 1;
    WHILE NOT eoln(f) DO
      IF i < xmaxstring THEN BEGIN
        read(f, s[i]); i := succ(i); END
      ELSE get(f);
    s[i] := eos;
    END; (* readstring *)

  (* 1---------------1 *)

  PROCEDURE readlnstring(VAR f : text; VAR s : string)
  (* differs from readstring in that at exit readln has been called *);

    BEGIN (* readlnstring *)
    readstring(f, s); readln(f);
    END; (* readlnstring *)

  (* 1---------------1 *)

  FUNCTION length(VAR s : string) : xstrindex;
  (* better implemented as a macro. *)

    BEGIN (* length *)
    length := pred(scanfor(eos, s, xmaxstring));
    (* rangerror for invalid string, with no eos mark *)
    END; (* length *)

  (* 1---------------1 *)

  PROCEDURE writestring(VAR f : text; VAR s : string);
  (* better implemented as a macro. Uses the (nonstandard) *)
  (* fact that write(f, s : 0) is a null op in PascalP.    *)
  (* On other systems guard with "IF s > 0 THEN ..."       *)

    BEGIN (* writestring *)
    write(f, s : length(s));
    END; (* writestring *)

  (* 1---------------1 *)

  PROCEDURE wrtfldstring(VAR f : text; VAR s : string; field : integer)
  (* Analog to the normal Pascal write(f, x : field). Rt. justifies *);

    VAR
      l       : integer;

    BEGIN (* wrtfldstring *)
    l := field - length(s);
    IF l > 0 THEN BEGIN
      write(f, ' ' : l); writestring(f, s); END
    ELSE IF l < 0 THEN write(f, s : field)
    ELSE writestring(f, s);
    END; (* wrtfldstring *)

  (* 1---------------1 *)

  PROCEDURE concat(s1, s2 : string; VAR sdest : string)
  (* Arguments may be the same string, correctly handled *);

    VAR
      i, j, k     : integer;

    BEGIN (* concat *)
    sdest := s1; k := 1; i := length(s1); j := i + length(s2);
    IF j > maxstring THEN j := maxstring;
    FOR i := succ(i) TO j DO BEGIN
      sdest[i] := s2[k]; k := succ(k); END;
    sdest[succ(j)] := eos;
    END; (* concat *)

  (* 1---------------1 *)

  PROCEDURE stringdeblank(VAR s : string)
  (* remove trailing blanks, if any *);

    VAR
      i    : integer;

    BEGIN (* stringdeblank *)
    i := length(s);
    WHILE i > 0 DO
      IF s[i] <> ' ' THEN i := 0 (* force exit *)
      ELSE BEGIN
        s[i] := eos; i := pred(i); END;
    END; (* stringdeblank *)

  (* 1---------------1 *)

  PROCEDURE stringextend(VAR s : string; ch : char; always : boolean)
  (* always false prevents extension if the terminal *)
  (* char is ch, or if the string is null (length=0) *);

    VAR
      l    : integer;

    BEGIN (* stringextend *)
    l := length(s);
    IF l = 0 THEN BEGIN
      IF always THEN BEGIN
        s[1] := ch; s[2] := eos; END;
      END
    ELSE IF l < maxstring THEN
      IF (s[l] <> ch) OR always THEN BEGIN
        s[succ(l)] := ch; s[l + 2] := eos; END;
    END; (* stringextend *)

  (* 1---------------1 *)

  PROCEDURE substring(si : string; index : strindex; len : integer;
                      VAR sdest : string)
  (* if index outside of si, then return the null string *)
  (* if index + len > length of si, then truncate len    *);

    VAR
      i, j  : integer;

    BEGIN (* substring *)
    IF (index > length(si)) OR           (* check anomalies *)
       (len <= 0) OR (index <= 0) THEN sdest[1] := eos
    ELSE BEGIN
      j := index; i := 0;
      REPEAT
        i := succ(i); sdest[i] := si[j]; j := succ(j);
      UNTIL (sdest[i] = eos) OR (i >= len) OR (j > maxstring);
      IF i <= maxstring THEN sdest[succ(i)] := eos; END;
    END; (* substring *)

  (* 1---------------1 *)

  PROCEDURE stringclean(VAR s : string)
  (* This standardizes the portion beyond the eos marker. *);
  (* Thus straight lexical comparisons can be made.       *)
  (* Because strings are meaningless beyond their length, *)
  (* this does not affect any other string operations.    *)
  (* Comparisons depend on the fact that eos is zero, so  *)
  (* that a string vs string+suffix compares correctly.   *)
  (* This should be called after any string has been mod- *)
  (* ified, and before any comparison is made.  It need   *)
  (* not be called again unless the string is modified.   *)

    VAR
      i    : xxstrindex;

    BEGIN (* stringclean *)
    FOR i := succ(length(s)) TO xmaxstring DO s[i] := eos;
    END; (* stringclean *)

  (* 1---------------1 *)

  PROCEDURE fillstring(VAR s : string; fillchar : char)
  (* This fills the string out to maximum string length with  *)
  (* "fillchar".  Can be used to create fixed rcd. lgh files. *);

    VAR
      i    : xxstrindex;

    BEGIN (* fillstring *)
    FOR i := succ(length(s)) TO maxstring DO s[i] := fillchar;
    s[xmaxstring] := eos;
    END; (* fillstring *)

  (* 1---------------1 *)

  FUNCTION stringfind(VAR s, searchee : string; start : strindex)
                       : xstrindex
  (* returns the index in searchee (from start up) where    *)
  (* the substring s may be found.  Returns 0 if not found. *);

    LABEL 10;

    CONST
      debug      = false;

    VAR
      i, j, k    : integer;

    BEGIN (* stringfind *)
    stringfind := 0;                            (* default not found *)
    IF (length(searchee) >= start) THEN
      IF length(s) = 0 THEN stringfind := start (* null string found *)
      ELSE BEGIN                            (* both strings non-null *)
        j := start;
10:     i := scanfor(s[1], searchee[j], succ(length(searchee)) - j)
             + pred(j);            (* returns index from start point *)
        IF debug THEN writeln('i=', i : 1, ', j=', j : 1);
        IF i >= j THEN BEGIN           (* found 1st char, check rest *)
          IF (pred(i) + length(s)) <= length(searchee) THEN BEGIN
                                 (* room for the substring, continue *)
            FOR k := 2 TO length(s) DO        (* 1st already matched *)
              IF s[k] <> searchee[i + pred(k)] THEN BEGIN
                j := succ(i); GOTO 10; END;   (* no match, try again *)
            stringfind := i; END;                     (* matched all *)
          END;
        END
 (* ELSE searching a null string, return 0 *);
    END; (* stringfind *)

  (* 1---------------1 *)

  PROCEDURE stringupshift(VAR s : string);

    CONST
      upconvert = 32;  (* ord('a') - ord('A') *)

    VAR
      i         : xstrindex;

    BEGIN (* stringupshift *)
    FOR i := 1 TO length(s) DO
      IF s[i] IN ['a'..'z'] THEN
        s[i] := chr(ord(s[i]) - upconvert);
    END; (* stringupshift *)

  (* 1---------------1 *)

  FUNCTION stoi(VAR s : string; start : strindex;
                VAR value : integer) : xstrindex
  (* returns 0 for no valid number, else index past number *);
  (* cannot handle -maxint - 1. Allows "--123" = 123, etc. *)

    VAR
      i   : integer;

    BEGIN (* stoi *)
    value := 0; i := start;
    WHILE s[i] = ' ' DO i := succ(i);
    IF s[i] = '-' THEN BEGIN
      stoi := stoi(s, succ(i), value); value := - value; END
    ELSE IF s[i] IN ['0'..'9'] THEN BEGIN
      REPEAT                (* may cause integer overflow *)
        value := 10*value + ord(s[i]) - ord('0'); i := succ(i);
      UNTIL NOT (s[i] IN ['0'..'9']);
      stoi := i; END
    ELSE stoi := 0;    (* failure *)
    END; (* stoi *)

  (* 1---------------1 *)

  PROCEDURE itos(i : integer; VAR s : string)
  (* Creates a string with the left justified representation of i *);
  (* fails for -maxint -1 *)

    VAR
      x     : xstrindex;

    (* 2---------------2 *)

    PROCEDURE convert(i : integer); (* and reverse digits *)

      VAR
        ch   : char;

      BEGIN (* convert *)
      ch := chr(i MOD 10 + ord('0'));
      IF i > 9 THEN convert(i DIV 10);
      s[x] := ch; x := succ(x);
      END; (* convert *)

    (* 2---------------2 *)

    BEGIN (* itos *)
    IF i < 0 THEN BEGIN
      s[1] := '-'; x := 2; i := abs(i); END
    ELSE x := 1;
    convert(i); s[x] := eos;
    END; (* itos *)

  (* 1---------------1 *)