GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/program/m2posx02/pstring.ipp

Modula Implementation | 1993-10-23 | 17.4 KB | 763 lines

IMPLEMENTATION MODULE pSTRING;
(*__NO_CHECKS__*)
(*****************************************************************************)
(* 14-Feb-93, Holger Kleinschmidt                                            *)
(* --------------------------------------------------------------------------*)
(* STATUS: OK                                                                *)
(*****************************************************************************)

VAL_INTRINSIC
CAST_IMPORT

FROM types IMPORT
(* CONST*) NULL;

FROM CTYPE IMPORT
(* PROC *) TOLOWER, TOUPPER, ISSPACE;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)

CONST
#if no_MIN_MAX
  MAXCARD  = CAST(CARDINAL,-1);
#else
  MAXCARD  = MAX(CARDINAL);
#endif
  NOTFOUND = -1;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)

PROCEDURE SLEN ((* EIN/ -- *) REF s : ARRAY OF CHAR ): CARDINAL;
(*T*)
#if ISOM2 || MM2
BEGIN
 RETURN(LENGTH(s));
#else
VAR i : CARDINAL;
BEGIN
 i := 0;
 WHILE (i <= VAL(CARDINAL,HIGH(s))) AND (s[i] <> EOS) DO
   INC(i);
 END;
 RETURN(i);
#endif
END SLEN;

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

PROCEDURE ASSIGN ((* EIN/ -- *) REF src : ARRAY OF CHAR;
                  (* -- /AUS *) VAR dst : ARRAY OF CHAR );
(*T*)
VAR i   : CARDINAL;
    max : CARDINAL;

BEGIN
 IF HIGH(src) > HIGH(dst) THEN
   max := VAL(CARDINAL,HIGH(dst));
 ELSE
   max := VAL(CARDINAL,HIGH(src));
 END;

 i := 0;
 WHILE (i <= max) AND (src[i] <> EOS) DO
   dst[i] := src[i];
   INC(i);
 END;
 IF i <= VAL(CARDINAL,HIGH(dst)) THEN
   dst[i] := EOS;
 END;
END ASSIGN;

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

PROCEDURE CONCAT ((* EIN/ -- *)     s1  : ARRAY OF CHAR;
                  (* EIN/ -- *)     s2  : ARRAY OF CHAR;
                  (* -- /AUS *) VAR dst : ARRAY OF CHAR );
(*T*)
VAR i1, i2 : INTEGER;
    max    : INTEGER;

BEGIN
 IF HIGH(s1) > HIGH(dst) THEN
   max := INT(HIGH(dst));
 ELSE
   max := INT(HIGH(s1));
 END;

 i1 := 0;
 WHILE (i1 <= max) AND (s1[i1] <> EOS) DO
   dst[i1] := s1[i1];
   INC(i1);
 END;

 IF INT(HIGH(s2)) > (INT(HIGH(dst)) - i1) THEN
   max := INT(HIGH(dst)) - i1;
 ELSE
   max := INT(HIGH(s2));
 END;

 i2 := 0;
 WHILE (i2 <= max) AND (s2[i2] <> EOS) DO
   dst[i1] := s2[i2];
   INC(i1);
   INC(i2);
 END;

 IF i1 <= INT(HIGH(dst)) THEN
   dst[i1] := EOS;
 END;
END CONCAT;

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

PROCEDURE iappend (    len : CARDINAL;
                   VAR app : ARRAY OF CHAR;
                   VAR dst : ARRAY OF CHAR );
VAR dIdx : CARDINAL;
    aIdx : CARDINAL;
    max  : CARDINAL;

BEGIN
 dIdx := SLEN(dst);
 max  := (VAL(CARDINAL,HIGH(dst)) + 1) - dIdx;
 IF max > len THEN
   max := len;
 END;
 IF max > VAL(CARDINAL,HIGH(app)) THEN
   max := VAL(CARDINAL,HIGH(app)) + 1;
 END;

 aIdx := 0;
 WHILE (aIdx < max) AND (app[aIdx] <> EOS) DO
   dst[dIdx] := app[aIdx];
   INC(aIdx);
   INC(dIdx);
 END;

 IF dIdx <= VAL(CARDINAL,HIGH(dst)) THEN
   dst[dIdx] := EOS;
 END;
END iappend;

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

PROCEDURE APPEND ((* EIN/ -- *)     app : ARRAY OF CHAR;
                  (* EIN/AUS *) VAR dst : ARRAY OF CHAR );
(*T*)
BEGIN
 iappend(MAXCARD, app, dst);
END APPEND;

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

PROCEDURE APPENDN ((* EIN/ -- *)     len : CARDINAL;
                   (* EIN/ -- *)     app : ARRAY OF CHAR;
                   (* EIN/AUS *) VAR dst : ARRAY OF CHAR );
(*T*)
BEGIN
 iappend(len, app, dst);
END APPENDN;

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

PROCEDURE APPENDCHR ((* EIN/ -- *)     c   : CHAR;
                     (* EIN/AUS *) VAR dst : ARRAY OF CHAR );
(*T*)
VAR dIdx : CARDINAL;

BEGIN
 dIdx := SLEN(dst);
 IF dIdx <= VAL(CARDINAL,HIGH(dst)) THEN
   dst[dIdx] := c;
   IF dIdx < VAL(CARDINAL,HIGH(dst)) THEN
     dst[dIdx+1] := EOS;
   END;
 END;
END APPENDCHR;

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

PROCEDURE COPY ((* EIN/ -- *)     from : CARDINAL;
                (* EIN/ -- *)     len  : CARDINAL;
                (* EIN/ -- *)     src  : ARRAY OF CHAR;
                (* -- /AUS *) VAR dst  : ARRAY OF CHAR );
(*T*)
VAR  srcLen : CARDINAL;
     cnt    : CARDINAL;
     dIdx   : INTEGER;
     max    : INTEGER;

BEGIN
 srcLen := SLEN(src);

 IF (len > MAXCARD - from) OR (from + len > srcLen) THEN
   IF from < srcLen THEN
     cnt := srcLen - from;
   ELSE
     cnt := 0;
   END;
 ELSE
   cnt := len;
 END;

 IF cnt > VAL(CARDINAL,HIGH(dst)) THEN
   max := INT(HIGH(dst));
 ELSE
   max := CAST(INTEGER,cnt) - 1;
 END;

 dIdx := 0;
 WHILE dIdx <= max DO
   dst[dIdx] := src[from];
   INC(dIdx);
   INC(from);
 END;

 IF dIdx <= INT(HIGH(dst)) THEN
   dst[dIdx] := EOS;
 END;
END COPY;

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

PROCEDURE INSERT ((* EIN/ -- *)     at  : CARDINAL;
                  (* EIN/ -- *)     ins : ARRAY OF CHAR;
                  (* EIN/AUS *) VAR s   : ARRAY OF CHAR );
(*T*)
VAR spc  : INTEGER;
    sLen : INTEGER;
    iLen : INTEGER;
    i    : INTEGER;

BEGIN
 sLen := CAST(INTEGER,SLEN(s));
 iLen := CAST(INTEGER,SLEN(ins));

 IF at > CAST(CARDINAL,sLen) THEN
   at := sLen;
 END;

 spc := (INT(HIGH(s)) + 1 - sLen) - iLen;

 IF spc < 0 THEN
   INC(sLen, spc);
   IF INT(HIGH(s)) + 1 - CAST(INTEGER,at) < iLen THEN
     iLen := INT(HIGH(s)) + 1 - CAST(INTEGER,at);
   END;
 ELSIF spc > 0 THEN
   s[sLen+iLen] := EOS;
 END;

 FOR i := sLen - 1 TO CAST(INTEGER,at) BY -1 DO
   s[i+iLen] := s[i];
 END;

 FOR i := 0 TO iLen - 1 DO
   s[CAST(INTEGER,at)+i] := ins[i];
 END;
END INSERT;

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

PROCEDURE DELETE ((* EIN/ -- *)     from : CARDINAL;
                  (* EIN/ -- *)     len  : CARDINAL;
                  (* EIN/AUS *) VAR s    : ARRAY OF CHAR );
(*T*)
VAR strLen : CARDINAL;

BEGIN
 strLen := SLEN(s);

 IF from < MAXCARD - len THEN
   INC(len, from);
 ELSE
   len := MAXCARD;
 END;

 WHILE len < strLen  DO
   s[from] := s[len];
   INC(from);
   INC(len);
 END;

 IF from <= VAL(CARDINAL,HIGH(s)) THEN
   s[from] := EOS;
 END;
END DELETE;

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

PROCEDURE LOWER ((* EIN/AUS *) VAR s : ARRAY OF CHAR );
(*T*)
VAR i : CARDINAL;

BEGIN
 i := 0;
 WHILE (i <= VAL(CARDINAL,HIGH(s))) AND (s[i] <> EOS) DO
   s[i] := TOLOWER(s[i]);
   INC(i);
 END;
END LOWER;

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

PROCEDURE UPPER ((* EIN/AUS *) VAR s : ARRAY OF CHAR );
(*T*)
VAR i : CARDINAL;

BEGIN
 i := 0;
 WHILE (i <= VAL(CARDINAL,HIGH(s))) AND (s[i] <> EOS) DO
   s[i] := TOUPPER(s[i]);
   INC(i);
 END;
END UPPER;

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

PROCEDURE compare (    len : CARDINAL;
#if has_REF
                   REF s1  : ARRAY OF CHAR;
                   REF s2  : ARRAY OF CHAR ): INTEGER;
#else
                   VAR s1  : ARRAY OF CHAR;
                   VAR s2  : ARRAY OF CHAR ): INTEGER;
#endif
CONST less    = -1;
      equal   =  0;
      greater =  1;

VAR i   : CARDINAL;
    max : CARDINAL;
    ch  : CHAR;

BEGIN
 IF len = 0 THEN
   RETURN(equal);
 ELSE
   DEC(len);
 END;
 IF HIGH(s1) > HIGH(s2) THEN
   max := VAL(CARDINAL,HIGH(s2));
 ELSE
   max := VAL(CARDINAL,HIGH(s1));
 END;
 IF max > len THEN
   max := len;
 END;

 i := 0;
 REPEAT
   ch := s1[i];
   IF ch <> s2[i]  THEN
     IF ch < s2[i]  THEN
       RETURN(less);
     ELSE
       RETURN(greater);
     END;
   ELSIF ch = EOS THEN
     RETURN(equal);
   END;

   INC(i);
 UNTIL i > max;

(* Bis hierher waren die beiden Strings gleich *)

 IF max = len THEN
   RETURN(equal);
 ELSIF HIGH(s1) < HIGH(s2) THEN
   (* i <= HIGH(s2) *)
   IF s2[i] = EOS THEN
     RETURN(equal);
   ELSE
     RETURN(less);
   END;
 ELSIF HIGH(s1) > HIGH(s2) THEN
   (* i <= HIGH(s1) *)
   IF s1[i] = EOS  THEN
     RETURN(equal);
   ELSE
     RETURN(greater);
   END;
 ELSE (* HIGH(s1) = HIGH(s2) *)
   RETURN(equal);
 END;
END compare;

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

PROCEDURE EQUAL ((* EIN/ -- *) REF s1 : ARRAY OF CHAR;
                 (* EIN/ -- *) REF s2 : ARRAY OF CHAR ): BOOLEAN;
(*T*)
BEGIN
 RETURN(compare(MAXCARD, s1, s2) = 0);
END EQUAL;

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

PROCEDURE EQUALN ((* EIN/ -- *)     len : CARDINAL;
                  (* EIN/ -- *) REF s1  : ARRAY OF CHAR;
                  (* EIN/ -- *) REF s2  : ARRAY OF CHAR ): BOOLEAN;
(*T*)
BEGIN
 RETURN(compare(len, s1, s2) = 0);
END EQUALN;

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

PROCEDURE COMPARE ((* EIN/ -- *) REF s1 : ARRAY OF CHAR;
                   (* EIN/ -- *) REF s2 : ARRAY OF CHAR ): INTEGER;
(*T*)
BEGIN
 RETURN(compare(MAXCARD, s1, s2));
END COMPARE;

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

PROCEDURE COMPAREN ((* EIN/ -- *)     len : CARDINAL;
                    (* EIN/ -- *) REF s1  : ARRAY OF CHAR;
                    (* EIN/ -- *) REF s2  : ARRAY OF CHAR ): INTEGER;
(*T*)
BEGIN
 RETURN(compare(len, s1, s2));
END COMPAREN;

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

PROCEDURE LPOS ((* EIN/ -- *)     from : CARDINAL;
                (* EIN/ -- *) REF pat  : ARRAY OF CHAR;
                (* EIN/ -- *) REF s    : ARRAY OF CHAR ): INTEGER;
(*T*)
VAR sLen  : CARDINAL;
    pLen  : CARDINAL;
    tries : CARDINAL;
    pIdx  : CARDINAL;

BEGIN
 sLen := SLEN(s);;
 pLen := SLEN(pat);

 IF (pLen = 0) OR (pLen > sLen) OR (from > sLen - pLen) THEN
   RETURN(NOTFOUND);
 ELSE
   tries := sLen - pLen - from;
 END;

 LOOP
   pIdx := 0;
   WHILE (pIdx < pLen) AND (s[from] = pat[pIdx]) DO
     INC(from);
     INC(pIdx);
   END;
   DEC(from, pIdx);

   IF pIdx = pLen THEN
     RETURN(CAST(INTEGER,from));
   ELSIF tries = 0 THEN
     RETURN(NOTFOUND);
   END;

   INC(from);
   DEC(tries);
 END;
END LPOS;

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

PROCEDURE RPOS ((* EIN/ -- *)     from : CARDINAL;
                (* EIN/ -- *) REF pat  : ARRAY OF CHAR;
                (* EIN/ -- *) REF s    : ARRAY OF CHAR ): INTEGER;
(*T*)
VAR sLen  : CARDINAL;
    pLen  : CARDINAL;
    pIdx  : CARDINAL;

BEGIN
 sLen := SLEN(s);;
 pLen := SLEN(pat);

 IF (pLen = 0) OR (pLen > sLen) THEN
   RETURN(NOTFOUND);
 END;
 IF from > sLen - pLen THEN
   from := sLen - pLen;
 END;

 LOOP
   pIdx := 0;
   WHILE (pIdx < pLen) AND (s[from] = pat[pIdx]) DO
     INC(from);
     INC(pIdx);
   END;
   DEC(from, pIdx);

   IF pIdx = pLen THEN
     RETURN(CAST(INTEGER,from));
   ELSIF from = 0 THEN
     RETURN(NOTFOUND);
   END;

   DEC(from);
 END;
END RPOS;

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

PROCEDURE LPOSCHR ((* EIN/ -- *)     from : CARDINAL;
                   (* EIN/ -- *)     c    : CHAR;
                   (* EIN/ -- *) REF s    : ARRAY OF CHAR ): INTEGER;
(*T*)
VAR len : CARDINAL;

BEGIN
 len := SLEN(s);

 WHILE (from < len) AND (s[from] <> c) DO
   INC(from);
 END;

 IF from >= len THEN
   RETURN(NOTFOUND);
 ELSE
   RETURN(CAST(INTEGER,from));
 END;
END LPOSCHR;

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

PROCEDURE RPOSCHR ((* EIN/ -- *)     from : CARDINAL;
                   (* EIN/ -- *)     c    : CHAR;
                   (* EIN/ -- *) REF s    : ARRAY OF CHAR ): INTEGER;
(*T*)
VAR len : CARDINAL;

BEGIN
 len := SLEN(s);

 IF len = 0 THEN
   RETURN(NOTFOUND);
 ELSIF from >= len THEN
   from := len - 1;
 END;

 WHILE (from > 0) AND (s[from] <> c) DO
   DEC(from);
 END;
 IF s[from] = c THEN
   RETURN(CAST(INTEGER,from));
 ELSE
   RETURN(NOTFOUND);
 END;
END RPOSCHR;

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

PROCEDURE LPOSCHRSET ((* EIN/ -- *)     from : CARDINAL;
                      (* EIN/ -- *) REF set  : ARRAY OF CHAR;
                      (* EIN/ -- *) REF str  : ARRAY OF CHAR ): INTEGER;
(*T*)
VAR strLen, setLen : CARDINAL;
    setIdx         : CARDINAL;
    c              : CHAR;

BEGIN
 strLen := SLEN(str);
 setLen := SLEN(set);
 IF (from >= strLen) OR (setLen = 0) THEN
   RETURN(NOTFOUND);
 END;

 LOOP
   c      := str[from];
   setIdx := 0;
   WHILE (setIdx < setLen) AND (c <> set[setIdx]) DO
     INC(setIdx);
   END;

   IF setIdx < setLen THEN
     RETURN(CAST(INTEGER,from));
   ELSIF from >= strLen THEN
     RETURN(NOTFOUND);
   ELSE
     INC(from);
   END;
 END;
END LPOSCHRSET;

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

PROCEDURE RPOSCHRSET ((* EIN/ -- *)     from : CARDINAL;
                      (* EIN/ -- *) REF set  : ARRAY OF CHAR;
                      (* EIN/ -- *) REF str  : ARRAY OF CHAR ): INTEGER;
(*T*)
VAR strLen, setLen : CARDINAL;
    setIdx         : CARDINAL;
    c              : CHAR;

BEGIN
 strLen := SLEN(str);
 setLen := SLEN(set);

 IF (setLen = 0) OR (strLen = 0) THEN
   RETURN(NOTFOUND);
 ELSIF from >= strLen THEN
   from := strLen - 1;
 END;

 LOOP
   c      := str[from];
   setIdx := 0;
   WHILE (setIdx < setLen) AND (c <> set[setIdx]) DO
     INC(setIdx);
   END;

   IF setIdx < setLen THEN
     RETURN(CAST(INTEGER,from));
   ELSIF from = 0 THEN
     RETURN(NOTFOUND);
   ELSE
     DEC(from);
   END;
 END;
END RPOSCHRSET;

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

PROCEDURE TOKEN ((* EIN/ -- *)     str   : ARRAY OF CHAR;
                 (* EIN/ -- *)     stop  : ARRAY OF CHAR;
                 (* EIN/AUS *) VAR idx   : CARDINAL;
                 (* EIN/AUS *) VAR l1    : CARDINAL;
                 (* EIN/AUS *) VAR l2    : CARDINAL;
                 (* -- /AUS *) VAR token : ARRAY OF CHAR ): BOOLEAN;
(*T*)
VAR end      : INTEGER;
    min, max : CARDINAL;
    strLen   : CARDINAL;
    stpLen   : CARDINAL;

BEGIN
 IF l1 = 0 THEN
   (* Beim ersten Aufruf muessen die Stringlaengen berechnet werden.
    * Sie werden fuer spaetere Aufrufe gemerkt.
    *)
   l1 := SLEN(str);
   l2 := SLEN(stop);
 END;
 strLen := l1;
 stpLen := l2;

 min := idx;
 IF (min >= strLen) OR (stpLen = 0) THEN
   (* <str> vollstaendig durchsucht *)
   token[0] := EOS;
   RETURN(FALSE);
 END;

 WHILE (min < strLen) AND ISSPACE(str[min]) DO
   (* fuehrende Leerzeichen ueberlesen *)
   INC(min);
 END;

 (* abschliessendes Trennzeichen suchen, das fuehrende wurde schon
  * beim letzten Mal ueberlesen, oder es ist das erste Token im String.
  *)
 end := LPOSCHRSET(min, stop, str);
 IF end < 0 THEN
   (* Kein Trennzeichen mehr -> jetzt kommt letztes Token, oder der
    * String ist zuende.
    *)
   max := strLen;
   idx := MAXCARD; (* beim naechsten Mal abbrechen *)
 ELSE
   max := CAST(CARDINAL,end);
   idx := max + 1; (* beim naechsten Mal hinter dem Trenner starten *)
 END;

 WHILE (max > min) AND ISSPACE(str[max-1]) DO
   (* abschliessende Leerzeichen ueberlesen *)
   DEC(max);
 END;

 (* Token ohne fuehrende und abschliessende Leerzeichen abspeichern *)
 COPY(min, max - min, str, token);
 RETURN(TRUE);
END TOKEN;

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

PROCEDURE LenC ((* EIN/ -- *) strC : StrPtr ): CARDINAL;
(*T*)
VAR len : StrRange;

BEGIN
 IF (strC = NIL) OR (strC = NULL) THEN
   RETURN(0);
 END;
 len := 0;
 WHILE strC^[len] <> 0C DO
   INC(len);
 END;
 RETURN(VAL(CARDINAL,len));
END LenC;

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

PROCEDURE AssignM2ToC ((* EIN/ -- *) strM2 : ARRAY OF CHAR;
                       (* EIN/ -- *) sizeC : StrRange;
                       (* EIN/ -- *) strC  : StrPtr        );
(*T*)
VAR idx : StrRange;

BEGIN
 IF (strC = NIL) OR (strC = NULL) THEN
   RETURN;
 END;
 IF sizeC = 0 THEN
   RETURN;
 ELSE
   DEC(sizeC); (* Platz fuer das Nullbyte abziehen *)
 END;

 IF VAL(StrRange,HIGH(strM2)) < sizeC THEN
   sizeC := VAL(StrRange,HIGH(strM2)) + 1;
   (* Plus eins, da der M2-String nicht mit einem Nullbyte abgeschlossen sein
    * muss; er kann also bis zum Ende des Feldes gehen.
    *)
 END;
 idx := 0;
 WHILE (idx < sizeC) AND (strM2[idx] <> EOS) DO
   strC^[idx] := strM2[idx];
   INC(idx);
 END;
 strC^[idx] := 0C;
END AssignM2ToC;

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

PROCEDURE AssignCToM2 ((* EIN/ -- *)     strC  : StrPtr;
                       (* -- /AUS *) VAR strM2 : ARRAY OF CHAR );
(*T*)
VAR idx : StrRange;
    c   : CHAR;

BEGIN
 IF (strC = NIL) OR (strC = NULL) THEN
   strM2[0] := EOS;
   RETURN;
 END;
 idx := 0;
 c   := strC^[0];
 WHILE (idx <= VAL(StrRange,HIGH(strM2))) AND (c <> 0C) DO
   strM2[idx] := c;
   INC(idx);
   c := strC^[idx];
 END;
 IF idx <= VAL(StrRange,HIGH(strM2)) THEN
   strM2[idx] := EOS;
 END;
END AssignCToM2;

END pSTRING.