Amiga ISO Collection/AmigaUtilCD2.iso/Programming/Misc/OB3.2D2.DMS/in.adf/Module/Strings.mod

Text File | 1994-08-05 | 5.8 KB | 228 lines

(*-------------------------------------------------------------------------*)
(*                                                                         *)
(*  Amiga Oberon Library Module: Strings              Date: 02-Nov-92      *)
(*                                                                         *)
(*   © 1992 by Fridtjof Siebert                                            *)
(*                                                                         *)
(*-------------------------------------------------------------------------*)

MODULE Strings;

IMPORT s := SYSTEM, u := Utility;

PROCEDURE Length*(str: ARRAY OF CHAR): LONGINT; (* $EntryExitCode- *)
BEGIN
s.INLINE(0225FH,                  (*     MOVEA.L     (A7)+,A1       *)
         0201FH,                  (*     MOVE.L      (A7)+,D0       *)
         0205FH,                  (*     MOVEA.L     (A7)+,A0       *)
         05380H,                  (*     SUBQ.L      #1,D0          *)
         02200H,                  (*     MOVE.L      D0,D1          *)
         04A18H,                  (* l:  TST.B       (A0)+          *)
         057C9H,0FFFCH,           (*     DBEQ        D1,l           *)
         06708H,                  (*     BEQ         e              *)
         00481H,00001H,00000H,    (*     SUBI.L      #00010000H,D1  *)
         06AF0H,                  (*     BPL         l              *)
         09081H,                  (* e:  SUB.L       D1,D0          *)
         04ED1H);                 (*     JMP         (A1)           *)
END Length;


PROCEDURE Append*(VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); (* $CopyArrays- *)
(* hängt s2 an s1 an *)

VAR l,p,q: LONGINT;
BEGIN
  p := Length(s1);
  l := Length(s2);
  q := 0;
  WHILE (p<LEN(s1)) & (q<l) DO
    s1[p] := s2[q];
    INC(p); INC(q);
  END;
  IF p<LEN(s1) THEN s1[p] := 0X END;
END Append;


PROCEDURE Occurs*(VAR  s: ARRAY OF CHAR;
                  search: ARRAY OF CHAR): LONGINT;  (* $CopyArrays- *)
(* prüft, ob search in s vorkommt und gibt die Position oder -1 zurück *)

VAR l,L,i,j,start: LONGINT;

BEGIN
  l := Length(s); L := Length(search); start := 0;
  WHILE start<=l-L DO
    j := 0; i := start;
    WHILE (j<L) & (search[j]=s[i]) DO
      INC(j); INC(i);
    END;
    IF j=L THEN RETURN i-L END;
    INC(start);
  END;
  RETURN -1;
END Occurs;


PROCEDURE OccursPos*(VAR  s: ARRAY OF CHAR;
                     search: ARRAY OF CHAR;
                      start: LONGINT): LONGINT;  (* $CopyArrays- *)
(* prüft, ob search ab Zeichen Nummer start in s vorkommt und gibt die
Position oder -1 zurück *)

VAR l,L,i,j: LONGINT;

BEGIN
  l := Length(s); L := Length(search);
  WHILE start<l DO
    j := 0; i := start;
    WHILE (j<L) & (search[j]=s[i]) DO
      INC(j); INC(i);
    END;
    IF j=L THEN RETURN i-L END;
    INC(start);
  END;
  RETURN -1;
END OccursPos;


PROCEDURE Cut*(VAR  s: ARRAY OF CHAR; from,cnt: LONGINT;
               VAR to: ARRAY OF CHAR);
(* kopiert von Zeichen from ausgehend cnt Zeichen nach to *)

VAR i: LONGINT;

BEGIN
  i := 0;
  WHILE (i<cnt) & (from<LEN(s)) & (i<LEN(to)) DO
    to[i] := s[from];
    INC(i);
    INC(from);
  END;
  IF i<LEN(to) THEN to[i] := 0X END;
END Cut;


PROCEDURE Upper*(VAR s: ARRAY OF CHAR);
(* wandelt alle Buchstaben in Großbuchstaben um. Ist für Caseinsensitives
   Vergleichen nützlich *)

VAR i: LONGINT;
BEGIN
  i := 0;
  WHILE (i<LEN(s)) & (s[i]#0X) DO s[i] := CAP(s[i]); INC(i) END;
END Upper;


PROCEDURE CapIntl*(c: CHAR): CHAR;
(* wandelt c in einen Großbuchstaben um.
 * Im Gegensatz zur Standardprozedur CAP werden hier auch die
 * internationalen Zeichen wie 'ä' oder 'ú' umgewandelt.
 *)

BEGIN
  IF u.base#NIL THEN
    RETURN u.ToUpper(c);
  ELSE
    CASE c OF
    | "a".."z","à".."ö","ø".."þ": DEC(c,32)
    ELSE END;
    RETURN c;
  END;
END CapIntl;


PROCEDURE UpperIntl*(VAR s: ARRAY OF CHAR);
(* wandelt alle Buchstaben in Großbuchstaben um. Ist für Caseinsensitives
 * Vergleichen nützlich: Im Gegensatz zu Upper werden hier auch die
 * internationalen Zeichen wie 'ä' oder 'ú' umgewandelt.
 *)

VAR i: LONGINT;
BEGIN
  i := 0;
  WHILE (i<LEN(s)) & (s[i]#0X) DO
    s[i] := CapIntl(s[i]);
    INC(i);
  END;
END UpperIntl;


PROCEDURE Insert*(VAR s: ARRAY OF CHAR;   (* $CopyArrays- *)
                     at: LONGINT;
                    str: ARRAY OF CHAR);
(* fügt str in s an der Stelle at eine. Beispiel:
   s = "Hallo"; Insert(s,3,"liHal");
     dies ergibt "HalliHallo". *)

VAR l1,l2,i: LONGINT;
BEGIN
  l1 := Length(s);
  l2 := Length(str);
  i := l1; WHILE (i>=at) DO         s[i+l2] := s  [i]; DEC(i) END;
  i := l2; WHILE (i>  0) DO DEC(i); s[at+i] := str[i]         END;
END Insert;


PROCEDURE Delete*(VAR s: ARRAY OF CHAR; at, cnt: LONGINT);
(* löscht n Zeichen aus s ab der Stelle at.
   Beispiel Delete("abcdefg",3,3) ergibt "abcg". *)
VAR l: LONGINT;
BEGIN
  l := Length(s)-cnt;
  WHILE at<l DO
    s[at] := s[at+cnt];
    INC(at);
  END;
  IF at<LEN(s) THEN s[at] := 0X END;
END Delete;


PROCEDURE AppendChar*(VAR s: ARRAY OF CHAR; c: CHAR);
(* hängt c an s1 an *)

VAR l: LONGINT;
BEGIN
  l := Length(s);
  s[l] := c; INC(l);
  IF l<LEN(s) THEN s[l] := 0X END;
END AppendChar;


PROCEDURE InsertChar*(VAR s: ARRAY OF CHAR;
                         at: LONGINT;
                          c: CHAR);
(* fügt c in s an der Stelle at eine. Beispiel:
   s = "Halo"; Insert(s,3,"l");
     dies ergibt "Hallo". *)

VAR i: LONGINT;
BEGIN
  i := Length(s);
  WHILE (i>=at) DO s[i+1] := s[i]; DEC(i) END;
  s[at] := c;
END InsertChar;


PROCEDURE OverWrite*(VAR string: ARRAY OF CHAR; (* $CopyArrays- *)
                        overlay: ARRAY OF CHAR;
                            pos: LONGINT);
VAR
  i, len: LONGINT;
BEGIN
  len := Length(overlay)-1;
  IF pos+len > LEN(string) THEN
    len := LEN(string)-pos;
  END;
  i := 0;
  WHILE i <= len DO
    string[pos] := overlay[i];
    INC(pos); INC(i);
  END;
END OverWrite;


END Strings.